aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore17
-rw-r--r--lux-bootstrapper/src/lux/analyser/base.clj2
-rw-r--r--lux-bootstrapper/src/lux/base.clj5
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm.clj4
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm/base.clj8
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm/case.clj16
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm/lux.clj13
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj13
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm/rt.clj28
-rw-r--r--lux-bootstrapper/src/lux/host.clj13
-rw-r--r--lux-bootstrapper/src/lux/repl.clj2
-rw-r--r--lux-bootstrapper/src/lux/type.clj42
-rw-r--r--lux-bootstrapper/src/lux/type/host.clj2
-rw-r--r--lux-js/source/program.lux125
-rw-r--r--lux-jvm/source/luxc/lang/directive/jvm.lux69
-rw-r--r--lux-jvm/source/luxc/lang/host/jvm.lux55
-rw-r--r--lux-jvm/source/luxc/lang/host/jvm/def.lux45
-rw-r--r--lux-jvm/source/luxc/lang/host/jvm/inst.lux69
-rw-r--r--lux-jvm/source/luxc/lang/synthesis/variable.lux3
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm.lux71
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/case.lux53
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/common.lux43
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/expression.lux17
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/extension.lux9
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux67
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux103
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/function.lux69
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/loop.lux41
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/primitive.lux23
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/program.lux27
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/reference.lux39
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/runtime.lux63
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/structure.lux59
-rw-r--r--lux-jvm/source/program.lux113
-rw-r--r--lux-lua/source/program.lux121
l---------lux-php/source/lux.lux1
-rw-r--r--lux-python/source/program.lux125
-rw-r--r--lux-ruby/source/program.lux139
-rw-r--r--stdlib/source/library/lux.lux5958
-rw-r--r--stdlib/source/library/lux/abstract/algebra.lux17
-rw-r--r--stdlib/source/library/lux/abstract/apply.lux37
-rw-r--r--stdlib/source/library/lux/abstract/codec.lux29
-rw-r--r--stdlib/source/library/lux/abstract/comonad.lux79
-rw-r--r--stdlib/source/library/lux/abstract/comonad/cofree.lux28
-rw-r--r--stdlib/source/library/lux/abstract/enum.lux26
-rw-r--r--stdlib/source/library/lux/abstract/equivalence.lux25
-rw-r--r--stdlib/source/library/lux/abstract/fold.lux17
-rw-r--r--stdlib/source/library/lux/abstract/functor.lux45
-rw-r--r--stdlib/source/library/lux/abstract/functor/contravariant.lux9
-rw-r--r--stdlib/source/library/lux/abstract/hash.lux27
-rw-r--r--stdlib/source/library/lux/abstract/interval.lux194
-rw-r--r--stdlib/source/library/lux/abstract/monad.lux184
-rw-r--r--stdlib/source/library/lux/abstract/monad/free.lux68
-rw-r--r--stdlib/source/library/lux/abstract/monad/indexed.lux84
-rw-r--r--stdlib/source/library/lux/abstract/monoid.lux21
-rw-r--r--stdlib/source/library/lux/abstract/order.lux58
-rw-r--r--stdlib/source/library/lux/abstract/predicate.lux61
-rw-r--r--stdlib/source/library/lux/control/concatenative.lux331
-rw-r--r--stdlib/source/library/lux/control/concurrency/actor.lux390
-rw-r--r--stdlib/source/library/lux/control/concurrency/atom.lux103
-rw-r--r--stdlib/source/library/lux/control/concurrency/frp.lux296
-rw-r--r--stdlib/source/library/lux/control/concurrency/promise.lux200
-rw-r--r--stdlib/source/library/lux/control/concurrency/semaphore.lux174
-rw-r--r--stdlib/source/library/lux/control/concurrency/stm.lux274
-rw-r--r--stdlib/source/library/lux/control/concurrency/thread.lux170
-rw-r--r--stdlib/source/library/lux/control/continuation.lux100
-rw-r--r--stdlib/source/library/lux/control/exception.lux184
-rw-r--r--stdlib/source/library/lux/control/function.lux47
-rw-r--r--stdlib/source/library/lux/control/function/contract.lux52
-rw-r--r--stdlib/source/library/lux/control/function/memo.lux64
-rw-r--r--stdlib/source/library/lux/control/function/mixin.lux64
-rw-r--r--stdlib/source/library/lux/control/function/mutual.lux158
-rw-r--r--stdlib/source/library/lux/control/io.lux72
-rw-r--r--stdlib/source/library/lux/control/parser.lux324
-rw-r--r--stdlib/source/library/lux/control/parser/analysis.lux135
-rw-r--r--stdlib/source/library/lux/control/parser/binary.lux275
-rw-r--r--stdlib/source/library/lux/control/parser/cli.lux99
-rw-r--r--stdlib/source/library/lux/control/parser/code.lux199
-rw-r--r--stdlib/source/library/lux/control/parser/environment.lux44
-rw-r--r--stdlib/source/library/lux/control/parser/json.lux207
-rw-r--r--stdlib/source/library/lux/control/parser/synthesis.lux164
-rw-r--r--stdlib/source/library/lux/control/parser/text.lux377
-rw-r--r--stdlib/source/library/lux/control/parser/tree.lux60
-rw-r--r--stdlib/source/library/lux/control/parser/type.lux349
-rw-r--r--stdlib/source/library/lux/control/parser/xml.lux142
-rw-r--r--stdlib/source/library/lux/control/pipe.lux161
-rw-r--r--stdlib/source/library/lux/control/reader.lux72
-rw-r--r--stdlib/source/library/lux/control/region.lux158
-rw-r--r--stdlib/source/library/lux/control/remember.lux74
-rw-r--r--stdlib/source/library/lux/control/security/capability.lux71
-rw-r--r--stdlib/source/library/lux/control/security/policy.lux93
-rw-r--r--stdlib/source/library/lux/control/state.lux149
-rw-r--r--stdlib/source/library/lux/control/thread.lux106
-rw-r--r--stdlib/source/library/lux/control/try.lux153
-rw-r--r--stdlib/source/library/lux/control/writer.lux78
-rw-r--r--stdlib/source/library/lux/data/binary.lux367
-rw-r--r--stdlib/source/library/lux/data/bit.lux59
-rw-r--r--stdlib/source/library/lux/data/collection/array.lux388
-rw-r--r--stdlib/source/library/lux/data/collection/bits.lux177
-rw-r--r--stdlib/source/library/lux/data/collection/dictionary.lux732
-rw-r--r--stdlib/source/library/lux/data/collection/dictionary/ordered.lux584
-rw-r--r--stdlib/source/library/lux/data/collection/dictionary/plist.lux98
-rw-r--r--stdlib/source/library/lux/data/collection/list.lux616
-rw-r--r--stdlib/source/library/lux/data/collection/queue.lux93
-rw-r--r--stdlib/source/library/lux/data/collection/queue/priority.lux121
-rw-r--r--stdlib/source/library/lux/data/collection/row.lux490
-rw-r--r--stdlib/source/library/lux/data/collection/sequence.lux151
-rw-r--r--stdlib/source/library/lux/data/collection/set.lux105
-rw-r--r--stdlib/source/library/lux/data/collection/set/multi.lux158
-rw-r--r--stdlib/source/library/lux/data/collection/set/ordered.lux85
-rw-r--r--stdlib/source/library/lux/data/collection/stack.lux66
-rw-r--r--stdlib/source/library/lux/data/collection/tree.lux85
-rw-r--r--stdlib/source/library/lux/data/collection/tree/finger.lux108
-rw-r--r--stdlib/source/library/lux/data/collection/tree/zipper.lux318
-rw-r--r--stdlib/source/library/lux/data/color.lux425
-rw-r--r--stdlib/source/library/lux/data/color/named.lux156
-rw-r--r--stdlib/source/library/lux/data/format/binary.lux292
-rw-r--r--stdlib/source/library/lux/data/format/css.lux126
-rw-r--r--stdlib/source/library/lux/data/format/css/font.lux26
-rw-r--r--stdlib/source/library/lux/data/format/css/property.lux503
-rw-r--r--stdlib/source/library/lux/data/format/css/query.lux135
-rw-r--r--stdlib/source/library/lux/data/format/css/selector.lux205
-rw-r--r--stdlib/source/library/lux/data/format/css/style.lux36
-rw-r--r--stdlib/source/library/lux/data/format/css/value.lux1329
-rw-r--r--stdlib/source/library/lux/data/format/html.lux563
-rw-r--r--stdlib/source/library/lux/data/format/json.lux422
-rw-r--r--stdlib/source/library/lux/data/format/markdown.lux181
-rw-r--r--stdlib/source/library/lux/data/format/tar.lux871
-rw-r--r--stdlib/source/library/lux/data/format/xml.lux299
-rw-r--r--stdlib/source/library/lux/data/identity.lux38
-rw-r--r--stdlib/source/library/lux/data/lazy.lux68
-rw-r--r--stdlib/source/library/lux/data/maybe.lux151
-rw-r--r--stdlib/source/library/lux/data/name.lux64
-rw-r--r--stdlib/source/library/lux/data/product.lux69
-rw-r--r--stdlib/source/library/lux/data/store.lux50
-rw-r--r--stdlib/source/library/lux/data/sum.lux90
-rw-r--r--stdlib/source/library/lux/data/text.lux380
-rw-r--r--stdlib/source/library/lux/data/text/buffer.lux115
-rw-r--r--stdlib/source/library/lux/data/text/encoding.lux163
-rw-r--r--stdlib/source/library/lux/data/text/encoding/utf8.lux164
-rw-r--r--stdlib/source/library/lux/data/text/escape.lux244
-rw-r--r--stdlib/source/library/lux/data/text/format.lux135
-rw-r--r--stdlib/source/library/lux/data/text/regex.lux495
-rw-r--r--stdlib/source/library/lux/data/text/unicode/block.lux205
-rw-r--r--stdlib/source/library/lux/data/text/unicode/set.lux240
-rw-r--r--stdlib/source/library/lux/data/trace.lux36
-rw-r--r--stdlib/source/library/lux/debug.lux598
-rw-r--r--stdlib/source/library/lux/extension.lux89
-rw-r--r--stdlib/source/library/lux/ffi.js.lux364
-rw-r--r--stdlib/source/library/lux/ffi.jvm.lux2048
-rw-r--r--stdlib/source/library/lux/ffi.lua.lux310
-rw-r--r--stdlib/source/library/lux/ffi.old.lux1829
-rw-r--r--stdlib/source/library/lux/ffi.php.lux314
-rw-r--r--stdlib/source/library/lux/ffi.py.lux315
-rw-r--r--stdlib/source/library/lux/ffi.rb.lux332
-rw-r--r--stdlib/source/library/lux/ffi.scm.lux220
-rw-r--r--stdlib/source/library/lux/locale.lux45
-rw-r--r--stdlib/source/library/lux/locale/language.lux573
-rw-r--r--stdlib/source/library/lux/locale/territory.lux312
-rw-r--r--stdlib/source/library/lux/macro.lux210
-rw-r--r--stdlib/source/library/lux/macro/code.lux161
-rw-r--r--stdlib/source/library/lux/macro/local.lux106
-rw-r--r--stdlib/source/library/lux/macro/poly.lux128
-rw-r--r--stdlib/source/library/lux/macro/syntax.lux129
-rw-r--r--stdlib/source/library/lux/macro/syntax/annotations.lux42
-rw-r--r--stdlib/source/library/lux/macro/syntax/check.lux42
-rw-r--r--stdlib/source/library/lux/macro/syntax/declaration.lux47
-rw-r--r--stdlib/source/library/lux/macro/syntax/definition.lux141
-rw-r--r--stdlib/source/library/lux/macro/syntax/export.lux21
-rw-r--r--stdlib/source/library/lux/macro/syntax/input.lux38
-rw-r--r--stdlib/source/library/lux/macro/syntax/type/variable.lux28
-rw-r--r--stdlib/source/library/lux/macro/template.lux185
-rw-r--r--stdlib/source/library/lux/math.lux394
-rw-r--r--stdlib/source/library/lux/math/infix.lux96
-rw-r--r--stdlib/source/library/lux/math/logic/continuous.lux40
-rw-r--r--stdlib/source/library/lux/math/logic/fuzzy.lux132
-rw-r--r--stdlib/source/library/lux/math/modular.lux157
-rw-r--r--stdlib/source/library/lux/math/modulus.lux56
-rw-r--r--stdlib/source/library/lux/math/number.lux87
-rw-r--r--stdlib/source/library/lux/math/number/complex.lux316
-rw-r--r--stdlib/source/library/lux/math/number/frac.lux447
-rw-r--r--stdlib/source/library/lux/math/number/i16.lux24
-rw-r--r--stdlib/source/library/lux/math/number/i32.lux24
-rw-r--r--stdlib/source/library/lux/math/number/i64.lux214
-rw-r--r--stdlib/source/library/lux/math/number/i8.lux24
-rw-r--r--stdlib/source/library/lux/math/number/int.lux260
-rw-r--r--stdlib/source/library/lux/math/number/nat.lux380
-rw-r--r--stdlib/source/library/lux/math/number/ratio.lux162
-rw-r--r--stdlib/source/library/lux/math/number/rev.lux463
-rw-r--r--stdlib/source/library/lux/math/random.lux400
-rw-r--r--stdlib/source/library/lux/meta.lux568
-rw-r--r--stdlib/source/library/lux/meta/annotation.lux95
-rw-r--r--stdlib/source/library/lux/meta/location.lux49
-rw-r--r--stdlib/source/library/lux/program.lux83
-rw-r--r--stdlib/source/library/lux/target.lux26
-rw-r--r--stdlib/source/library/lux/target/common_lisp.lux469
-rw-r--r--stdlib/source/library/lux/target/js.lux449
-rw-r--r--stdlib/source/library/lux/target/jvm.lux284
-rw-r--r--stdlib/source/library/lux/target/jvm/attribute.lux123
-rw-r--r--stdlib/source/library/lux/target/jvm/attribute/code.lux83
-rw-r--r--stdlib/source/library/lux/target/jvm/attribute/code/exception.lux58
-rw-r--r--stdlib/source/library/lux/target/jvm/attribute/constant.lux27
-rw-r--r--stdlib/source/library/lux/target/jvm/bytecode.lux1046
-rw-r--r--stdlib/source/library/lux/target/jvm/bytecode/address.lux74
-rw-r--r--stdlib/source/library/lux/target/jvm/bytecode/environment.lux108
-rw-r--r--stdlib/source/library/lux/target/jvm/bytecode/environment/limit.lux58
-rw-r--r--stdlib/source/library/lux/target/jvm/bytecode/environment/limit/registry.lux91
-rw-r--r--stdlib/source/library/lux/target/jvm/bytecode/environment/limit/stack.lux69
-rw-r--r--stdlib/source/library/lux/target/jvm/bytecode/instruction.lux714
-rw-r--r--stdlib/source/library/lux/target/jvm/bytecode/jump.lux27
-rw-r--r--stdlib/source/library/lux/target/jvm/class.lux134
-rw-r--r--stdlib/source/library/lux/target/jvm/constant.lux246
-rw-r--r--stdlib/source/library/lux/target/jvm/constant/pool.lux158
-rw-r--r--stdlib/source/library/lux/target/jvm/constant/tag.lux50
-rw-r--r--stdlib/source/library/lux/target/jvm/encoding/name.lux40
-rw-r--r--stdlib/source/library/lux/target/jvm/encoding/signed.lux107
-rw-r--r--stdlib/source/library/lux/target/jvm/encoding/unsigned.lux121
-rw-r--r--stdlib/source/library/lux/target/jvm/field.lux70
-rw-r--r--stdlib/source/library/lux/target/jvm/index.lux38
-rw-r--r--stdlib/source/library/lux/target/jvm/loader.lux143
-rw-r--r--stdlib/source/library/lux/target/jvm/magic.lux20
-rw-r--r--stdlib/source/library/lux/target/jvm/method.lux104
-rw-r--r--stdlib/source/library/lux/target/jvm/modifier.lux88
-rw-r--r--stdlib/source/library/lux/target/jvm/modifier/inner.lux21
-rw-r--r--stdlib/source/library/lux/target/jvm/reflection.lux382
-rw-r--r--stdlib/source/library/lux/target/jvm/type.lux205
-rw-r--r--stdlib/source/library/lux/target/jvm/type/alias.lux116
-rw-r--r--stdlib/source/library/lux/target/jvm/type/box.lux19
-rw-r--r--stdlib/source/library/lux/target/jvm/type/category.lux36
-rw-r--r--stdlib/source/library/lux/target/jvm/type/descriptor.lux123
-rw-r--r--stdlib/source/library/lux/target/jvm/type/lux.lux189
-rw-r--r--stdlib/source/library/lux/target/jvm/type/parser.lux253
-rw-r--r--stdlib/source/library/lux/target/jvm/type/reflection.lux104
-rw-r--r--stdlib/source/library/lux/target/jvm/type/signature.lux134
-rw-r--r--stdlib/source/library/lux/target/jvm/version.lux38
-rw-r--r--stdlib/source/library/lux/target/lua.lux416
-rw-r--r--stdlib/source/library/lux/target/php.lux545
-rw-r--r--stdlib/source/library/lux/target/python.lux501
-rw-r--r--stdlib/source/library/lux/target/r.lux386
-rw-r--r--stdlib/source/library/lux/target/ruby.lux473
-rw-r--r--stdlib/source/library/lux/target/scheme.lux380
-rw-r--r--stdlib/source/library/lux/test.lux419
-rw-r--r--stdlib/source/library/lux/time.lux217
-rw-r--r--stdlib/source/library/lux/time/date.lux349
-rw-r--r--stdlib/source/library/lux/time/day.lux121
-rw-r--r--stdlib/source/library/lux/time/duration.lux203
-rw-r--r--stdlib/source/library/lux/time/instant.lux235
-rw-r--r--stdlib/source/library/lux/time/month.lux225
-rw-r--r--stdlib/source/library/lux/time/year.lux142
-rw-r--r--stdlib/source/library/lux/tool/compiler.lux47
-rw-r--r--stdlib/source/library/lux/tool/compiler/arity.lux16
-rw-r--r--stdlib/source/library/lux/tool/compiler/default/init.lux287
-rw-r--r--stdlib/source/library/lux/tool/compiler/default/platform.lux602
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux.lux107
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/analysis.lux556
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/analysis/evaluation.lux57
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/analysis/macro.lux52
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/directive.lux83
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/generation.lux336
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux144
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux325
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux373
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/function.lux113
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/inference.lux301
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux275
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/primitive.lux33
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux85
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/scope.lux206
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux361
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/type.lux56
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/directive.lux79
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension.lux177
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis.lux16
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux35
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux218
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux2076
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux252
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux301
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux214
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux231
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux35
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux199
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux158
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/bundle.lux29
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux307
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux451
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux18
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux180
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux40
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js.lux18
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux191
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux160
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux20
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux414
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux1106
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux18
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux181
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux200
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php.lux18
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux192
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux143
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python.lux18
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux171
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux165
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r.lux18
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux179
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux40
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux18
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux186
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux136
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux18
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux175
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux109
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/synthesis.lux11
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux57
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux262
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux14
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux137
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux103
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux70
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux21
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux13
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux293
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux37
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/extension.lux66
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js.lux117
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/case.lux322
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/function.lux123
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/loop.lux91
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux21
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/reference.lux13
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux785
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/structure.lux38
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm.lux73
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux266
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux31
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux135
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux24
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux26
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux22
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux56
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux40
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux59
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux31
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux14
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux157
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux42
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux98
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux81
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux50
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux161
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux90
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux121
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux144
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux67
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux611
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux95
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux23
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux49
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua.lux119
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/case.lux280
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux137
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux119
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux16
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux13
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux432
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux37
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php.lux103
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/case.lux298
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension.lux14
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux112
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/function.lux116
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/loop.lux122
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux32
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/reference.lux13
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux610
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/structure.lux42
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python.lux113
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/case.lux334
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/function.lux112
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/loop.lux122
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux18
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/reference.lux13
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux456
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/structure.lux37
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r.lux59
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/case.lux240
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/function.lux117
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/loop.lux65
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux18
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux340
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux90
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/reference.lux13
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux855
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/structure.lux40
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/reference.lux89
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby.lux105
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux360
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux112
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux96
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux16
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux13
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux403
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux37
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme.lux59
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux223
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux14
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux223
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux101
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux64
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux16
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux13
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux370
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux40
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis.lux104
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/case.lux430
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/function.lux277
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/loop.lux187
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/variable.lux443
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/program.lux57
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/syntax.lux584
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/synthesis.lux809
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/version.lux9
-rw-r--r--stdlib/source/library/lux/tool/compiler/meta.lux9
-rw-r--r--stdlib/source/library/lux/tool/compiler/meta/archive.lux280
-rw-r--r--stdlib/source/library/lux/tool/compiler/meta/archive/artifact.lux155
-rw-r--r--stdlib/source/library/lux/tool/compiler/meta/archive/descriptor.lux49
-rw-r--r--stdlib/source/library/lux/tool/compiler/meta/archive/document.lux72
-rw-r--r--stdlib/source/library/lux/tool/compiler/meta/archive/key.lux19
-rw-r--r--stdlib/source/library/lux/tool/compiler/meta/archive/signature.lux42
-rw-r--r--stdlib/source/library/lux/tool/compiler/meta/cache/dependency.lux97
-rw-r--r--stdlib/source/library/lux/tool/compiler/meta/io.lux20
-rw-r--r--stdlib/source/library/lux/tool/compiler/meta/io/archive.lux450
-rw-r--r--stdlib/source/library/lux/tool/compiler/meta/io/context.lux170
-rw-r--r--stdlib/source/library/lux/tool/compiler/meta/packager.lux43
-rw-r--r--stdlib/source/library/lux/tool/compiler/meta/packager/jvm.lux145
-rw-r--r--stdlib/source/library/lux/tool/compiler/meta/packager/scheme.lux132
-rw-r--r--stdlib/source/library/lux/tool/compiler/meta/packager/script.lux76
-rw-r--r--stdlib/source/library/lux/tool/compiler/phase.lux119
-rw-r--r--stdlib/source/library/lux/tool/compiler/reference.lux85
-rw-r--r--stdlib/source/library/lux/tool/compiler/reference/variable.lux68
-rw-r--r--stdlib/source/library/lux/tool/compiler/version.lux52
-rw-r--r--stdlib/source/library/lux/tool/interpreter.lux222
-rw-r--r--stdlib/source/library/lux/tool/mediator.lux19
-rw-r--r--stdlib/source/library/lux/type.lux463
-rw-r--r--stdlib/source/library/lux/type/abstract.lux269
-rw-r--r--stdlib/source/library/lux/type/check.lux721
-rw-r--r--stdlib/source/library/lux/type/dynamic.lux51
-rw-r--r--stdlib/source/library/lux/type/implicit.lux401
-rw-r--r--stdlib/source/library/lux/type/quotient.lux56
-rw-r--r--stdlib/source/library/lux/type/refinement.lux89
-rw-r--r--stdlib/source/library/lux/type/resource.lux218
-rw-r--r--stdlib/source/library/lux/type/unit.lux188
-rw-r--r--stdlib/source/library/lux/type/variance.lux12
-rw-r--r--stdlib/source/library/lux/world/console.lux159
-rw-r--r--stdlib/source/library/lux/world/db/jdbc.lux176
-rw-r--r--stdlib/source/library/lux/world/db/jdbc/input.lux107
-rw-r--r--stdlib/source/library/lux/world/db/jdbc/output.lux195
-rw-r--r--stdlib/source/library/lux/world/db/sql.lux476
-rw-r--r--stdlib/source/library/lux/world/file.lux1303
-rw-r--r--stdlib/source/library/lux/world/file/watch.lux459
-rw-r--r--stdlib/source/library/lux/world/input/keyboard.lux112
-rw-r--r--stdlib/source/library/lux/world/net.lux13
-rw-r--r--stdlib/source/library/lux/world/net/http.lux80
-rw-r--r--stdlib/source/library/lux/world/net/http/client.lux227
-rw-r--r--stdlib/source/library/lux/world/net/http/cookie.lux88
-rw-r--r--stdlib/source/library/lux/world/net/http/header.lux35
-rw-r--r--stdlib/source/library/lux/world/net/http/mime.lux100
-rw-r--r--stdlib/source/library/lux/world/net/http/query.lux65
-rw-r--r--stdlib/source/library/lux/world/net/http/request.lux128
-rw-r--r--stdlib/source/library/lux/world/net/http/response.lux74
-rw-r--r--stdlib/source/library/lux/world/net/http/route.lux74
-rw-r--r--stdlib/source/library/lux/world/net/http/status.lux83
-rw-r--r--stdlib/source/library/lux/world/net/http/version.lux13
-rw-r--r--stdlib/source/library/lux/world/net/uri.lux9
-rw-r--r--stdlib/source/library/lux/world/output/video/resolution.lux47
-rw-r--r--stdlib/source/library/lux/world/program.lux451
-rw-r--r--stdlib/source/library/lux/world/service/authentication.lux25
-rw-r--r--stdlib/source/library/lux/world/service/crud.lux33
-rw-r--r--stdlib/source/library/lux/world/service/inventory.lux31
-rw-r--r--stdlib/source/library/lux/world/service/journal.lux51
-rw-r--r--stdlib/source/library/lux/world/service/mail.lux19
-rw-r--r--stdlib/source/library/lux/world/shell.lux374
-rw-r--r--stdlib/source/lux.lux5953
-rw-r--r--stdlib/source/lux/abstract/algebra.lux16
-rw-r--r--stdlib/source/lux/abstract/apply.lux36
-rw-r--r--stdlib/source/lux/abstract/codec.lux28
-rw-r--r--stdlib/source/lux/abstract/comonad.lux78
-rw-r--r--stdlib/source/lux/abstract/comonad/cofree.lux27
-rw-r--r--stdlib/source/lux/abstract/enum.lux25
-rw-r--r--stdlib/source/lux/abstract/equivalence.lux24
-rw-r--r--stdlib/source/lux/abstract/fold.lux16
-rw-r--r--stdlib/source/lux/abstract/functor.lux44
-rw-r--r--stdlib/source/lux/abstract/functor/contravariant.lux8
-rw-r--r--stdlib/source/lux/abstract/hash.lux26
-rw-r--r--stdlib/source/lux/abstract/interval.lux193
-rw-r--r--stdlib/source/lux/abstract/monad.lux183
-rw-r--r--stdlib/source/lux/abstract/monad/free.lux67
-rw-r--r--stdlib/source/lux/abstract/monad/indexed.lux83
-rw-r--r--stdlib/source/lux/abstract/monoid.lux20
-rw-r--r--stdlib/source/lux/abstract/order.lux57
-rw-r--r--stdlib/source/lux/abstract/predicate.lux60
-rw-r--r--stdlib/source/lux/control/concatenative.lux330
-rw-r--r--stdlib/source/lux/control/concurrency/actor.lux389
-rw-r--r--stdlib/source/lux/control/concurrency/atom.lux102
-rw-r--r--stdlib/source/lux/control/concurrency/frp.lux295
-rw-r--r--stdlib/source/lux/control/concurrency/promise.lux199
-rw-r--r--stdlib/source/lux/control/concurrency/semaphore.lux173
-rw-r--r--stdlib/source/lux/control/concurrency/stm.lux273
-rw-r--r--stdlib/source/lux/control/concurrency/thread.lux169
-rw-r--r--stdlib/source/lux/control/continuation.lux99
-rw-r--r--stdlib/source/lux/control/exception.lux183
-rw-r--r--stdlib/source/lux/control/function.lux46
-rw-r--r--stdlib/source/lux/control/function/contract.lux51
-rw-r--r--stdlib/source/lux/control/function/memo.lux63
-rw-r--r--stdlib/source/lux/control/function/mixin.lux63
-rw-r--r--stdlib/source/lux/control/function/mutual.lux157
-rw-r--r--stdlib/source/lux/control/io.lux71
-rw-r--r--stdlib/source/lux/control/parser.lux323
-rw-r--r--stdlib/source/lux/control/parser/analysis.lux134
-rw-r--r--stdlib/source/lux/control/parser/binary.lux274
-rw-r--r--stdlib/source/lux/control/parser/cli.lux98
-rw-r--r--stdlib/source/lux/control/parser/code.lux198
-rw-r--r--stdlib/source/lux/control/parser/environment.lux43
-rw-r--r--stdlib/source/lux/control/parser/json.lux206
-rw-r--r--stdlib/source/lux/control/parser/synthesis.lux163
-rw-r--r--stdlib/source/lux/control/parser/text.lux376
-rw-r--r--stdlib/source/lux/control/parser/tree.lux59
-rw-r--r--stdlib/source/lux/control/parser/type.lux348
-rw-r--r--stdlib/source/lux/control/parser/xml.lux141
-rw-r--r--stdlib/source/lux/control/pipe.lux160
-rw-r--r--stdlib/source/lux/control/reader.lux71
-rw-r--r--stdlib/source/lux/control/region.lux157
-rw-r--r--stdlib/source/lux/control/remember.lux73
-rw-r--r--stdlib/source/lux/control/security/capability.lux70
-rw-r--r--stdlib/source/lux/control/security/policy.lux92
-rw-r--r--stdlib/source/lux/control/state.lux148
-rw-r--r--stdlib/source/lux/control/thread.lux105
-rw-r--r--stdlib/source/lux/control/try.lux151
-rw-r--r--stdlib/source/lux/control/writer.lux77
-rw-r--r--stdlib/source/lux/data/binary.lux366
-rw-r--r--stdlib/source/lux/data/bit.lux58
-rw-r--r--stdlib/source/lux/data/collection/array.lux387
-rw-r--r--stdlib/source/lux/data/collection/bits.lux176
-rw-r--r--stdlib/source/lux/data/collection/dictionary.lux731
-rw-r--r--stdlib/source/lux/data/collection/dictionary/ordered.lux583
-rw-r--r--stdlib/source/lux/data/collection/dictionary/plist.lux97
-rw-r--r--stdlib/source/lux/data/collection/list.lux615
-rw-r--r--stdlib/source/lux/data/collection/queue.lux92
-rw-r--r--stdlib/source/lux/data/collection/queue/priority.lux120
-rw-r--r--stdlib/source/lux/data/collection/row.lux489
-rw-r--r--stdlib/source/lux/data/collection/sequence.lux150
-rw-r--r--stdlib/source/lux/data/collection/set.lux104
-rw-r--r--stdlib/source/lux/data/collection/set/multi.lux157
-rw-r--r--stdlib/source/lux/data/collection/set/ordered.lux84
-rw-r--r--stdlib/source/lux/data/collection/stack.lux65
-rw-r--r--stdlib/source/lux/data/collection/tree.lux84
-rw-r--r--stdlib/source/lux/data/collection/tree/finger.lux107
-rw-r--r--stdlib/source/lux/data/collection/tree/zipper.lux317
-rw-r--r--stdlib/source/lux/data/color.lux424
-rw-r--r--stdlib/source/lux/data/color/named.lux155
-rw-r--r--stdlib/source/lux/data/format/binary.lux291
-rw-r--r--stdlib/source/lux/data/format/css.lux125
-rw-r--r--stdlib/source/lux/data/format/css/font.lux25
-rw-r--r--stdlib/source/lux/data/format/css/property.lux502
-rw-r--r--stdlib/source/lux/data/format/css/query.lux134
-rw-r--r--stdlib/source/lux/data/format/css/selector.lux204
-rw-r--r--stdlib/source/lux/data/format/css/style.lux35
-rw-r--r--stdlib/source/lux/data/format/css/value.lux1328
-rw-r--r--stdlib/source/lux/data/format/html.lux562
-rw-r--r--stdlib/source/lux/data/format/json.lux421
-rw-r--r--stdlib/source/lux/data/format/markdown.lux180
-rw-r--r--stdlib/source/lux/data/format/tar.lux870
-rw-r--r--stdlib/source/lux/data/format/xml.lux298
-rw-r--r--stdlib/source/lux/data/identity.lux37
-rw-r--r--stdlib/source/lux/data/lazy.lux67
-rw-r--r--stdlib/source/lux/data/maybe.lux150
-rw-r--r--stdlib/source/lux/data/name.lux63
-rw-r--r--stdlib/source/lux/data/product.lux68
-rw-r--r--stdlib/source/lux/data/store.lux49
-rw-r--r--stdlib/source/lux/data/sum.lux89
-rw-r--r--stdlib/source/lux/data/text.lux379
-rw-r--r--stdlib/source/lux/data/text/buffer.lux114
-rw-r--r--stdlib/source/lux/data/text/encoding.lux162
-rw-r--r--stdlib/source/lux/data/text/encoding/utf8.lux163
-rw-r--r--stdlib/source/lux/data/text/escape.lux243
-rw-r--r--stdlib/source/lux/data/text/format.lux134
-rw-r--r--stdlib/source/lux/data/text/regex.lux494
-rw-r--r--stdlib/source/lux/data/text/unicode/block.lux204
-rw-r--r--stdlib/source/lux/data/text/unicode/set.lux239
-rw-r--r--stdlib/source/lux/data/trace.lux35
-rw-r--r--stdlib/source/lux/debug.lux597
-rw-r--r--stdlib/source/lux/extension.lux88
-rw-r--r--stdlib/source/lux/ffi.js.lux363
-rw-r--r--stdlib/source/lux/ffi.jvm.lux2047
-rw-r--r--stdlib/source/lux/ffi.lua.lux309
-rw-r--r--stdlib/source/lux/ffi.old.lux1828
-rw-r--r--stdlib/source/lux/ffi.php.lux313
-rw-r--r--stdlib/source/lux/ffi.py.lux314
-rw-r--r--stdlib/source/lux/ffi.rb.lux331
-rw-r--r--stdlib/source/lux/ffi.scm.lux219
-rw-r--r--stdlib/source/lux/locale.lux44
-rw-r--r--stdlib/source/lux/locale/language.lux572
-rw-r--r--stdlib/source/lux/locale/territory.lux311
-rw-r--r--stdlib/source/lux/macro.lux209
-rw-r--r--stdlib/source/lux/macro/code.lux160
-rw-r--r--stdlib/source/lux/macro/local.lux105
-rw-r--r--stdlib/source/lux/macro/poly.lux127
-rw-r--r--stdlib/source/lux/macro/syntax.lux128
-rw-r--r--stdlib/source/lux/macro/syntax/annotations.lux41
-rw-r--r--stdlib/source/lux/macro/syntax/check.lux41
-rw-r--r--stdlib/source/lux/macro/syntax/declaration.lux46
-rw-r--r--stdlib/source/lux/macro/syntax/definition.lux140
-rw-r--r--stdlib/source/lux/macro/syntax/export.lux20
-rw-r--r--stdlib/source/lux/macro/syntax/input.lux37
-rw-r--r--stdlib/source/lux/macro/syntax/type/variable.lux27
-rw-r--r--stdlib/source/lux/macro/template.lux184
-rw-r--r--stdlib/source/lux/math.lux393
-rw-r--r--stdlib/source/lux/math/infix.lux95
-rw-r--r--stdlib/source/lux/math/logic/continuous.lux39
-rw-r--r--stdlib/source/lux/math/logic/fuzzy.lux131
-rw-r--r--stdlib/source/lux/math/modular.lux156
-rw-r--r--stdlib/source/lux/math/modulus.lux55
-rw-r--r--stdlib/source/lux/math/number.lux86
-rw-r--r--stdlib/source/lux/math/number/complex.lux315
-rw-r--r--stdlib/source/lux/math/number/frac.lux446
-rw-r--r--stdlib/source/lux/math/number/i16.lux23
-rw-r--r--stdlib/source/lux/math/number/i32.lux23
-rw-r--r--stdlib/source/lux/math/number/i64.lux213
-rw-r--r--stdlib/source/lux/math/number/i8.lux23
-rw-r--r--stdlib/source/lux/math/number/int.lux259
-rw-r--r--stdlib/source/lux/math/number/nat.lux379
-rw-r--r--stdlib/source/lux/math/number/ratio.lux161
-rw-r--r--stdlib/source/lux/math/number/rev.lux462
-rw-r--r--stdlib/source/lux/math/random.lux399
-rw-r--r--stdlib/source/lux/meta.lux567
-rw-r--r--stdlib/source/lux/meta/annotation.lux94
-rw-r--r--stdlib/source/lux/meta/location.lux48
-rw-r--r--stdlib/source/lux/program.lux82
-rw-r--r--stdlib/source/lux/target.lux25
-rw-r--r--stdlib/source/lux/target/common_lisp.lux468
-rw-r--r--stdlib/source/lux/target/js.lux448
-rw-r--r--stdlib/source/lux/target/jvm.lux283
-rw-r--r--stdlib/source/lux/target/jvm/attribute.lux122
-rw-r--r--stdlib/source/lux/target/jvm/attribute/code.lux82
-rw-r--r--stdlib/source/lux/target/jvm/attribute/code/exception.lux57
-rw-r--r--stdlib/source/lux/target/jvm/attribute/constant.lux26
-rw-r--r--stdlib/source/lux/target/jvm/bytecode.lux1045
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/address.lux73
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/environment.lux107
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/environment/limit.lux57
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux90
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux68
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/instruction.lux713
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/jump.lux26
-rw-r--r--stdlib/source/lux/target/jvm/class.lux133
-rw-r--r--stdlib/source/lux/target/jvm/constant.lux245
-rw-r--r--stdlib/source/lux/target/jvm/constant/pool.lux157
-rw-r--r--stdlib/source/lux/target/jvm/constant/tag.lux49
-rw-r--r--stdlib/source/lux/target/jvm/encoding/name.lux39
-rw-r--r--stdlib/source/lux/target/jvm/encoding/signed.lux106
-rw-r--r--stdlib/source/lux/target/jvm/encoding/unsigned.lux120
-rw-r--r--stdlib/source/lux/target/jvm/field.lux69
-rw-r--r--stdlib/source/lux/target/jvm/index.lux37
-rw-r--r--stdlib/source/lux/target/jvm/loader.lux142
-rw-r--r--stdlib/source/lux/target/jvm/magic.lux19
-rw-r--r--stdlib/source/lux/target/jvm/method.lux103
-rw-r--r--stdlib/source/lux/target/jvm/modifier.lux87
-rw-r--r--stdlib/source/lux/target/jvm/modifier/inner.lux20
-rw-r--r--stdlib/source/lux/target/jvm/reflection.lux381
-rw-r--r--stdlib/source/lux/target/jvm/type.lux204
-rw-r--r--stdlib/source/lux/target/jvm/type/alias.lux115
-rw-r--r--stdlib/source/lux/target/jvm/type/box.lux18
-rw-r--r--stdlib/source/lux/target/jvm/type/category.lux35
-rw-r--r--stdlib/source/lux/target/jvm/type/descriptor.lux122
-rw-r--r--stdlib/source/lux/target/jvm/type/lux.lux188
-rw-r--r--stdlib/source/lux/target/jvm/type/parser.lux252
-rw-r--r--stdlib/source/lux/target/jvm/type/reflection.lux103
-rw-r--r--stdlib/source/lux/target/jvm/type/signature.lux133
-rw-r--r--stdlib/source/lux/target/jvm/version.lux37
-rw-r--r--stdlib/source/lux/target/lua.lux415
-rw-r--r--stdlib/source/lux/target/php.lux544
-rw-r--r--stdlib/source/lux/target/python.lux500
-rw-r--r--stdlib/source/lux/target/r.lux385
-rw-r--r--stdlib/source/lux/target/ruby.lux472
-rw-r--r--stdlib/source/lux/target/scheme.lux379
-rw-r--r--stdlib/source/lux/test.lux418
-rw-r--r--stdlib/source/lux/time.lux216
-rw-r--r--stdlib/source/lux/time/date.lux348
-rw-r--r--stdlib/source/lux/time/day.lux120
-rw-r--r--stdlib/source/lux/time/duration.lux202
-rw-r--r--stdlib/source/lux/time/instant.lux234
-rw-r--r--stdlib/source/lux/time/month.lux224
-rw-r--r--stdlib/source/lux/time/year.lux141
-rw-r--r--stdlib/source/lux/tool/compiler.lux46
-rw-r--r--stdlib/source/lux/tool/compiler/arity.lux15
-rw-r--r--stdlib/source/lux/tool/compiler/default/init.lux286
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux601
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux.lux106
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/analysis.lux555
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux56
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/analysis/macro.lux51
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/directive.lux82
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/generation.lux335
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux143
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux324
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux372
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/analysis/function.lux112
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux300
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux274
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/analysis/primitive.lux32
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/analysis/reference.lux84
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux205
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux360
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux55
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/directive.lux78
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux176
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis.lux15
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux34
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux217
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux2075
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux251
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux300
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux213
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux230
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux34
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux198
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux157
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/bundle.lux28
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux306
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux450
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux17
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux179
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux39
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js.lux17
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux190
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux159
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux19
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux413
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux1105
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux17
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux180
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux199
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php.lux17
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux191
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux142
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python.lux17
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux170
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux164
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux17
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux178
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux39
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux17
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux185
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux135
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux17
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux174
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux108
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/synthesis.lux10
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux56
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux261
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux13
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux136
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux102
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux69
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux20
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux292
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux36
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/extension.lux65
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux116
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux321
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux122
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux90
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux20
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux784
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux37
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux72
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux265
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux30
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux134
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux23
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux25
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux21
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux55
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux39
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux58
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux30
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux13
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux156
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux41
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux97
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux80
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux49
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux160
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux89
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux120
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux143
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux66
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux610
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux94
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux22
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux48
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux118
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux279
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux136
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux118
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux15
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux431
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux36
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/php.lux102
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux297
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension.lux13
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux111
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux115
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux121
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux31
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/reference.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux609
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/structure.lux41
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux112
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux317
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux111
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux121
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux17
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/reference.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux455
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/structure.lux36
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux58
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux239
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux116
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux64
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux17
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux339
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux89
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux854
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux39
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux88
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby.lux104
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux311
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux111
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux95
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux15
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux402
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux36
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux58
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux222
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux13
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux222
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux100
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux63
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux15
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux369
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux39
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux103
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux429
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux276
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux186
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux442
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/program.lux56
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/syntax.lux582
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/synthesis.lux808
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/version.lux8
-rw-r--r--stdlib/source/lux/tool/compiler/meta.lux8
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive.lux279
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/artifact.lux154
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux48
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/document.lux71
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/key.lux18
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/signature.lux41
-rw-r--r--stdlib/source/lux/tool/compiler/meta/cache/dependency.lux96
-rw-r--r--stdlib/source/lux/tool/compiler/meta/io.lux19
-rw-r--r--stdlib/source/lux/tool/compiler/meta/io/archive.lux449
-rw-r--r--stdlib/source/lux/tool/compiler/meta/io/context.lux169
-rw-r--r--stdlib/source/lux/tool/compiler/meta/packager.lux42
-rw-r--r--stdlib/source/lux/tool/compiler/meta/packager/jvm.lux144
-rw-r--r--stdlib/source/lux/tool/compiler/meta/packager/scheme.lux131
-rw-r--r--stdlib/source/lux/tool/compiler/meta/packager/script.lux75
-rw-r--r--stdlib/source/lux/tool/compiler/phase.lux118
-rw-r--r--stdlib/source/lux/tool/compiler/reference.lux84
-rw-r--r--stdlib/source/lux/tool/compiler/reference/variable.lux67
-rw-r--r--stdlib/source/lux/tool/compiler/version.lux51
-rw-r--r--stdlib/source/lux/tool/interpreter.lux221
-rw-r--r--stdlib/source/lux/tool/mediator.lux18
-rw-r--r--stdlib/source/lux/type.lux462
-rw-r--r--stdlib/source/lux/type/abstract.lux268
-rw-r--r--stdlib/source/lux/type/check.lux720
-rw-r--r--stdlib/source/lux/type/dynamic.lux50
-rw-r--r--stdlib/source/lux/type/implicit.lux400
-rw-r--r--stdlib/source/lux/type/quotient.lux55
-rw-r--r--stdlib/source/lux/type/refinement.lux88
-rw-r--r--stdlib/source/lux/type/resource.lux217
-rw-r--r--stdlib/source/lux/type/unit.lux188
-rw-r--r--stdlib/source/lux/type/variance.lux11
-rw-r--r--stdlib/source/lux/world/console.lux158
-rw-r--r--stdlib/source/lux/world/db/jdbc.lux175
-rw-r--r--stdlib/source/lux/world/db/jdbc/input.lux106
-rw-r--r--stdlib/source/lux/world/db/jdbc/output.lux194
-rw-r--r--stdlib/source/lux/world/db/sql.lux475
-rw-r--r--stdlib/source/lux/world/file.lux1302
-rw-r--r--stdlib/source/lux/world/file/watch.lux458
-rw-r--r--stdlib/source/lux/world/input/keyboard.lux111
-rw-r--r--stdlib/source/lux/world/net.lux12
-rw-r--r--stdlib/source/lux/world/net/http.lux79
-rw-r--r--stdlib/source/lux/world/net/http/client.lux226
-rw-r--r--stdlib/source/lux/world/net/http/cookie.lux87
-rw-r--r--stdlib/source/lux/world/net/http/header.lux34
-rw-r--r--stdlib/source/lux/world/net/http/mime.lux99
-rw-r--r--stdlib/source/lux/world/net/http/query.lux64
-rw-r--r--stdlib/source/lux/world/net/http/request.lux127
-rw-r--r--stdlib/source/lux/world/net/http/response.lux73
-rw-r--r--stdlib/source/lux/world/net/http/route.lux73
-rw-r--r--stdlib/source/lux/world/net/http/status.lux82
-rw-r--r--stdlib/source/lux/world/net/http/version.lux12
-rw-r--r--stdlib/source/lux/world/net/uri.lux8
-rw-r--r--stdlib/source/lux/world/output/video/resolution.lux46
-rw-r--r--stdlib/source/lux/world/program.lux450
-rw-r--r--stdlib/source/lux/world/service/authentication.lux24
-rw-r--r--stdlib/source/lux/world/service/crud.lux32
-rw-r--r--stdlib/source/lux/world/service/inventory.lux30
-rw-r--r--stdlib/source/lux/world/service/journal.lux50
-rw-r--r--stdlib/source/lux/world/service/mail.lux18
-rw-r--r--stdlib/source/lux/world/shell.lux373
-rw-r--r--stdlib/source/poly/lux/abstract/equivalence.lux81
-rw-r--r--stdlib/source/poly/lux/abstract/functor.lux45
-rw-r--r--stdlib/source/poly/lux/data/format/json.lux83
-rw-r--r--stdlib/source/program/aedifex.lux81
-rw-r--r--stdlib/source/program/aedifex/action.lux15
-rw-r--r--stdlib/source/program/aedifex/artifact.lux31
-rw-r--r--stdlib/source/program/aedifex/artifact/extension.lux13
-rw-r--r--stdlib/source/program/aedifex/artifact/snapshot.lux25
-rw-r--r--stdlib/source/program/aedifex/artifact/snapshot/build.lux33
-rw-r--r--stdlib/source/program/aedifex/artifact/snapshot/stamp.lux25
-rw-r--r--stdlib/source/program/aedifex/artifact/snapshot/time.lux33
-rw-r--r--stdlib/source/program/aedifex/artifact/snapshot/version.lux27
-rw-r--r--stdlib/source/program/aedifex/artifact/snapshot/version/value.lux15
-rw-r--r--stdlib/source/program/aedifex/artifact/time.lux31
-rw-r--r--stdlib/source/program/aedifex/artifact/time/date.lux45
-rw-r--r--stdlib/source/program/aedifex/artifact/time/time.lux27
-rw-r--r--stdlib/source/program/aedifex/artifact/type.lux3
-rw-r--r--stdlib/source/program/aedifex/artifact/versioning.lux51
-rw-r--r--stdlib/source/program/aedifex/cli.lux21
-rw-r--r--stdlib/source/program/aedifex/command.lux3
-rw-r--r--stdlib/source/program/aedifex/command/auto.lux35
-rw-r--r--stdlib/source/program/aedifex/command/build.lux57
-rw-r--r--stdlib/source/program/aedifex/command/clean.lux27
-rw-r--r--stdlib/source/program/aedifex/command/deploy.lux55
-rw-r--r--stdlib/source/program/aedifex/command/deps.lux39
-rw-r--r--stdlib/source/program/aedifex/command/install.lux47
-rw-r--r--stdlib/source/program/aedifex/command/pom.lux35
-rw-r--r--stdlib/source/program/aedifex/command/test.lux35
-rw-r--r--stdlib/source/program/aedifex/command/version.lux25
-rw-r--r--stdlib/source/program/aedifex/dependency.lux19
-rw-r--r--stdlib/source/program/aedifex/dependency/deployment.lux43
-rw-r--r--stdlib/source/program/aedifex/dependency/resolution.lux77
-rw-r--r--stdlib/source/program/aedifex/dependency/status.lux15
-rw-r--r--stdlib/source/program/aedifex/format.lux21
-rw-r--r--stdlib/source/program/aedifex/hash.lux41
-rw-r--r--stdlib/source/program/aedifex/input.lux45
-rw-r--r--stdlib/source/program/aedifex/local.lux15
-rw-r--r--stdlib/source/program/aedifex/metadata.lux17
-rw-r--r--stdlib/source/program/aedifex/metadata/artifact.lux67
-rw-r--r--stdlib/source/program/aedifex/metadata/snapshot.lux69
-rw-r--r--stdlib/source/program/aedifex/package.lux37
-rw-r--r--stdlib/source/program/aedifex/parser.lux37
-rw-r--r--stdlib/source/program/aedifex/pom.lux39
-rw-r--r--stdlib/source/program/aedifex/profile.lux49
-rw-r--r--stdlib/source/program/aedifex/project.lux31
-rw-r--r--stdlib/source/program/aedifex/repository.lux29
-rw-r--r--stdlib/source/program/aedifex/repository/identity.lux21
-rw-r--r--stdlib/source/program/aedifex/repository/local.lux31
-rw-r--r--stdlib/source/program/aedifex/repository/origin.lux19
-rw-r--r--stdlib/source/program/aedifex/repository/remote.lux49
-rw-r--r--stdlib/source/program/aedifex/runtime.lux27
-rw-r--r--stdlib/source/program/compositor.lux101
-rw-r--r--stdlib/source/program/compositor/cli.lux25
-rw-r--r--stdlib/source/program/compositor/export.lux51
-rw-r--r--stdlib/source/program/compositor/import.lux53
-rw-r--r--stdlib/source/program/compositor/static.lux9
-rw-r--r--stdlib/source/program/scriptum.lux5
-rw-r--r--stdlib/source/spec/aedifex/repository.lux27
-rw-r--r--stdlib/source/spec/compositor/generation/case.lux4
-rw-r--r--stdlib/source/spec/lux/abstract/apply.lux23
-rw-r--r--stdlib/source/spec/lux/abstract/codec.lux19
-rw-r--r--stdlib/source/spec/lux/abstract/comonad.lux19
-rw-r--r--stdlib/source/spec/lux/abstract/enum.lux15
-rw-r--r--stdlib/source/spec/lux/abstract/equivalence.lux15
-rw-r--r--stdlib/source/spec/lux/abstract/fold.lux19
-rw-r--r--stdlib/source/spec/lux/abstract/functor.lux25
-rw-r--r--stdlib/source/spec/lux/abstract/functor/contravariant.lux25
-rw-r--r--stdlib/source/spec/lux/abstract/hash.lux23
-rw-r--r--stdlib/source/spec/lux/abstract/interval.lux17
-rw-r--r--stdlib/source/spec/lux/abstract/monad.lux15
-rw-r--r--stdlib/source/spec/lux/abstract/monoid.lux15
-rw-r--r--stdlib/source/spec/lux/abstract/order.lux15
-rw-r--r--stdlib/source/spec/lux/world/console.lux31
-rw-r--r--stdlib/source/spec/lux/world/file.lux59
-rw-r--r--stdlib/source/spec/lux/world/program.lux33
-rw-r--r--stdlib/source/spec/lux/world/shell.lux41
-rw-r--r--stdlib/source/test/aedifex.lux11
-rw-r--r--stdlib/source/test/aedifex/artifact.lux37
-rw-r--r--stdlib/source/test/aedifex/artifact/extension.lux27
-rw-r--r--stdlib/source/test/aedifex/artifact/snapshot.lux25
-rw-r--r--stdlib/source/test/aedifex/artifact/snapshot/build.lux25
-rw-r--r--stdlib/source/test/aedifex/artifact/snapshot/stamp.lux29
-rw-r--r--stdlib/source/test/aedifex/artifact/snapshot/time.lux25
-rw-r--r--stdlib/source/test/aedifex/artifact/snapshot/version.lux25
-rw-r--r--stdlib/source/test/aedifex/artifact/snapshot/version/value.lux41
-rw-r--r--stdlib/source/test/aedifex/artifact/time.lux29
-rw-r--r--stdlib/source/test/aedifex/artifact/time/date.lux33
-rw-r--r--stdlib/source/test/aedifex/artifact/time/time.lux29
-rw-r--r--stdlib/source/test/aedifex/artifact/type.lux27
-rw-r--r--stdlib/source/test/aedifex/artifact/versioning.lux25
-rw-r--r--stdlib/source/test/aedifex/cache.lux51
-rw-r--r--stdlib/source/test/aedifex/cli.lux31
-rw-r--r--stdlib/source/test/aedifex/command.lux5
-rw-r--r--stdlib/source/test/aedifex/command/auto.lux65
-rw-r--r--stdlib/source/test/aedifex/command/build.lux45
-rw-r--r--stdlib/source/test/aedifex/command/clean.lux45
-rw-r--r--stdlib/source/test/aedifex/command/deploy.lux57
-rw-r--r--stdlib/source/test/aedifex/command/deps.lux53
-rw-r--r--stdlib/source/test/aedifex/command/install.lux45
-rw-r--r--stdlib/source/test/aedifex/command/pom.lux39
-rw-r--r--stdlib/source/test/aedifex/command/test.lux45
-rw-r--r--stdlib/source/test/aedifex/command/version.lux47
-rw-r--r--stdlib/source/test/aedifex/dependency.lux17
-rw-r--r--stdlib/source/test/aedifex/dependency/deployment.lux65
-rw-r--r--stdlib/source/test/aedifex/dependency/resolution.lux55
-rw-r--r--stdlib/source/test/aedifex/dependency/status.lux15
-rw-r--r--stdlib/source/test/aedifex/hash.lux37
-rw-r--r--stdlib/source/test/aedifex/input.lux39
-rw-r--r--stdlib/source/test/aedifex/local.lux17
-rw-r--r--stdlib/source/test/aedifex/metadata.lux17
-rw-r--r--stdlib/source/test/aedifex/metadata/artifact.lux47
-rw-r--r--stdlib/source/test/aedifex/metadata/snapshot.lux47
-rw-r--r--stdlib/source/test/aedifex/package.lux51
-rw-r--r--stdlib/source/test/aedifex/parser.lux45
-rw-r--r--stdlib/source/test/aedifex/pom.lux29
-rw-r--r--stdlib/source/test/aedifex/profile.lux45
-rw-r--r--stdlib/source/test/aedifex/project.lux35
-rw-r--r--stdlib/source/test/aedifex/repository.lux45
-rw-r--r--stdlib/source/test/aedifex/repository/identity.lux15
-rw-r--r--stdlib/source/test/aedifex/repository/local.lux41
-rw-r--r--stdlib/source/test/aedifex/repository/origin.lux15
-rw-r--r--stdlib/source/test/aedifex/repository/remote.lux53
-rw-r--r--stdlib/source/test/aedifex/runtime.lux29
-rw-r--r--stdlib/source/test/lux.lux49
-rw-r--r--stdlib/source/test/lux/abstract.lux5
-rw-r--r--stdlib/source/test/lux/abstract/apply.lux27
-rw-r--r--stdlib/source/test/lux/abstract/codec.lux27
-rw-r--r--stdlib/source/test/lux/abstract/comonad.lux23
-rw-r--r--stdlib/source/test/lux/abstract/comonad/cofree.lux35
-rw-r--r--stdlib/source/test/lux/abstract/enum.lux29
-rw-r--r--stdlib/source/test/lux/abstract/equivalence.lux31
-rw-r--r--stdlib/source/test/lux/abstract/fold.lux25
-rw-r--r--stdlib/source/test/lux/abstract/functor.lux27
-rw-r--r--stdlib/source/test/lux/abstract/functor/contravariant.lux7
-rw-r--r--stdlib/source/test/lux/abstract/hash.lux29
-rw-r--r--stdlib/source/test/lux/abstract/interval.lux37
-rw-r--r--stdlib/source/test/lux/abstract/monad.lux23
-rw-r--r--stdlib/source/test/lux/abstract/monad/free.lux33
-rw-r--r--stdlib/source/test/lux/abstract/monoid.lux21
-rw-r--r--stdlib/source/test/lux/abstract/order.lux29
-rw-r--r--stdlib/source/test/lux/abstract/predicate.lux41
-rw-r--r--stdlib/source/test/lux/control.lux5
-rw-r--r--stdlib/source/test/lux/control/concatenative.lux37
-rw-r--r--stdlib/source/test/lux/control/concurrency/actor.lux39
-rw-r--r--stdlib/source/test/lux/control/concurrency/atom.lux23
-rw-r--r--stdlib/source/test/lux/control/concurrency/frp.lux43
-rw-r--r--stdlib/source/test/lux/control/concurrency/promise.lux45
-rw-r--r--stdlib/source/test/lux/control/concurrency/semaphore.lux55
-rw-r--r--stdlib/source/test/lux/control/concurrency/stm.lux39
-rw-r--r--stdlib/source/test/lux/control/concurrency/thread.lux31
-rw-r--r--stdlib/source/test/lux/control/continuation.lux33
-rw-r--r--stdlib/source/test/lux/control/exception.lux25
-rw-r--r--stdlib/source/test/lux/control/function.lux29
-rw-r--r--stdlib/source/test/lux/control/function/contract.lux23
-rw-r--r--stdlib/source/test/lux/control/function/memo.lux43
-rw-r--r--stdlib/source/test/lux/control/function/mixin.lux39
-rw-r--r--stdlib/source/test/lux/control/function/mutual.lux27
-rw-r--r--stdlib/source/test/lux/control/io.lux27
-rw-r--r--stdlib/source/test/lux/control/parser.lux53
-rw-r--r--stdlib/source/test/lux/control/parser/analysis.lux61
-rw-r--r--stdlib/source/test/lux/control/parser/binary.lux79
-rw-r--r--stdlib/source/test/lux/control/parser/cli.lux33
-rw-r--r--stdlib/source/test/lux/control/parser/code.lux49
-rw-r--r--stdlib/source/test/lux/control/parser/environment.lux33
-rw-r--r--stdlib/source/test/lux/control/parser/json.lux53
-rw-r--r--stdlib/source/test/lux/control/parser/synthesis.lux61
-rw-r--r--stdlib/source/test/lux/control/parser/text.lux55
-rw-r--r--stdlib/source/test/lux/control/parser/tree.lux33
-rw-r--r--stdlib/source/test/lux/control/parser/type.lux35
-rw-r--r--stdlib/source/test/lux/control/parser/xml.lux47
-rw-r--r--stdlib/source/test/lux/control/pipe.lux29
-rw-r--r--stdlib/source/test/lux/control/reader.lux27
-rw-r--r--stdlib/source/test/lux/control/region.lux47
-rw-r--r--stdlib/source/test/lux/control/remember.lux53
-rw-r--r--stdlib/source/test/lux/control/security/capability.lux27
-rw-r--r--stdlib/source/test/lux/control/security/policy.lux33
-rw-r--r--stdlib/source/test/lux/control/state.lux37
-rw-r--r--stdlib/source/test/lux/control/thread.lux27
-rw-r--r--stdlib/source/test/lux/control/try.lux39
-rw-r--r--stdlib/source/test/lux/control/writer.lux41
-rw-r--r--stdlib/source/test/lux/data.lux65
-rw-r--r--stdlib/source/test/lux/data/binary.lux41
-rw-r--r--stdlib/source/test/lux/data/bit.lux29
-rw-r--r--stdlib/source/test/lux/data/collection.lux5
-rw-r--r--stdlib/source/test/lux/data/collection/array.lux41
-rw-r--r--stdlib/source/test/lux/data/collection/bits.lux25
-rw-r--r--stdlib/source/test/lux/data/collection/dictionary.lux43
-rw-r--r--stdlib/source/test/lux/data/collection/dictionary/ordered.lux41
-rw-r--r--stdlib/source/test/lux/data/collection/dictionary/plist.lux37
-rw-r--r--stdlib/source/test/lux/data/collection/list.lux61
-rw-r--r--stdlib/source/test/lux/data/collection/queue.lux35
-rw-r--r--stdlib/source/test/lux/data/collection/queue/priority.lux25
-rw-r--r--stdlib/source/test/lux/data/collection/row.lux49
-rw-r--r--stdlib/source/test/lux/data/collection/sequence.lux39
-rw-r--r--stdlib/source/test/lux/data/collection/set.lux37
-rw-r--r--stdlib/source/test/lux/data/collection/set/multi.lux39
-rw-r--r--stdlib/source/test/lux/data/collection/set/ordered.lux33
-rw-r--r--stdlib/source/test/lux/data/collection/stack.lux31
-rw-r--r--stdlib/source/test/lux/data/collection/tree.lux35
-rw-r--r--stdlib/source/test/lux/data/collection/tree/finger.lux31
-rw-r--r--stdlib/source/test/lux/data/collection/tree/zipper.lux43
-rw-r--r--stdlib/source/test/lux/data/color.lux43
-rw-r--r--stdlib/source/test/lux/data/color/named.lux31
-rw-r--r--stdlib/source/test/lux/data/format/binary.lux25
-rw-r--r--stdlib/source/test/lux/data/format/json.lux59
-rw-r--r--stdlib/source/test/lux/data/format/tar.lux69
-rw-r--r--stdlib/source/test/lux/data/format/xml.lux51
-rw-r--r--stdlib/source/test/lux/data/identity.lux21
-rw-r--r--stdlib/source/test/lux/data/lazy.lux33
-rw-r--r--stdlib/source/test/lux/data/maybe.lux47
-rw-r--r--stdlib/source/test/lux/data/name.lux46
-rw-r--r--stdlib/source/test/lux/data/product.lux25
-rw-r--r--stdlib/source/test/lux/data/sum.lux37
-rw-r--r--stdlib/source/test/lux/data/text.lux43
-rw-r--r--stdlib/source/test/lux/data/text/buffer.lux25
-rw-r--r--stdlib/source/test/lux/data/text/encoding.lux43
-rw-r--r--stdlib/source/test/lux/data/text/encoding/utf8.lux21
-rw-r--r--stdlib/source/test/lux/data/text/escape.lux53
-rw-r--r--stdlib/source/test/lux/data/text/format.lux175
-rw-r--r--stdlib/source/test/lux/data/text/regex.lux39
-rw-r--r--stdlib/source/test/lux/data/text/unicode/block.lux41
-rw-r--r--stdlib/source/test/lux/data/text/unicode/set.lux33
-rw-r--r--stdlib/source/test/lux/debug.lux61
-rw-r--r--stdlib/source/test/lux/extension.lux85
-rw-r--r--stdlib/source/test/lux/ffi.js.lux31
-rw-r--r--stdlib/source/test/lux/ffi.jvm.lux51
-rw-r--r--stdlib/source/test/lux/ffi.lua.lux29
-rw-r--r--stdlib/source/test/lux/ffi.old.lux41
-rw-r--r--stdlib/source/test/lux/ffi.php.lux29
-rw-r--r--stdlib/source/test/lux/ffi.py.lux71
-rw-r--r--stdlib/source/test/lux/ffi.rb.lux29
-rw-r--r--stdlib/source/test/lux/ffi.scm.lux29
-rw-r--r--stdlib/source/test/lux/locale.lux31
-rw-r--r--stdlib/source/test/lux/locale/language.lux58
-rw-r--r--stdlib/source/test/lux/locale/territory.lux41
-rw-r--r--stdlib/source/test/lux/macro.lux45
-rw-r--r--stdlib/source/test/lux/macro/code.lux51
-rw-r--r--stdlib/source/test/lux/macro/local.lux51
-rw-r--r--stdlib/source/test/lux/macro/poly.lux7
-rw-r--r--stdlib/source/test/lux/macro/poly/equivalence.lux47
-rw-r--r--stdlib/source/test/lux/macro/poly/functor.lux31
-rw-r--r--stdlib/source/test/lux/macro/poly/json.lux89
-rw-r--r--stdlib/source/test/lux/macro/syntax.lux19
-rw-r--r--stdlib/source/test/lux/macro/syntax/annotations.lux37
-rw-r--r--stdlib/source/test/lux/macro/syntax/check.lux31
-rw-r--r--stdlib/source/test/lux/macro/syntax/declaration.lux31
-rw-r--r--stdlib/source/test/lux/macro/syntax/definition.lux37
-rw-r--r--stdlib/source/test/lux/macro/syntax/export.lux27
-rw-r--r--stdlib/source/test/lux/macro/syntax/input.lux31
-rw-r--r--stdlib/source/test/lux/macro/syntax/type/variable.lux27
-rw-r--r--stdlib/source/test/lux/macro/template.lux37
-rw-r--r--stdlib/source/test/lux/math.lux27
-rw-r--r--stdlib/source/test/lux/math/infix.lux25
-rw-r--r--stdlib/source/test/lux/math/logic/continuous.lux23
-rw-r--r--stdlib/source/test/lux/math/logic/fuzzy.lux39
-rw-r--r--stdlib/source/test/lux/math/modular.lux45
-rw-r--r--stdlib/source/test/lux/math/modulus.lux33
-rw-r--r--stdlib/source/test/lux/math/number.lux15
-rw-r--r--stdlib/source/test/lux/math/number/complex.lux31
-rw-r--r--stdlib/source/test/lux/math/number/frac.lux35
-rw-r--r--stdlib/source/test/lux/math/number/i16.lux19
-rw-r--r--stdlib/source/test/lux/math/number/i32.lux19
-rw-r--r--stdlib/source/test/lux/math/number/i64.lux27
-rw-r--r--stdlib/source/test/lux/math/number/i8.lux19
-rw-r--r--stdlib/source/test/lux/math/number/int.lux35
-rw-r--r--stdlib/source/test/lux/math/number/nat.lux35
-rw-r--r--stdlib/source/test/lux/math/number/ratio.lux31
-rw-r--r--stdlib/source/test/lux/math/number/rev.lux35
-rw-r--r--stdlib/source/test/lux/meta.lux59
-rw-r--r--stdlib/source/test/lux/meta/annotation.lux51
-rw-r--r--stdlib/source/test/lux/meta/location.lux23
-rw-r--r--stdlib/source/test/lux/program.lux39
-rw-r--r--stdlib/source/test/lux/target.lux23
-rw-r--r--stdlib/source/test/lux/target/jvm.lux69
-rw-r--r--stdlib/source/test/lux/test.lux37
-rw-r--r--stdlib/source/test/lux/time.lux47
-rw-r--r--stdlib/source/test/lux/time/date.lux47
-rw-r--r--stdlib/source/test/lux/time/day.lux31
-rw-r--r--stdlib/source/test/lux/time/duration.lux37
-rw-r--r--stdlib/source/test/lux/time/instant.lux45
-rw-r--r--stdlib/source/test/lux/time/month.lux47
-rw-r--r--stdlib/source/test/lux/time/year.lux43
-rw-r--r--stdlib/source/test/lux/tool.lux5
-rw-r--r--stdlib/source/test/lux/type.lux60
-rw-r--r--stdlib/source/test/lux/type/abstract.lux39
-rw-r--r--stdlib/source/test/lux/type/check.lux57
-rw-r--r--stdlib/source/test/lux/type/dynamic.lux31
-rw-r--r--stdlib/source/test/lux/type/implicit.lux35
-rw-r--r--stdlib/source/test/lux/type/quotient.lux29
-rw-r--r--stdlib/source/test/lux/type/refinement.lux29
-rw-r--r--stdlib/source/test/lux/type/resource.lux47
-rw-r--r--stdlib/source/test/lux/type/unit.lux41
-rw-r--r--stdlib/source/test/lux/type/variance.lux15
-rw-r--r--stdlib/source/test/lux/world.lux5
-rw-r--r--stdlib/source/test/lux/world/console.lux29
-rw-r--r--stdlib/source/test/lux/world/file.lux19
-rw-r--r--stdlib/source/test/lux/world/file/watch.lux39
-rw-r--r--stdlib/source/test/lux/world/input/keyboard.lux35
-rw-r--r--stdlib/source/test/lux/world/net/http/client.lux55
-rw-r--r--stdlib/source/test/lux/world/net/http/status.lux25
-rw-r--r--stdlib/source/test/lux/world/output/video/resolution.lux35
-rw-r--r--stdlib/source/test/lux/world/program.lux74
-rw-r--r--stdlib/source/test/lux/world/shell.lux45
1231 files changed, 96351 insertions, 95357 deletions
diff --git a/.gitignore b/.gitignore
index ded3e74bf..84f1571c4 100644
--- a/.gitignore
+++ b/.gitignore
@@ -21,39 +21,34 @@ pom.xml.asc
/licentia/source/lux
/lux-jvm/target
-/lux-jvm/source/lux.lux
-/lux-jvm/source/lux
+/lux-jvm/source/library
/lux-jvm/source/program
/lux-jvm/source/spec
/lux-js/target
-/lux-js/source/lux.lux
-/lux-js/source/lux
+/lux-js/source/library
/lux-js/source/program
/lux-js/source/spec
/lux-js/node_based_compiler.js
/lux-js/lux.js
/lux-python/target
-/lux-python/source/lux.lux
-/lux-python/source/lux
+/lux-python/source/library
/lux-python/source/program
/lux-python/source/spec
/lux-lua/target
-/lux-lua/source/lux.lux
-/lux-lua/source/lux
+/lux-lua/source/library
/lux-lua/source/program
/lux-lua/source/spec
/lux-ruby/target
-/lux-ruby/source/lux.lux
-/lux-ruby/source/lux
+/lux-ruby/source/library
/lux-ruby/source/program
/lux-ruby/source/spec
/lux-php/target
-/lux-php/source/lux.lux
+/lux-php/source/library
/lux-php/source/lux
/lux-php/source/program
/lux-php/source/spec
diff --git a/lux-bootstrapper/src/lux/analyser/base.clj b/lux-bootstrapper/src/lux/analyser/base.clj
index d6787280f..e5f47f977 100644
--- a/lux-bootstrapper/src/lux/analyser/base.clj
+++ b/lux-bootstrapper/src/lux/analyser/base.clj
@@ -77,7 +77,7 @@
(let [tag-names #{"Primitive" "Sum" "Product" "Function" "Parameter" "Var" "Ex" "UnivQ" "ExQ" "Apply" "Named"}]
(defn type-tag? [module name]
- (and (= "lux" module)
+ (and (= &/prelude module)
(contains? tag-names name))))
(defn |meta [type location analysis]
diff --git a/lux-bootstrapper/src/lux/base.clj b/lux-bootstrapper/src/lux/base.clj
index 5ef710a03..648b3341c 100644
--- a/lux-bootstrapper/src/lux/base.clj
+++ b/lux-bootstrapper/src/lux/base.clj
@@ -5,7 +5,7 @@
clojure.core.match.array))
(def prelude
- "lux")
+ "library/lux")
(def !log! (atom false))
(defn flag-prn! [& args]
@@ -13,7 +13,8 @@
(apply prn args)))
;; [Tags]
-(def unit-tag (.intern ""))
+(def unit-tag
+ (.intern ""))
(defn T [elems]
(case (count elems)
diff --git a/lux-bootstrapper/src/lux/compiler/jvm.clj b/lux-bootstrapper/src/lux/compiler/jvm.clj
index bacf2cb9c..e2521fec7 100644
--- a/lux-bootstrapper/src/lux/compiler/jvm.clj
+++ b/lux-bootstrapper/src/lux/compiler/jvm.clj
@@ -188,7 +188,7 @@
(.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
module-class-name nil "java/lang/Object" nil)
(.visitSource file-name nil))]
- _ (if (= "lux" name)
+ _ (if (= &/prelude name)
(|do [_ &&rt/compile-Function-class
_ &&rt/compile-LuxRT-class]
(return nil))
@@ -242,7 +242,7 @@
&&jvm-cache/load-def-value
&&jvm-cache/install-all-defs-in-module
&&jvm-cache/uninstall-all-defs-in-module)
- _ (compile-module source-dirs "lux")]
+ _ (compile-module source-dirs &/prelude)]
(compile-module source-dirs program-module))]
(|case (m-action (&/init-state "{old}" mode (jvm-host)))
(&/$Right ?state _)
diff --git a/lux-bootstrapper/src/lux/compiler/jvm/base.clj b/lux-bootstrapper/src/lux/compiler/jvm/base.clj
index b5e520de5..47566a626 100644
--- a/lux-bootstrapper/src/lux/compiler/jvm/base.clj
+++ b/lux-bootstrapper/src/lux/compiler/jvm/base.clj
@@ -21,8 +21,12 @@
(java.lang.reflect Field)))
;; [Constants]
-(def ^:const ^String function-class "lux/Function")
-(def ^:const ^String lux-utils-class "lux/LuxRT")
+(def ^:const ^String function-class
+ (&host/internal &host/function-class))
+
+(def ^:const ^String lux-utils-class
+ (&host/internal &host/lux-utils-class))
+
(def ^:const ^String unit-tag-field "unit_tag")
;; Formats
diff --git a/lux-bootstrapper/src/lux/compiler/jvm/case.clj b/lux-bootstrapper/src/lux/compiler/jvm/case.clj
index b7cdb7571..8a41db0b3 100644
--- a/lux-bootstrapper/src/lux/compiler/jvm/case.clj
+++ b/lux-bootstrapper/src/lux/compiler/jvm/case.clj
@@ -114,21 +114,21 @@
#(doto ^MethodVisitor %
(.visitInsn Opcodes/AALOAD))
#(doto ^MethodVisitor %
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "tuple_left" "([Ljava/lang/Object;I)Ljava/lang/Object;")))]
+ (.visitMethodInsn Opcodes/INVOKESTATIC &rt/rt-class "tuple_left" "([Ljava/lang/Object;I)Ljava/lang/Object;")))]
(doto writer
stack-peek
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
(.visitLdcInsn (int lefts))
accessI
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")))
+ (.visitMethodInsn Opcodes/INVOKESTATIC &rt/rt-class "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")))
(&o/$TuplePM (&/$Right _idx))
(doto writer
stack-peek
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
(.visitLdcInsn (int (dec _idx)))
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "tuple_right" "([Ljava/lang/Object;I)Ljava/lang/Object;")
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))
+ (.visitMethodInsn Opcodes/INVOKESTATIC &rt/rt-class "tuple_right" "([Ljava/lang/Object;I)Ljava/lang/Object;")
+ (.visitMethodInsn Opcodes/INVOKESTATIC &rt/rt-class "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))
(&o/$VariantPM _idx+)
(|let [$success (new Label)
@@ -147,7 +147,7 @@
(.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;")
+ (.visitMethodInsn Opcodes/INVOKESTATIC &rt/rt-class "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;")
(.visitInsn Opcodes/DUP)
(.visitJumpInsn Opcodes/IFNULL $fail)
(.visitJumpInsn Opcodes/GOTO $success)
@@ -155,7 +155,7 @@
(.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;")))
+ (.visitMethodInsn Opcodes/INVOKESTATIC &rt/rt-class "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")))
(&o/$SeqPM _left-pm _right-pm)
(doto writer
@@ -178,7 +178,7 @@
(compile-pattern* bodies 1 $else pm)
(.visitLabel $else)
(.visitInsn Opcodes/POP)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_fail" "()V")
+ (.visitMethodInsn Opcodes/INVOKESTATIC &rt/rt-class "pm_fail" "()V")
(.visitInsn Opcodes/ACONST_NULL)
(.visitJumpInsn Opcodes/GOTO $end))))
@@ -200,7 +200,7 @@
(.visitInsn Opcodes/ACONST_NULL))]
_ (compile ?value)
:let [_ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))
+ (.visitMethodInsn Opcodes/INVOKESTATIC &rt/rt-class "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)]]
diff --git a/lux-bootstrapper/src/lux/compiler/jvm/lux.clj b/lux-bootstrapper/src/lux/compiler/jvm/lux.clj
index 515bd8db5..f5fa88e02 100644
--- a/lux-bootstrapper/src/lux/compiler/jvm/lux.clj
+++ b/lux-bootstrapper/src/lux/compiler/jvm/lux.clj
@@ -15,7 +15,8 @@
(lux.analyser [base :as &a]
[module :as &a-module])
(lux.compiler.jvm [base :as &&]
- [function :as &&function]))
+ [function :as &&function]
+ [rt :as &rt]))
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
@@ -79,7 +80,7 @@
(.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;")]]
+ :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC &rt/rt-class "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")]]
(return nil)))
(defn compile-local [compile ?idx]
@@ -120,7 +121,7 @@
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)
+ func-partials (.get ^Field (.getDeclaredField (Class/forName &host/function-class 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)
@@ -208,7 +209,7 @@
(.visitLdcInsn (int (if tail?
(dec idx)
idx)))
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT"
+ (.visitMethodInsn Opcodes/INVOKESTATIC &rt/rt-class
(if tail? "tuple_right" "tuple_left")
"([Ljava/lang/Object;I)Ljava/lang/Object;"))))
_path)]]
@@ -339,7 +340,7 @@
(.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
+ (.visitMethodInsn Opcodes/INVOKESTATIC &rt/rt-class "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; V
;; Tail: End
;; Size: Begin
(.visitVarInsn Opcodes/ALOAD 0) ;; VA
@@ -379,7 +380,7 @@
(.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
+ (.visitMethodInsn Opcodes/INVOKESTATIC &rt/rt-class "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; IV
;; Cons: End
(.visitInsn Opcodes/SWAP) ;; VI
(.visitJumpInsn Opcodes/GOTO $loop)
diff --git a/lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj b/lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj
index f21557e88..cd1b77dee 100644
--- a/lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj
+++ b/lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj
@@ -14,7 +14,8 @@
[lux.type.host :as &host-type]
[lux.host.generics :as &host-generics]
[lux.analyser.base :as &a]
- [lux.compiler.jvm.base :as &&])
+ (lux.compiler.jvm [base :as &&]
+ [rt :as &rt]))
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
@@ -81,8 +82,8 @@
^MethodVisitor *writer* &/get-writer
_ (compile ?op)
:let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST "lux/Function")
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "runTry" "(Llux/Function;)[Ljava/lang/Object;"))]]
+ (.visitTypeInsn Opcodes/CHECKCAST &rt/function-class)
+ (.visitMethodInsn Opcodes/INVOKESTATIC &rt/rt-class "runTry" (str "(L" &rt/function-class ";)[Ljava/lang/Object;")))]]
(return nil)))
(do-template [<name> <opcode> <unwrap> <wrap>]
@@ -160,7 +161,7 @@
_ (compile ?input)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST "java/lang/String")
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "decode_frac" "(Ljava/lang/String;)[Ljava/lang/Object;"))]]
+ (.visitMethodInsn Opcodes/INVOKESTATIC &rt/rt-class "decode_frac" "(Ljava/lang/String;)[Ljava/lang/Object;"))]]
(return nil)))
(defn ^:private compile-int-char [compile ?values special-args]
@@ -276,11 +277,11 @@
(.visitJumpInsn Opcodes/IF_ICMPEQ $not-found)
(.visitInsn Opcodes/I2L)
&&/wrap-long
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;")
+ (.visitMethodInsn Opcodes/INVOKESTATIC &rt/rt-class "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;")
(.visitJumpInsn Opcodes/GOTO $end)
(.visitLabel $not-found)
(.visitInsn Opcodes/POP)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()[Ljava/lang/Object;")
+ (.visitMethodInsn Opcodes/INVOKESTATIC &rt/rt-class "make_none" "()[Ljava/lang/Object;")
(.visitLabel $end))]]
(return nil)))
diff --git a/lux-bootstrapper/src/lux/compiler/jvm/rt.clj b/lux-bootstrapper/src/lux/compiler/jvm/rt.clj
index 7fabd27ed..73812ef8f 100644
--- a/lux-bootstrapper/src/lux/compiler/jvm/rt.clj
+++ b/lux-bootstrapper/src/lux/compiler/jvm/rt.clj
@@ -21,6 +21,12 @@
MethodVisitor
AnnotationVisitor)))
+(def ^:const ^String rt-class
+ &&/lux-utils-class)
+
+(def ^:const ^String function-class
+ &&/function-class)
+
;; [Utils]
(def init-method "<init>")
@@ -63,7 +69,7 @@
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd)))))]]
- (&&/save-class! (second (string/split &&/function-class #"/"))
+ (&&/save-class! (-> &&/function-class (string/split #"/") (nth 2))
(.toByteArray (doto =class .visitEnd)))))
(defmacro <bytecode> [& instructions]
@@ -170,7 +176,7 @@
super-nested (<bytecode> super-nested-tag ;; super-tag
!variant <>last? ;; super-tag, super-last
!variant <>value ;; super-tag, super-last, super-value
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))
+ (.visitMethodInsn Opcodes/INVOKESTATIC rt-class "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))
update-!variant (<bytecode> !variant <>value
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
@@ -249,11 +255,11 @@
(.visitVarInsn Opcodes/ALOAD 0)
(.visitMethodInsn Opcodes/INVOKESTATIC <class> <parse-method> <signature>)
<wrapper>
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;")
+ (.visitMethodInsn Opcodes/INVOKESTATIC rt-class "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;")
+ (.visitMethodInsn Opcodes/INVOKESTATIC rt-class "make_none" "()[Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd)))
@@ -335,7 +341,7 @@
(.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;")
+ (.visitMethodInsn Opcodes/INVOKESTATIC rt-class "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd))
@@ -344,7 +350,7 @@
(.visitLdcInsn (->> #'&/$Some meta ::&/idx int)) ;; I
(.visitLdcInsn "") ;; I?
(.visitVarInsn Opcodes/ALOAD 0) ;; I?O
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
+ (.visitMethodInsn Opcodes/INVOKESTATIC rt-class "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd))
@@ -377,14 +383,14 @@
(.visitMethodInsn Opcodes/INVOKESPECIAL "java/io/PrintWriter" "<init>" "(Ljava/io/Writer;Z)V")
;; P
))]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "runTry" "(Llux/Function;)[Ljava/lang/Object;" nil nil)
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "runTry" (str "(L" function-class ";)[Ljava/lang/Object;") nil nil)
(.visitCode)
(.visitTryCatchBlock $from $to $handler "java/lang/Throwable")
(.visitLabel $from)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitInsn Opcodes/ACONST_NULL)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "lux/Function" &&/apply-method (&&/apply-signature 1))
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL function-class &&/apply-method (&&/apply-signature 1))
+ (.visitMethodInsn Opcodes/INVOKESTATIC rt-class "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
(.visitLabel $to)
(.visitLabel $handler) ;; T
@@ -397,7 +403,7 @@
(.visitLdcInsn (->> #'&/$Left meta ::&/idx int)) ;; SI
(.visitInsn Opcodes/ACONST_NULL) ;; SI?
swap2x1 ;; I?S
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
+ (.visitMethodInsn Opcodes/INVOKESTATIC rt-class "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd)))
@@ -406,5 +412,5 @@
(compile-LuxRT-adt-methods)
(compile-LuxRT-int-methods)
(compile-LuxRT-frac-methods))]]
- (&&/save-class! (second (string/split &&/lux-utils-class #"/"))
+ (&&/save-class! (-> &&/lux-utils-class (string/split #"/") (nth 2))
(.toByteArray (doto =class .visitEnd)))))
diff --git a/lux-bootstrapper/src/lux/host.clj b/lux-bootstrapper/src/lux/host.clj
index 4da818db2..eb1bcb41c 100644
--- a/lux-bootstrapper/src/lux/host.clj
+++ b/lux-bootstrapper/src/lux/host.clj
@@ -15,12 +15,23 @@
MethodVisitor)))
;; [Constants]
-(def function-class "lux.Function")
(def module-separator "/")
(def class-name-separator ".")
(def class-separator "/")
(def bytecode-version Opcodes/V1_6)
+(defn ^String external [^String internal]
+ (.replace internal class-separator class-name-separator))
+
+(defn ^String internal [^String external]
+ (.replace external class-name-separator class-separator))
+
+(def ^:const ^String function-class
+ (str (external &/prelude) class-name-separator "Function"))
+
+(def ^:const ^String lux-utils-class
+ (str (external &/prelude) class-name-separator "LuxRT"))
+
;; [Resources]
(defn ^String ->module-class [old]
old)
diff --git a/lux-bootstrapper/src/lux/repl.clj b/lux-bootstrapper/src/lux/repl.clj
index d980ac9ec..ff5c108c5 100644
--- a/lux-bootstrapper/src/lux/repl.clj
+++ b/lux-bootstrapper/src/lux/repl.clj
@@ -21,7 +21,7 @@
(defn ^:private init [source-dirs]
(do (&compiler/init!)
- (|case ((|do [_ (&compiler/compile-module source-dirs "lux")
+ (|case ((|do [_ (&compiler/compile-module source-dirs &/prelude)
_ (&cache/delete repl-module)
_ (&module/create-module repl-module 0)
_ (fn [?state]
diff --git a/lux-bootstrapper/src/lux/type.clj b/lux-bootstrapper/src/lux/type.clj
index 8853224b5..267b6d67b 100644
--- a/lux-bootstrapper/src/lux/type.clj
+++ b/lux-bootstrapper/src/lux/type.clj
@@ -25,41 +25,43 @@
(def empty-env &/$Nil)
-(def I64 (&/$Named (&/T ["lux" "I64"])
+(def I64 (&/$Named (&/T [&/prelude "I64"])
(&/$UnivQ empty-env
(&/$Primitive "#I64" (&/|list (&/$Parameter 1))))))
(def Nat* (&/$Primitive &&host/nat-data-tag &/$Nil))
(def Rev* (&/$Primitive &&host/rev-data-tag &/$Nil))
(def Int* (&/$Primitive &&host/int-data-tag &/$Nil))
-(def Bit (&/$Named (&/T ["lux" "Bit"]) (&/$Primitive "#Bit" &/$Nil)))
-(def Nat (&/$Named (&/T ["lux" "Nat"]) (&/$Apply Nat* I64)))
-(def Rev (&/$Named (&/T ["lux" "Rev"]) (&/$Apply Rev* I64)))
-(def Int (&/$Named (&/T ["lux" "Int"]) (&/$Apply Int* I64)))
-(def Frac (&/$Named (&/T ["lux" "Frac"]) (&/$Primitive "#Frac" &/$Nil)))
-(def Text (&/$Named (&/T ["lux" "Text"]) (&/$Primitive "#Text" &/$Nil)))
-(def Ident (&/$Named (&/T ["lux" "Ident"]) (&/$Product Text Text)))
+(def Bit (&/$Named (&/T [&/prelude "Bit"]) (&/$Primitive "#Bit" &/$Nil)))
+(def Nat (&/$Named (&/T [&/prelude "Nat"]) (&/$Apply Nat* I64)))
+(def Rev (&/$Named (&/T [&/prelude "Rev"]) (&/$Apply Rev* I64)))
+(def Int (&/$Named (&/T [&/prelude "Int"]) (&/$Apply Int* I64)))
+(def Frac (&/$Named (&/T [&/prelude "Frac"]) (&/$Primitive "#Frac" &/$Nil)))
+(def Text (&/$Named (&/T [&/prelude "Text"]) (&/$Primitive "#Text" &/$Nil)))
+(def Ident (&/$Named (&/T [&/prelude "Ident"]) (&/$Product Text Text)))
(defn Array [elemT]
(&/$Primitive "#Array" (&/|list elemT)))
(def Nothing
- (&/$Named (&/T ["lux" "Nothing"])
+ (&/$Named (&/T [&/prelude "Nothing"])
(&/$UnivQ empty-env
(&/$Parameter 1))))
(def Any
- (&/$Named (&/T ["lux" "Any"])
+ (&/$Named (&/T [&/prelude "Any"])
(&/$ExQ empty-env
(&/$Parameter 1))))
(def IO
- (&/$Named (&/T ["lux/control/io" "IO"])
+ (&/$Named (&/T [(str &/prelude "/control/io") "IO"])
(&/$UnivQ empty-env
- (&/$Primitive "lux/type/abstract.Abstraction lux/control/io.IO" (&/|list (&/$Parameter 1))))))
+ (&/$Primitive (str &/prelude "/type/abstract.Abstraction "
+ &/prelude "/control/io.IO")
+ (&/|list (&/$Parameter 1))))))
(def List
- (&/$Named (&/T ["lux" "List"])
+ (&/$Named (&/T [&/prelude "List"])
(&/$UnivQ empty-env
(&/$Sum
;; lux;Nil
@@ -70,7 +72,7 @@
(&/$Parameter 0)))))))
(def Maybe
- (&/$Named (&/T ["lux" "Maybe"])
+ (&/$Named (&/T [&/prelude "Maybe"])
(&/$UnivQ empty-env
(&/$Sum
;; lux;None
@@ -80,7 +82,7 @@
)))
(def Type
- (&/$Named (&/T ["lux" "Type"])
+ (&/$Named (&/T [&/prelude "Type"])
(let [Type (&/$Apply (&/$Parameter 1) (&/$Parameter 0))
TypeList (&/$Apply Type List)
TypePair (&/$Product Type Type)]
@@ -121,18 +123,18 @@
)))))
(def Location
- (&/$Named (&/T ["lux" "Location"])
+ (&/$Named (&/T [&/prelude "Location"])
(&/$Product Text (&/$Product Nat Nat))))
(def Meta
- (&/$Named (&/T ["lux" "Meta"])
+ (&/$Named (&/T [&/prelude "Meta"])
(&/$UnivQ empty-env
(&/$UnivQ empty-env
(&/$Product (&/$Parameter 3)
(&/$Parameter 1))))))
(def Code*
- (&/$Named (&/T ["lux" "Code'"])
+ (&/$Named (&/T [&/prelude "Code'"])
(let [Code (&/$Apply (&/$Apply (&/$Parameter 1)
(&/$Parameter 0))
(&/$Parameter 1))
@@ -164,12 +166,12 @@
))))
(def Code
- (&/$Named (&/T ["lux" "Code"])
+ (&/$Named (&/T [&/prelude "Code"])
(let [w (&/$Apply Location Meta)]
(&/$Apply (&/$Apply w Code*) w))))
(def Macro
- (&/$Named (&/T ["lux" "Macro"])
+ (&/$Named (&/T [&/prelude "Macro"])
(&/$Primitive "#Macro" &/$Nil)))
(defn bound? [id]
diff --git a/lux-bootstrapper/src/lux/type/host.clj b/lux-bootstrapper/src/lux/type/host.clj
index 36e969046..dbf780a84 100644
--- a/lux-bootstrapper/src/lux/type/host.clj
+++ b/lux-bootstrapper/src/lux/type/host.clj
@@ -59,7 +59,7 @@
output)))
(def ^:private Any
- (&/$Named (&/T ["lux" "Any"])
+ (&/$Named (&/T [&/prelude "Any"])
(&/$ExQ (&/|list)
(&/$Parameter 1))))
diff --git a/lux-js/source/program.lux b/lux-js/source/program.lux
index 28b18227f..6163c2dfa 100644
--- a/lux-js/source/program.lux
+++ b/lux-js/source/program.lux
@@ -1,66 +1,67 @@
(.module:
- [lux #*
- [program (#+ program:)]
- ["." ffi (#+ import:)]
- ["." debug]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." io (#+ IO io)]
- ["." function]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." product]
- ["." maybe]
- [text
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." array (#+ Array)]]]
- [macro
- ["." template]]
- [math
- [number
- ["n" nat]
- ["i" int]
- ["." i64]]]
- ["." world #_
- ["." file]
- ["#/." program]]
- ["@" target
- ["_" js]]
- [tool
- [compiler
- ["." phase (#+ Operation Phase)]
- [reference
- [variable (#+ Register)]]
- [language
- [lux
- [program (#+ Program)]
- [generation (#+ Context Host)]
- [analysis
- [macro (#+ Expander)]]
- [phase
- ["." extension (#+ Extender Handler)
- ["#/." bundle]
- ["." analysis #_
- ["#" js]]
- ["." generation #_
- ["#" js]]]
- [generation
- ["." reference]
- ["." js
- ["." runtime]]]]]]
- [default
- ["." platform (#+ Platform)]]
- [meta
- [archive (#+ Archive)]
- ["." packager #_
- ["#" script]]]]]]
+ [library
+ [lux #*
+ [program (#+ program:)]
+ ["." ffi (#+ import:)]
+ ["." debug]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO io)]
+ ["." function]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ [text
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." array (#+ Array)]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]
+ ["." i64]]]
+ ["." world #_
+ ["." file]
+ ["#/." program]]
+ ["@" target
+ ["_" js]]
+ [tool
+ [compiler
+ ["." phase (#+ Operation Phase)]
+ [reference
+ [variable (#+ Register)]]
+ [language
+ [lux
+ [program (#+ Program)]
+ [generation (#+ Context Host)]
+ [analysis
+ [macro (#+ Expander)]]
+ [phase
+ ["." extension (#+ Extender Handler)
+ ["#/." bundle]
+ ["." analysis #_
+ ["#" js]]
+ ["." generation #_
+ ["#" js]]]
+ [generation
+ ["." reference]
+ ["." js
+ ["." runtime]]]]]]
+ [default
+ ["." platform (#+ Platform)]]
+ [meta
+ [archive (#+ Archive)]
+ ["." packager #_
+ ["#" script]]]]]]]
[program
["/" compositor
["#." cli]
diff --git a/lux-jvm/source/luxc/lang/directive/jvm.lux b/lux-jvm/source/luxc/lang/directive/jvm.lux
index bcd40a1f8..4d78d729c 100644
--- a/lux-jvm/source/luxc/lang/directive/jvm.lux
+++ b/lux-jvm/source/luxc/lang/directive/jvm.lux
@@ -1,38 +1,39 @@
(.module:
- [lux #*
- [ffi (#+ import:)]
- [type (#+ :share)]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]]
- [data
- [identity (#+ Identity)]
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#@." fold)]
- ["." dictionary (#+ Dictionary)]
- ["." row (#+ Row) ("#@." functor fold)]]]
- [math
- [number
- ["." nat]]]
- [target
- ["/" jvm]]
- [tool
- [compiler
- ["." phase]
- [language
- [lux
- [synthesis (#+ Synthesis)]
- ["." generation]
- ["." directive]
- [phase
- ["." extension
- ["." bundle]
- [directive
- ["./" lux]]]]]]]]]
+ [library
+ [lux #*
+ [ffi (#+ import:)]
+ [type (#+ :share)]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ [identity (#+ Identity)]
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#@." fold)]
+ ["." dictionary (#+ Dictionary)]
+ ["." row (#+ Row) ("#@." functor fold)]]]
+ [math
+ [number
+ ["." nat]]]
+ [target
+ ["/" jvm]]
+ [tool
+ [compiler
+ ["." phase]
+ [language
+ [lux
+ [synthesis (#+ Synthesis)]
+ ["." generation]
+ ["." directive]
+ [phase
+ ["." extension
+ ["." bundle]
+ [directive
+ ["./" lux]]]]]]]]]]
[///
[host
["." jvm (#+ Inst)
diff --git a/lux-jvm/source/luxc/lang/host/jvm.lux b/lux-jvm/source/luxc/lang/host/jvm.lux
index a50090c5d..de92a3ba5 100644
--- a/lux-jvm/source/luxc/lang/host/jvm.lux
+++ b/lux-jvm/source/luxc/lang/host/jvm.lux
@@ -1,31 +1,32 @@
(.module:
- [lux (#- Definition Type)
- [ffi (#+ import:)]
- [abstract
- monad]
- [control
- ["<>" parser
- ["<.>" code]]]
- [data
- [binary (#+ Binary)]
- [collection
- ["." list ("#/." functor)]]]
- [macro
- ["." code]
- [syntax (#+ syntax:)]]
- [target
- [jvm
- ["." type (#+ Type)
- [category (#+ Class)]]]]
- [tool
- [compiler
- [reference
- [variable (#+ Register)]]
- [language
- [lux
- ["." generation]]]
- [meta
- [archive (#+ Archive)]]]]])
+ [library
+ [lux (#- Definition Type)
+ [ffi (#+ import:)]
+ [abstract
+ monad]
+ [control
+ ["<>" parser
+ ["<.>" code]]]
+ [data
+ [binary (#+ Binary)]
+ [collection
+ ["." list ("#/." functor)]]]
+ [macro
+ ["." code]
+ [syntax (#+ syntax:)]]
+ [target
+ [jvm
+ ["." type (#+ Type)
+ [category (#+ Class)]]]]
+ [tool
+ [compiler
+ [reference
+ [variable (#+ Register)]]
+ [language
+ [lux
+ ["." generation]]]
+ [meta
+ [archive (#+ Archive)]]]]]])
(import: org/objectweb/asm/MethodVisitor)
diff --git a/lux-jvm/source/luxc/lang/host/jvm/def.lux b/lux-jvm/source/luxc/lang/host/jvm/def.lux
index b2012006a..58121502a 100644
--- a/lux-jvm/source/luxc/lang/host/jvm/def.lux
+++ b/lux-jvm/source/luxc/lang/host/jvm/def.lux
@@ -1,26 +1,27 @@
(.module:
- [lux (#- Type)
- ["." ffi (#+ import: do_to)]
- [control
- ["." function]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." array (#+ Array)]
- ["." list ("#@." functor)]]]
- [math
- [number
- ["i" int]]]
- [target
- [jvm
- [encoding
- ["." name]]
- ["." type (#+ Type Constraint)
- [category (#+ Class Value Method)]
- ["." signature]
- ["." descriptor]]]]]
+ [library
+ [lux (#- Type)
+ ["." ffi (#+ import: do_to)]
+ [control
+ ["." function]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." array (#+ Array)]
+ ["." list ("#@." functor)]]]
+ [math
+ [number
+ ["i" int]]]
+ [target
+ [jvm
+ [encoding
+ ["." name]]
+ ["." type (#+ Type Constraint)
+ [category (#+ Class Value Method)]
+ ["." signature]
+ ["." descriptor]]]]]]
["." //])
(def: signature (|>> type.signature signature.signature))
diff --git a/lux-jvm/source/luxc/lang/host/jvm/inst.lux b/lux-jvm/source/luxc/lang/host/jvm/inst.lux
index 95de82463..8427e23e1 100644
--- a/lux-jvm/source/luxc/lang/host/jvm/inst.lux
+++ b/lux-jvm/source/luxc/lang/host/jvm/inst.lux
@@ -1,38 +1,39 @@
(.module:
- [lux (#- Type int char try)
- ["." ffi (#+ import: do_to)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." function]
- ["." try]
- ["p" parser
- ["s" code]]]
- [data
- ["." product]
- ["." maybe]
- [collection
- ["." list ("#@." functor)]]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]
- ["." template]]
- [math
- [number
- ["n" nat]
- ["i" int]]]
- [target
- [jvm
- [encoding
- ["." name (#+ External)]]
- ["." type (#+ Type) ("#@." equivalence)
- [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
- ["." box]
- ["." descriptor]
- ["." reflection]]]]
- [tool
- [compiler
- [phase (#+ Operation)]]]]
+ [library
+ [lux (#- Type int char try)
+ ["." ffi (#+ import: do_to)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try]
+ ["p" parser
+ ["s" code]]]
+ [data
+ ["." product]
+ ["." maybe]
+ [collection
+ ["." list ("#@." functor)]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]
+ ["." template]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]]]
+ [target
+ [jvm
+ [encoding
+ ["." name (#+ External)]]
+ ["." type (#+ Type) ("#@." equivalence)
+ [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
+ ["." box]
+ ["." descriptor]
+ ["." reflection]]]]
+ [tool
+ [compiler
+ [phase (#+ Operation)]]]]]
["." // (#+ Inst)])
(def: class_name (|>> type.descriptor descriptor.class_name name.read))
diff --git a/lux-jvm/source/luxc/lang/synthesis/variable.lux b/lux-jvm/source/luxc/lang/synthesis/variable.lux
index f6a45b02e..33f359239 100644
--- a/lux-jvm/source/luxc/lang/synthesis/variable.lux
+++ b/lux-jvm/source/luxc/lang/synthesis/variable.lux
@@ -1,6 +1,7 @@
(.module:
lux
- (lux (data [number]
+ (lux (data [library
+ [number]]
(coll [list "list/" Fold<List> Monoid<List>]
["s" set])))
(luxc (lang ["la" analysis]
diff --git a/lux-jvm/source/luxc/lang/translation/jvm.lux b/lux-jvm/source/luxc/lang/translation/jvm.lux
index 7b5df9f08..4cd521f9f 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm.lux
@@ -1,39 +1,40 @@
(.module:
- [lux (#- Module Definition)
- ["." ffi (#+ import: do_to object)]
- [abstract
- [monad (#+ do)]]
- [control
- pipe
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." io (#+ IO io)]
- [concurrency
- ["." atom (#+ Atom atom)]]]
- [data
- [binary (#+ Binary)]
- ["." product]
- ["." text ("#@." hash)
- ["%" format (#+ format)]]
- [collection
- ["." array]
- ["." dictionary (#+ Dictionary)]]]
- [target
- [jvm
- ["." loader (#+ Library)]
- ["." type
- ["." descriptor]]]]
- [tool
- [compiler
- [language
- [lux
- ["." version]
- ["." generation]]]
- [meta
- [io (#+ lux_context)]
- [archive
- [descriptor (#+ Module)]
- ["." artifact]]]]]]
+ [library
+ [lux (#- Module Definition)
+ ["." ffi (#+ import: do_to object)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ pipe
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO io)]
+ [concurrency
+ ["." atom (#+ Atom atom)]]]
+ [data
+ [binary (#+ Binary)]
+ ["." product]
+ ["." text ("#@." hash)
+ ["%" format (#+ format)]]
+ [collection
+ ["." array]
+ ["." dictionary (#+ Dictionary)]]]
+ [target
+ [jvm
+ ["." loader (#+ Library)]
+ ["." type
+ ["." descriptor]]]]
+ [tool
+ [compiler
+ [language
+ [lux
+ ["." version]
+ ["." generation]]]
+ [meta
+ [io (#+ lux_context)]
+ [archive
+ [descriptor (#+ Module)]
+ ["." artifact]]]]]]]
[///
[host
["." jvm (#+ Inst Definition Host State)
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/case.lux b/lux-jvm/source/luxc/lang/translation/jvm/case.lux
index f3bbb2a1c..65e5dba62 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/case.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/case.lux
@@ -1,30 +1,31 @@
(.module:
- [lux (#- Type if let case)
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["ex" exception (#+ exception:)]]
- [data
- [collection
- ["." list ("#@." fold)]]]
- [math
- [number
- ["n" nat]]]
- [target
- [jvm
- ["." type (#+ Type)
- ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]
- ["." descriptor (#+ Descriptor)]
- ["." signature (#+ Signature)]]]]
- [tool
- [compiler
- ["." phase ("operation@." monad)]
- [meta
- [archive (#+ Archive)]]
- [language
- [lux
- ["." synthesis (#+ Path Synthesis)]]]]]]
+ [library
+ [lux (#- Type if let case)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["ex" exception (#+ exception:)]]
+ [data
+ [collection
+ ["." list ("#@." fold)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [target
+ [jvm
+ ["." type (#+ Type)
+ ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]
+ ["." descriptor (#+ Descriptor)]
+ ["." signature (#+ Signature)]]]]
+ [tool
+ [compiler
+ ["." phase ("operation@." monad)]
+ [meta
+ [archive (#+ Archive)]]
+ [language
+ [lux
+ ["." synthesis (#+ Path Synthesis)]]]]]]]
[luxc
[lang
[host
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/common.lux b/lux-jvm/source/luxc/lang/translation/jvm/common.lux
index 6cd7f4f2f..10e865283 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/common.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/common.lux
@@ -1,25 +1,26 @@
(.module:
- [lux #*
- ## [abstract
- ## [monad (#+ do)]]
- ## [control
- ## ["." try (#+ Try)]
- ## ["ex" exception (#+ exception:)]
- ## ["." io]]
- ## [data
- ## [binary (#+ Binary)]
- ## ["." text ("#/." hash)
- ## format]
- ## [collection
- ## ["." dictionary (#+ Dictionary)]]]
- ## ["." macro]
- ## [host (#+ import:)]
- ## [tool
- ## [compiler
- ## [reference (#+ Register)]
- ## ["." name]
- ## ["." phase]]]
- ]
+ [library
+ [lux #*
+ ## [abstract
+ ## [monad (#+ do)]]
+ ## [control
+ ## ["." try (#+ Try)]
+ ## ["ex" exception (#+ exception:)]
+ ## ["." io]]
+ ## [data
+ ## [binary (#+ Binary)]
+ ## ["." text ("#/." hash)
+ ## format]
+ ## [collection
+ ## ["." dictionary (#+ Dictionary)]]]
+ ## ["." macro]
+ ## [host (#+ import:)]
+ ## [tool
+ ## [compiler
+ ## [reference (#+ Register)]
+ ## ["." name]
+ ## ["." phase]]]
+ ]]
## [luxc
## [lang
## [host
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/expression.lux b/lux-jvm/source/luxc/lang/translation/jvm/expression.lux
index 01425750f..44abe2444 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/expression.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/expression.lux
@@ -1,12 +1,13 @@
(.module:
- [lux #*
- [tool
- [compiler
- [language
- [lux
- ["." synthesis]
- [phase
- ["." extension]]]]]]]
+ [library
+ [lux #*
+ [tool
+ [compiler
+ [language
+ [lux
+ ["." synthesis]
+ [phase
+ ["." extension]]]]]]]]
[luxc
[lang
[host
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension.lux
index 9066dd156..2f1bd6a36 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/extension.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/extension.lux
@@ -1,8 +1,9 @@
(.module:
- [lux #*
- [data
- [collection
- ["." dictionary]]]]
+ [library
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]]
[////
[host
[jvm (#+ Bundle)]]]
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux
index c15d1ffcf..d79362d79 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux
@@ -1,37 +1,38 @@
(.module:
- [lux (#- Type)
- [ffi (#+ import:)]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- ["." product]
- [collection
- ["." list ("#@." monad)]
- ["." dictionary]]]
- [math
- [number
- ["f" frac]]]
- [target
- [jvm
- ["." type]]]
- [tool
- [compiler
- ["." phase]
- [meta
- [archive (#+ Archive)]]
- [language
- [lux
- ["." synthesis (#+ Synthesis %synthesis)]
- [phase
- [generation
- [extension (#+ Nullary Unary Binary Trinary Variadic
- nullary unary binary trinary variadic)]]
- ["." extension
- ["." bundle]]]]]]]]
+ [library
+ [lux (#- Type)
+ [ffi (#+ import:)]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ [collection
+ ["." list ("#@." monad)]
+ ["." dictionary]]]
+ [math
+ [number
+ ["f" frac]]]
+ [target
+ [jvm
+ ["." type]]]
+ [tool
+ [compiler
+ ["." phase]
+ [meta
+ [archive (#+ Archive)]]
+ [language
+ [lux
+ ["." synthesis (#+ Synthesis %synthesis)]
+ [phase
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary Variadic
+ nullary unary binary trinary variadic)]]
+ ["." extension
+ ["." bundle]]]]]]]]]
[luxc
[lang
[host
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
index 96fa95363..69e63ab71 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
@@ -1,56 +1,57 @@
(.module:
- [lux (#- Type primitive int char type)
- [ffi (#+ import:)]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." exception (#+ exception:)]
- ["." function]
- ["<>" parser ("#@." monad)
- ["<.>" text]
- ["<.>" synthesis (#+ Parser)]]]
- [data
- ["." product]
- ["." maybe ("#@." functor)]
- ["." text ("#@." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#@." monad)]
- ["." dictionary (#+ Dictionary)]
- ["." set]]]
- [math
- [number
- ["." nat]]]
- [target
- [jvm
- ["." type (#+ Type Typed Argument)
- ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]
- ["." box]
- ["." reflection]
- ["." signature]
- ["." parser]]]]
- [tool
- [compiler
- ["." phase ("#@." monad)]
- [reference (#+)
- ["." variable (#+ Variable)]]
- [meta
- [archive (#+ Archive)]]
- [language
- [lux
- [analysis (#+ Environment)]
- ["." synthesis (#+ Synthesis Path %synthesis)]
- ["." generation]
- [phase
- [generation
- [extension (#+ Nullary Unary Binary
- nullary unary binary)]]
- [analysis
- [".A" reference]]
- ["." extension
- ["." bundle]
+ [library
+ [lux (#- Type primitive int char type)
+ [ffi (#+ import:)]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]
+ ["." function]
+ ["<>" parser ("#@." monad)
+ ["<.>" text]
+ ["<.>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." maybe ("#@." functor)]
+ ["." text ("#@." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#@." monad)]
+ ["." dictionary (#+ Dictionary)]
+ ["." set]]]
+ [math
+ [number
+ ["." nat]]]
+ [target
+ [jvm
+ ["." type (#+ Type Typed Argument)
+ ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]
+ ["." box]
+ ["." reflection]
+ ["." signature]
+ ["." parser]]]]
+ [tool
+ [compiler
+ ["." phase ("#@." monad)]
+ [reference (#+)
+ ["." variable (#+ Variable)]]
+ [meta
+ [archive (#+ Archive)]]
+ [language
+ [lux
+ [analysis (#+ Environment)]
+ ["." synthesis (#+ Synthesis Path %synthesis)]
+ ["." generation]
+ [phase
+ [generation
+ [extension (#+ Nullary Unary Binary
+ nullary unary binary)]]
[analysis
- ["/" jvm]]]]]]]]]
+ [".A" reference]]
+ ["." extension
+ ["." bundle]
+ [analysis
+ ["/" jvm]]]]]]]]]]
[luxc
[lang
[host
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/function.lux b/lux-jvm/source/luxc/lang/translation/jvm/function.lux
index a3583155b..f524dc097 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/function.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/function.lux
@@ -1,38 +1,39 @@
(.module:
- [lux (#- Type function)
- [abstract
- ["." monad (#+ do)]
- ["." enum]]
- [control
- [pipe (#+ when> new>)]
- ["." function]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#@." functor monoid)]]]
- [math
- [number
- ["n" nat]
- ["i" int]]]
- [target
- [jvm
- ["." type (#+ Type)
- ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]]]]
- [tool
- [compiler
- [arity (#+ Arity)]
- ["." phase]
- [reference
- [variable (#+ Register)]]
- [language
- [lux
- [analysis (#+ Environment)]
- [synthesis (#+ Synthesis Abstraction Apply)]
- ["." generation (#+ Context)]]]
- [meta
- [archive (#+ Archive)]]]]]
+ [library
+ [lux (#- Type function)
+ [abstract
+ ["." monad (#+ do)]
+ ["." enum]]
+ [control
+ [pipe (#+ when> new>)]
+ ["." function]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#@." functor monoid)]]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]]]
+ [target
+ [jvm
+ ["." type (#+ Type)
+ ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]]]]
+ [tool
+ [compiler
+ [arity (#+ Arity)]
+ ["." phase]
+ [reference
+ [variable (#+ Register)]]
+ [language
+ [lux
+ [analysis (#+ Environment)]
+ [synthesis (#+ Synthesis Abstraction Apply)]
+ ["." generation (#+ Context)]]]
+ [meta
+ [archive (#+ Archive)]]]]]]
[luxc
[lang
[host
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/loop.lux b/lux-jvm/source/luxc/lang/translation/jvm/loop.lux
index 5ad997539..d17d3dfe2 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/loop.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/loop.lux
@@ -1,24 +1,25 @@
(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]]
- [data
- [collection
- ["." list ("#@." functor monoid)]]]
- [math
- [number
- ["n" nat]]]
- [tool
- [compiler
- ["." phase]
- [reference
- [variable (#+ Register)]]
- [language
- [lux
- ["." synthesis (#+ Synthesis)]
- ["." generation]]]]]]
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]]
+ [data
+ [collection
+ ["." list ("#@." functor monoid)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [tool
+ [compiler
+ ["." phase]
+ [reference
+ [variable (#+ Register)]]
+ [language
+ [lux
+ ["." synthesis (#+ Synthesis)]
+ ["." generation]]]]]]]
[luxc
[lang
[host
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/primitive.lux b/lux-jvm/source/luxc/lang/translation/jvm/primitive.lux
index 5f3a98b0f..1bced2ffc 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/primitive.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/primitive.lux
@@ -1,15 +1,16 @@
(.module:
- [lux (#- i64)
- ["." ffi (#+ import:)]
- [math
- [number
- ["i" int]]]
- [target
- [jvm
- ["." type]]]
- [tool
- [compiler
- [phase ("operation@." monad)]]]]
+ [library
+ [lux (#- i64)
+ ["." ffi (#+ import:)]
+ [math
+ [number
+ ["i" int]]]
+ [target
+ [jvm
+ ["." type]]]
+ [tool
+ [compiler
+ [phase ("operation@." monad)]]]]]
[luxc
[lang
[host
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/program.lux b/lux-jvm/source/luxc/lang/translation/jvm/program.lux
index 234c20fa9..1ebdf33f0 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/program.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/program.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- [data
- [text
- ["%" format (#+ format)]]]
- [target
- [jvm
- ["$t" type]]]
- [tool
- [compiler
- [language
- [lux
- [generation (#+ Context)]
- [program (#+ Program)]]]]]]
+ [library
+ [lux #*
+ [data
+ [text
+ ["%" format (#+ format)]]]
+ [target
+ [jvm
+ ["$t" type]]]
+ [tool
+ [compiler
+ [language
+ [lux
+ [generation (#+ Context)]
+ [program (#+ Program)]]]]]]]
[luxc
[lang
[host
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/reference.lux b/lux-jvm/source/luxc/lang/translation/jvm/reference.lux
index d2a524a82..bfbda85be 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/reference.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/reference.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [data
- [text
- ["%" format (#+ format)]]]
- [target
- [jvm
- ["." type]]]
- [tool
- [compiler
- [reference
- ["." variable (#+ Register Variable)]]
- ["." phase ("operation@." monad)]
- [meta
- [archive (#+ Archive)]]
- [language
- [lux
- ["." generation]]]]]]
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [data
+ [text
+ ["%" format (#+ format)]]]
+ [target
+ [jvm
+ ["." type]]]
+ [tool
+ [compiler
+ [reference
+ ["." variable (#+ Register Variable)]]
+ ["." phase ("operation@." monad)]
+ [meta
+ [archive (#+ Archive)]]
+ [language
+ [lux
+ ["." generation]]]]]]]
[luxc
[lang
[host
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux
index cd719679d..20bd9bd9e 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux
@@ -1,35 +1,36 @@
(.module:
- [lux (#- Type try)
- [abstract
- [monad (#+ do)]
- ["." enum]]
- [data
- [binary (#+ Binary)]
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#@." functor)]
- ["." row]]]
- ["." math
- [number
- ["n" nat]]]
- [target
- [jvm
- ["." type (#+ Type)
- ["." category (#+ Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method)]
- ["." reflection]]]]
- [tool
- [compiler
- [arity (#+ Arity)]
- ["." phase]
- [language
- [lux
- ["." synthesis]
- ["." generation]]]
- [meta
- [archive (#+ Output)
- ["." artifact (#+ Registry)]]]]]]
+ [library
+ [lux (#- Type try)
+ [abstract
+ [monad (#+ do)]
+ ["." enum]]
+ [data
+ [binary (#+ Binary)]
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#@." functor)]
+ ["." row]]]
+ ["." math
+ [number
+ ["n" nat]]]
+ [target
+ [jvm
+ ["." type (#+ Type)
+ ["." category (#+ Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method)]
+ ["." reflection]]]]
+ [tool
+ [compiler
+ [arity (#+ Arity)]
+ ["." phase]
+ [language
+ [lux
+ ["." synthesis]
+ ["." generation]]]
+ [meta
+ [archive (#+ Output)
+ ["." artifact (#+ Registry)]]]]]]]
[luxc
[lang
[host
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/structure.lux b/lux-jvm/source/luxc/lang/translation/jvm/structure.lux
index 100bce9d9..16b320b6d 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/structure.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/structure.lux
@@ -1,33 +1,34 @@
(.module:
- [lux (#- Type)
- ["." ffi (#+ import:)]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." exception (#+ exception:)]]
- [data
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list]]]
- [math
- [number
- ["n" nat]
- ["i" int]]]
- [target
- [jvm
- ["." type (#+ Type)
- ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]
- ["." descriptor (#+ Descriptor)]
- ["." signature (#+ Signature)]]]]
- [tool
- [compiler
- ["." phase]
- [meta
- [archive (#+ Archive)]]
- [language
- [lux
- [synthesis (#+ Synthesis)]]]]]]
+ [library
+ [lux (#- Type)
+ ["." ffi (#+ import:)]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]]
+ [data
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list]]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]]]
+ [target
+ [jvm
+ ["." type (#+ Type)
+ ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]
+ ["." descriptor (#+ Descriptor)]
+ ["." signature (#+ Signature)]]]]
+ [tool
+ [compiler
+ ["." phase]
+ [meta
+ [archive (#+ Archive)]]
+ [language
+ [lux
+ [synthesis (#+ Synthesis)]]]]]]]
[luxc
[lang
[host
diff --git a/lux-jvm/source/program.lux b/lux-jvm/source/program.lux
index e9f58a71b..185d2d9ba 100644
--- a/lux-jvm/source/program.lux
+++ b/lux-jvm/source/program.lux
@@ -1,60 +1,61 @@
(.module:
- [lux (#- Definition)
- [program (#+ program:)]
- ["@" target]
- ["." ffi (#+ import:)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io (#+ IO)]
- ["." try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- [array (#+ Array)]
- ["." dictionary]]]
- ["." world #_
- ["." file]
- ["#/." program]]
- [target
- ["." jvm #_
- [bytecode (#+ Bytecode)]
- ["#/." type
- ["#/." box]]]]
- [tool
- [compiler
- [reference (#+)]
- ["." phase]
- [default
- ["." platform (#+ Platform)]]
- [meta
- [archive (#+ Archive)]
- ["." packager #_
- ["#" jvm]]]
- [language
- [lux
- ["$" synthesis (#+ Synthesis)]
- ["." generation]
- [analysis
- [macro (#+ Expander)]]
- [phase
- [extension (#+ Phase Bundle Operation Handler Extender)
- ["." analysis #_
- ["#" jvm]]
- ## ["." generation #_
- ## ["#" jvm]]
- ## ["." directive #_
- ## ["#" jvm]]
- ]
- [generation
- ["." jvm #_
- ["#/." runtime]
- ## ["#/." host]
- ]]]]]]]]
+ [library
+ [lux (#- Definition)
+ [program (#+ program:)]
+ ["@" target]
+ ["." ffi (#+ import:)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io (#+ IO)]
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ [array (#+ Array)]
+ ["." dictionary]]]
+ ["." world #_
+ ["." file]
+ ["#/." program]]
+ [target
+ ["." jvm #_
+ [bytecode (#+ Bytecode)]
+ ["#/." type
+ ["#/." box]]]]
+ [tool
+ [compiler
+ [reference (#+)]
+ ["." phase]
+ [default
+ ["." platform (#+ Platform)]]
+ [meta
+ [archive (#+ Archive)]
+ ["." packager #_
+ ["#" jvm]]]
+ [language
+ [lux
+ ["$" synthesis (#+ Synthesis)]
+ ["." generation]
+ [analysis
+ [macro (#+ Expander)]]
+ [phase
+ [extension (#+ Phase Bundle Operation Handler Extender)
+ ["." analysis #_
+ ["#" jvm]]
+ ## ["." generation #_
+ ## ["#" jvm]]
+ ## ["." directive #_
+ ## ["#" jvm]]
+ ]
+ [generation
+ ["." jvm #_
+ ["#/." runtime]
+ ## ["#/." host]
+ ]]]]]]]]]
[program
["/" compositor
["/." cli]
diff --git a/lux-lua/source/program.lux b/lux-lua/source/program.lux
index 083c8ca0c..6c7719220 100644
--- a/lux-lua/source/program.lux
+++ b/lux-lua/source/program.lux
@@ -1,64 +1,65 @@
(.module:
- [lux #*
- [program (#+ program:)]
- ["." ffi]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." io (#+ IO io)]
- ["." function]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." maybe]
- ["." text ("#\." hash)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." array (#+ Array)]
- ["." list]]]
- [macro
- ["." template]]
- [math
- [number (#+ hex)
- ["n" nat]
- ["." i64]]]
- ["." world #_
- ["." file]
- ["#/." program]]
- ["@" target
- ["_" lua]]
- [tool
- [compiler
- ["." phase (#+ Operation Phase)]
- [reference
- [variable (#+ Register)]]
- [language
- [lux
- [program (#+ Program)]
- [generation (#+ Context Host)]
- [analysis
- [macro (#+ Expander)]]
- [phase
- ["." extension (#+ Extender Handler)
- ["#/." bundle]
- ["." analysis #_
- ["#" lua]]
- ["." generation #_
- ["#" lua]]]
- [generation
- ["." reference]
- ["." lua
- ["." runtime]]]]]]
- [default
- ["." platform (#+ Platform)]]
- [meta
- [archive (#+ Archive)]
- ["." packager #_
- ["#" script]]]]]]
+ [library
+ [lux #*
+ [program (#+ program:)]
+ ["." ffi]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO io)]
+ ["." function]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." maybe]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." array (#+ Array)]
+ ["." list]]]
+ [macro
+ ["." template]]
+ [math
+ [number (#+ hex)
+ ["n" nat]
+ ["." i64]]]
+ ["." world #_
+ ["." file]
+ ["#/." program]]
+ ["@" target
+ ["_" lua]]
+ [tool
+ [compiler
+ ["." phase (#+ Operation Phase)]
+ [reference
+ [variable (#+ Register)]]
+ [language
+ [lux
+ [program (#+ Program)]
+ [generation (#+ Context Host)]
+ [analysis
+ [macro (#+ Expander)]]
+ [phase
+ ["." extension (#+ Extender Handler)
+ ["#/." bundle]
+ ["." analysis #_
+ ["#" lua]]
+ ["." generation #_
+ ["#" lua]]]
+ [generation
+ ["." reference]
+ ["." lua
+ ["." runtime]]]]]]
+ [default
+ ["." platform (#+ Platform)]]
+ [meta
+ [archive (#+ Archive)]
+ ["." packager #_
+ ["#" script]]]]]]]
[program
["/" compositor
["#." cli]
diff --git a/lux-php/source/lux.lux b/lux-php/source/lux.lux
new file mode 120000
index 000000000..73d05a22e
--- /dev/null
+++ b/lux-php/source/lux.lux
@@ -0,0 +1 @@
+/home/eduardoejp/lux/stdlib/source/lux.lux \ No newline at end of file
diff --git a/lux-python/source/program.lux b/lux-python/source/program.lux
index 2fc611fe4..f00594c99 100644
--- a/lux-python/source/program.lux
+++ b/lux-python/source/program.lux
@@ -1,66 +1,67 @@
(.module:
- [lux #*
- [program (#+ program:)]
- ["." ffi (#+ import:)]
- [abstract
- [monad (#+ do)]]
- [control
- [pipe (#+ new>)]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." io (#+ IO io)]
- ["." function]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." maybe]
- ["." text ("#\." hash)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." array (#+ Array)]
- ["." list]]]
- [macro
- ["." template]]
- [math
- [number
- ["n" nat]
- ["." i64]]]
- ["." world #_
- ["." file]
- ["#/." program]]
- ["@" target
- ["_" python]]
- [tool
- [compiler
- ["." phase (#+ Operation Phase)]
- [reference
- [variable (#+ Register)]]
- [language
- [lux
- [program (#+ Program)]
- [generation (#+ Context Host)]
- ["." synthesis]
- [analysis
- [macro (#+ Expander)]]
- [phase
- ["." extension (#+ Extender Handler)
- ["#/." bundle]
- ["." analysis #_
- ["#" python]]
- ["." generation #_
- ["#" python]]]
- [generation
- ["." reference]
- ["." python
- ["." runtime]]]]]]
- [default
- ["." platform (#+ Platform)]]
- [meta
- [archive (#+ Archive)]
- ["." packager #_
- ["#" script]]]]]]
+ [library
+ [lux #*
+ [program (#+ program:)]
+ ["." ffi (#+ import:)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ new>)]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO io)]
+ ["." function]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." maybe]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." array (#+ Array)]
+ ["." list]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["n" nat]
+ ["." i64]]]
+ ["." world #_
+ ["." file]
+ ["#/." program]]
+ ["@" target
+ ["_" python]]
+ [tool
+ [compiler
+ ["." phase (#+ Operation Phase)]
+ [reference
+ [variable (#+ Register)]]
+ [language
+ [lux
+ [program (#+ Program)]
+ [generation (#+ Context Host)]
+ ["." synthesis]
+ [analysis
+ [macro (#+ Expander)]]
+ [phase
+ ["." extension (#+ Extender Handler)
+ ["#/." bundle]
+ ["." analysis #_
+ ["#" python]]
+ ["." generation #_
+ ["#" python]]]
+ [generation
+ ["." reference]
+ ["." python
+ ["." runtime]]]]]]
+ [default
+ ["." platform (#+ Platform)]]
+ [meta
+ [archive (#+ Archive)]
+ ["." packager #_
+ ["#" script]]]]]]]
[program
["/" compositor
["/." cli]
diff --git a/lux-ruby/source/program.lux b/lux-ruby/source/program.lux
index 91d9980d2..a221e6529 100644
--- a/lux-ruby/source/program.lux
+++ b/lux-ruby/source/program.lux
@@ -1,73 +1,74 @@
(.module:
- [lux #*
- [program (#+ program:)]
- ["." debug]
- ["." ffi (#+ import:)]
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- [pipe (#+ new>)]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." io (#+ IO io)]
- ["." function]
- [concurrency
- ["." promise (#+ Promise)]]
- ["<>" parser
- ["<.>" code]]]
- [data
- ["." maybe]
- ["." text ("#\." hash)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." array (#+ Array)]
- ["." list]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." template]
- ["." code]]
- [math
- [number (#+ hex)
- ["n" nat]
- ["i" int]
- ["." i64]]]
- ["." world #_
- ["." file]
- ["#/." program]]
- ["@" target
- ["_" ruby]]
- [tool
- [compiler
- ["." phase (#+ Operation Phase)]
- [reference
- [variable (#+ Register)]]
- [language
- [lux
- [program (#+ Program)]
- [generation (#+ Context Host)]
- ["." synthesis]
- [analysis
- [macro (#+ Expander)]]
- [phase
- ["." extension (#+ Extender Handler)
- ["#/." bundle]
- ["." analysis #_
- ["#" ruby]]
- ["." generation #_
- ["#" ruby]]]
- [generation
- ["." reference]
- ["." ruby
- ["." runtime]]]]]]
- [default
- ["." platform (#+ Platform)]]
- [meta
- [archive (#+ Archive)]
- ["." packager #_
- ["#" script]]]]]]
+ [library
+ [lux #*
+ [program (#+ program:)]
+ ["." debug]
+ ["." ffi (#+ import:)]
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ [pipe (#+ new>)]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO io)]
+ ["." function]
+ [concurrency
+ ["." promise (#+ Promise)]]
+ ["<>" parser
+ ["<.>" code]]]
+ [data
+ ["." maybe]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." array (#+ Array)]
+ ["." list]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." template]
+ ["." code]]
+ [math
+ [number (#+ hex)
+ ["n" nat]
+ ["i" int]
+ ["." i64]]]
+ ["." world #_
+ ["." file]
+ ["#/." program]]
+ ["@" target
+ ["_" ruby]]
+ [tool
+ [compiler
+ ["." phase (#+ Operation Phase)]
+ [reference
+ [variable (#+ Register)]]
+ [language
+ [lux
+ [program (#+ Program)]
+ [generation (#+ Context Host)]
+ ["." synthesis]
+ [analysis
+ [macro (#+ Expander)]]
+ [phase
+ ["." extension (#+ Extender Handler)
+ ["#/." bundle]
+ ["." analysis #_
+ ["#" ruby]]
+ ["." generation #_
+ ["#" ruby]]]
+ [generation
+ ["." reference]
+ ["." ruby
+ ["." runtime]]]]]]
+ [default
+ ["." platform (#+ Platform)]]
+ [meta
+ [archive (#+ Archive)]
+ ["." packager #_
+ ["#" script]]]]]]]
[program
["/" compositor
["/." cli]
diff --git a/stdlib/source/library/lux.lux b/stdlib/source/library/lux.lux
new file mode 100644
index 000000000..3a7fa442b
--- /dev/null
+++ b/stdlib/source/library/lux.lux
@@ -0,0 +1,5958 @@
+("lux def" dummy_location
+ ["" 0 0]
+ [["" 0 0] (9 #1 (0 #0))]
+ #0)
+
+("lux def" double_quote
+ ("lux i64 char" +34)
+ [dummy_location (9 #1 (0 #0))]
+ #0)
+
+("lux def" \n
+ ("lux i64 char" +10)
+ [dummy_location (9 #1 (0 #0))]
+ #0)
+
+("lux def" __paragraph
+ ("lux text concat" \n \n)
+ [dummy_location (9 #1 (0 #0))]
+ #0)
+
+("lux def" prelude_module
+ "library/lux"
+ [dummy_location (9 #1 (0 #0))]
+ #1)
+
+## (type: Any
+## (Ex [a] a))
+("lux def" Any
+ ("lux type check type"
+ (9 #1 [..prelude_module "Any"]
+ (8 #0 (0 #0) (4 #0 1))))
+ [dummy_location
+ (9 #1 (0 #1 [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 ("lux text concat"
+ ("lux text concat" "The type of things whose type is irrelevant." __paragraph)
+ "It can be used to write functions or data-structures that can take, or return, anything."))]]
+ (0 #0)))]
+ #1)
+
+## (type: Nothing
+## (All [a] a))
+("lux def" Nothing
+ ("lux type check type"
+ (9 #1 [..prelude_module "Nothing"]
+ (7 #0 (0 #0) (4 #0 1))))
+ [dummy_location
+ (9 #1 (0 #1 [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 ("lux text concat"
+ ("lux text concat" "The type of things whose type is undefined." __paragraph)
+ "Useful for expressions that cause errors or other 'extraordinary' conditions."))]]
+ (0 #0)))]
+ #1)
+
+## (type: (List a)
+## #Nil
+## (#Cons a (List a)))
+("lux def type tagged" List
+ (9 #1 [..prelude_module "List"]
+ (7 #0 (0 #0)
+ (1 #0 ## "lux.Nil"
+ Any
+ ## "lux.Cons"
+ (2 #0 (4 #0 1)
+ (9 #0 (4 #0 1) (4 #0 0))))))
+ [dummy_location
+ (9 #1 (0 #1 [[dummy_location (7 #0 [..prelude_module "type-args"])]
+ [dummy_location (9 #0 (0 #1 [dummy_location (5 #0 "a")] (0 #0)))]]
+ (0 #1 [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "A potentially empty list of values.")]]
+ (0 #0))))]
+ ["Nil" "Cons"]
+ #1)
+
+("lux def" Bit
+ ("lux type check type"
+ (9 #1 [..prelude_module "Bit"]
+ (0 #0 "#Bit" #Nil)))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "Your standard, run-of-the-mill boolean values (as bits).")]]
+ #Nil))]
+ #1)
+
+("lux def" I64
+ ("lux type check type"
+ (9 #1 [..prelude_module "I64"]
+ (7 #0 (0 #0)
+ (0 #0 "#I64" (#Cons (4 #0 1) #Nil)))))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "64-bit integers without any semantics.")]]
+ #Nil))]
+ #1)
+
+("lux def" Nat
+ ("lux type check type"
+ (9 #1 [..prelude_module "Nat"]
+ (0 #0 "#I64" (#Cons (0 #0 "#Nat" #Nil) #Nil))))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 ("lux text concat"
+ ("lux text concat" "Natural numbers (unsigned integers)." __paragraph)
+ "They start at zero (0) and extend in the positive direction."))]]
+ #Nil))]
+ #1)
+
+("lux def" Int
+ ("lux type check type"
+ (9 #1 [..prelude_module "Int"]
+ (0 #0 "#I64" (#Cons (0 #0 "#Int" #Nil) #Nil))))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "Your standard, run-of-the-mill integer numbers.")]]
+ #Nil))]
+ #1)
+
+("lux def" Rev
+ ("lux type check type"
+ (9 #1 [..prelude_module "Rev"]
+ (0 #0 "#I64" (#Cons (0 #0 "#Rev" #Nil) #Nil))))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 ("lux text concat"
+ ("lux text concat" "Fractional numbers that live in the interval [0,1)." __paragraph)
+ "Useful for probability, and other domains that work within that interval."))]]
+ #Nil))]
+ #1)
+
+("lux def" Frac
+ ("lux type check type"
+ (9 #1 [..prelude_module "Frac"]
+ (0 #0 "#Frac" #Nil)))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "Your standard, run-of-the-mill floating-point (fractional) numbers.")]]
+ #Nil))]
+ #1)
+
+("lux def" Text
+ ("lux type check type"
+ (9 #1 [..prelude_module "Text"]
+ (0 #0 "#Text" #Nil)))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "Your standard, run-of-the-mill string values.")]]
+ #Nil))]
+ #1)
+
+("lux def" Name
+ ("lux type check type"
+ (9 #1 [..prelude_module "Name"]
+ (2 #0 Text Text)))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "A name. It is used as part of Lux syntax to represent identifiers and tags.")]]
+ #Nil))]
+ #1)
+
+## (type: (Maybe a)
+## #None
+## (#Some a))
+("lux def type tagged" Maybe
+ (9 #1 [..prelude_module "Maybe"]
+ (7 #0 #Nil
+ (1 #0 ## "lux.None"
+ Any
+ ## "lux.Some"
+ (4 #0 1))))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "type-args"])]
+ [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "a")] #Nil))]]
+ (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "A potentially missing value.")]]
+ #Nil)))]
+ ["None" "Some"]
+ #1)
+
+## (type: #rec Type
+## (#Primitive Text (List Type))
+## (#Sum Type Type)
+## (#Product Type Type)
+## (#Function Type Type)
+## (#Parameter Nat)
+## (#Var Nat)
+## (#Ex Nat)
+## (#UnivQ (List Type) Type)
+## (#ExQ (List Type) Type)
+## (#Apply Type Type)
+## (#Named Name Type)
+## )
+("lux def type tagged" Type
+ (9 #1 [..prelude_module "Type"]
+ ({Type
+ ({Type_List
+ ({Type_Pair
+ (9 #0 Nothing
+ (7 #0 #Nil
+ (1 #0 ## "lux.Primitive"
+ (2 #0 Text Type_List)
+ (1 #0 ## "lux.Sum"
+ Type_Pair
+ (1 #0 ## "lux.Product"
+ Type_Pair
+ (1 #0 ## "lux.Function"
+ Type_Pair
+ (1 #0 ## "lux.Parameter"
+ Nat
+ (1 #0 ## "lux.Var"
+ Nat
+ (1 #0 ## "lux.Ex"
+ Nat
+ (1 #0 ## "lux.UnivQ"
+ (2 #0 Type_List Type)
+ (1 #0 ## "lux.ExQ"
+ (2 #0 Type_List Type)
+ (1 #0 ## "lux.Apply"
+ Type_Pair
+ ## "lux.Named"
+ (2 #0 Name Type)))))))))))))}
+ ("lux type check type" (2 #0 Type Type)))}
+ ("lux type check type" (9 #0 Type List)))}
+ ("lux type check type" (9 #0 (4 #0 1) (4 #0 0)))))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "This type represents the data-structures that are used to specify types themselves.")]]
+ (#Cons [[dummy_location (7 #0 [..prelude_module "type-rec?"])]
+ [dummy_location (0 #0 #1)]]
+ #Nil)))]
+ ["Primitive" "Sum" "Product" "Function" "Parameter" "Var" "Ex" "UnivQ" "ExQ" "Apply" "Named"]
+ #1)
+
+## (type: Location
+## {#module Text
+## #line Nat
+## #column Nat})
+("lux def type tagged" Location
+ (#Named [..prelude_module "Location"]
+ (#Product Text (#Product Nat Nat)))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "Locations are for specifying the location of Code nodes in Lux files during compilation.")]]
+ #Nil))]
+ ["module" "line" "column"]
+ #1)
+
+## (type: (Ann m v)
+## {#meta m
+## #datum v})
+("lux def type tagged" Ann
+ (#Named [..prelude_module "Ann"]
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#Product (#Parameter 3)
+ (#Parameter 1)))))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "doc"])]
+ [dummy_location (5 #0 "The type of things that can be annotated with meta-data of arbitrary types.")]]
+ (#Cons [[dummy_location (7 #0 [..prelude_module "type-args"])]
+ [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "m")] (#Cons [dummy_location (5 #0 "v")] #Nil)))]]
+ #Nil)))]
+ ["meta" "datum"]
+ #1)
+
+## (type: (Code' w)
+## (#Bit Bit)
+## (#Nat Nat)
+## (#Int Int)
+## (#Rev Rev)
+## (#Frac Frac)
+## (#Text Text)
+## (#Identifier Name)
+## (#Tag Name)
+## (#Form (List (w (Code' w))))
+## (#Tuple (List (w (Code' w))))
+## (#Record (List [(w (Code' w)) (w (Code' w))])))
+("lux def type tagged" Code'
+ (#Named [..prelude_module "Code'"]
+ ({Code
+ ({Code_List
+ (#UnivQ #Nil
+ (#Sum ## "lux.Bit"
+ Bit
+ (#Sum ## "lux.Nat"
+ Nat
+ (#Sum ## "lux.Int"
+ Int
+ (#Sum ## "lux.Rev"
+ Rev
+ (#Sum ## "lux.Frac"
+ Frac
+ (#Sum ## "lux.Text"
+ Text
+ (#Sum ## "lux.Identifier"
+ Name
+ (#Sum ## "lux.Tag"
+ Name
+ (#Sum ## "lux.Form"
+ Code_List
+ (#Sum ## "lux.Tuple"
+ Code_List
+ ## "lux.Record"
+ (#Apply (#Product Code Code) List)
+ ))))))))))
+ )}
+ ("lux type check type" (#Apply Code List)))}
+ ("lux type check type" (#Apply (#Apply (#Parameter 1)
+ (#Parameter 0))
+ (#Parameter 1)))))
+ [dummy_location
+ (9 #1 (#Cons [[dummy_location (7 #0 [..prelude_module "type-args"])]
+ [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "w")] #Nil))]]
+ #Nil))]
+ ["Bit" "Nat" "Int" "Rev" "Frac" "Text" "Identifier" "Tag" "Form" "Tuple" "Record"]
+ #1)
+
+## (type: Code
+## (Ann Location (Code' (Ann Location))))
+("lux def" Code
+ (#Named [..prelude_module "Code"]
+ ({w
+ (#Apply (#Apply w Code') w)}
+ ("lux type check type" (#Apply Location Ann))))
+ [dummy_location
+ (#Record (#Cons [[dummy_location (#Tag [..prelude_module "doc"])]
+ [dummy_location (#Text "The type of Code nodes for Lux syntax.")]]
+ #Nil))]
+ #1)
+
+("lux def" _ann
+ ("lux type check"
+ (#Function (#Apply (#Apply Location Ann)
+ Code')
+ Code)
+ ([_ data]
+ [dummy_location data]))
+ [dummy_location (#Record #Nil)]
+ #0)
+
+("lux def" bit$
+ ("lux type check" (#Function Bit Code)
+ ([_ value] (_ann (#Bit value))))
+ [dummy_location (#Record #Nil)]
+ #0)
+
+("lux def" nat$
+ ("lux type check" (#Function Nat Code)
+ ([_ value] (_ann (#Nat value))))
+ [dummy_location (#Record #Nil)]
+ #0)
+
+("lux def" int$
+ ("lux type check" (#Function Int Code)
+ ([_ value] (_ann (#Int value))))
+ [dummy_location (#Record #Nil)]
+ #0)
+
+("lux def" rev$
+ ("lux type check" (#Function Rev Code)
+ ([_ value] (_ann (#Rev value))))
+ [dummy_location (#Record #Nil)]
+ #0)
+
+("lux def" frac$
+ ("lux type check" (#Function Frac Code)
+ ([_ value] (_ann (#Frac value))))
+ [dummy_location (#Record #Nil)]
+ #0)
+
+("lux def" text$
+ ("lux type check" (#Function Text Code)
+ ([_ text] (_ann (#Text text))))
+ [dummy_location (#Record #Nil)]
+ #0)
+
+("lux def" identifier$
+ ("lux type check" (#Function Name Code)
+ ([_ name] (_ann (#Identifier name))))
+ [dummy_location (#Record #Nil)]
+ #0)
+
+("lux def" local_identifier$
+ ("lux type check" (#Function Text Code)
+ ([_ name] (_ann (#Identifier ["" name]))))
+ [dummy_location (#Record #Nil)]
+ #0)
+
+("lux def" tag$
+ ("lux type check" (#Function Name Code)
+ ([_ name] (_ann (#Tag name))))
+ [dummy_location (#Record #Nil)]
+ #0)
+
+("lux def" local_tag$
+ ("lux type check" (#Function Text Code)
+ ([_ name] (_ann (#Tag ["" name]))))
+ [dummy_location (#Record #Nil)]
+ #0)
+
+("lux def" form$
+ ("lux type check" (#Function (#Apply Code List) Code)
+ ([_ tokens] (_ann (#Form tokens))))
+ [dummy_location (#Record #Nil)]
+ #0)
+
+("lux def" tuple$
+ ("lux type check" (#Function (#Apply Code List) Code)
+ ([_ tokens] (_ann (#Tuple tokens))))
+ [dummy_location (#Record #Nil)]
+ #0)
+
+("lux def" record$
+ ("lux type check" (#Function (#Apply (#Product Code Code) List) Code)
+ ([_ tokens] (_ann (#Record tokens))))
+ [dummy_location (#Record #Nil)]
+ #0)
+
+## (type: Definition
+## [Bit Type Code Any])
+("lux def" Definition
+ ("lux type check type"
+ (#Named [..prelude_module "Definition"]
+ (#Product Bit (#Product Type (#Product Code Any)))))
+ (record$ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ "Represents all the data associated with a definition: its type, its annotations, and its value.")]
+ #Nil))
+ #1)
+
+## (type: Alias
+## Name)
+("lux def" Alias
+ ("lux type check type"
+ (#Named [..prelude_module "Alias"]
+ Name))
+ (record$ #Nil)
+ #1)
+
+## (type: Global
+## (#Alias Alias)
+## (#Definition Definition))
+("lux def type tagged" Global
+ (#Named [..prelude_module "Global"]
+ (#Sum Alias
+ Definition))
+ (record$ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ "Represents all the data associated with a global constant.")]
+ #Nil))
+ ["Alias" "Definition"]
+ #1)
+
+## (type: (Bindings k v)
+## {#counter Nat
+## #mappings (List [k v])})
+("lux def type tagged" Bindings
+ (#Named [..prelude_module "Bindings"]
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#Product ## "lux.counter"
+ Nat
+ ## "lux.mappings"
+ (#Apply (#Product (#Parameter 3)
+ (#Parameter 1))
+ List)))))
+ (record$ (#Cons [(tag$ [..prelude_module "type-args"])
+ (tuple$ (#Cons (text$ "k") (#Cons (text$ "v") #Nil)))]
+ #Nil))
+ ["counter" "mappings"]
+ #1)
+
+## (type: #export Ref
+## (#Local Nat)
+## (#Captured Nat))
+("lux def type tagged" Ref
+ (#Named [..prelude_module "Ref"]
+ (#Sum ## Local
+ Nat
+ ## Captured
+ Nat))
+ (record$ #Nil)
+ ["Local" "Captured"]
+ #1)
+
+## (type: Scope
+## {#name (List Text)
+## #inner Nat
+## #locals (Bindings Text [Type Nat])
+## #captured (Bindings Text [Type Ref])})
+("lux def type tagged" Scope
+ (#Named [..prelude_module "Scope"]
+ (#Product ## name
+ (#Apply Text List)
+ (#Product ## inner
+ Nat
+ (#Product ## locals
+ (#Apply (#Product Type Nat) (#Apply Text Bindings))
+ ## captured
+ (#Apply (#Product Type Ref) (#Apply Text Bindings))))))
+ (record$ #Nil)
+ ["name" "inner" "locals" "captured"]
+ #1)
+
+("lux def" Code_List
+ ("lux type check type"
+ (#Apply Code List))
+ (record$ #Nil)
+ #0)
+
+## (type: (Either l r)
+## (#Left l)
+## (#Right r))
+("lux def type tagged" Either
+ (#Named [..prelude_module "Either"]
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#Sum ## "lux.Left"
+ (#Parameter 3)
+ ## "lux.Right"
+ (#Parameter 1)))))
+ (record$ (#Cons [(tag$ [..prelude_module "type-args"])
+ (tuple$ (#Cons (text$ "l") (#Cons (text$ "r") #Nil)))]
+ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ "A choice between two values of different types.")]
+ #Nil)))
+ ["Left" "Right"]
+ #1)
+
+## (type: Source
+## [Location Nat Text])
+("lux def" Source
+ ("lux type check type"
+ (#Named [..prelude_module "Source"]
+ (#Product Location (#Product Nat Text))))
+ (record$ #Nil)
+ #1)
+
+## (type: Module_State
+## #Active
+## #Compiled
+## #Cached)
+("lux def type tagged" Module_State
+ (#Named [..prelude_module "Module_State"]
+ (#Sum
+ ## #Active
+ Any
+ (#Sum
+ ## #Compiled
+ Any
+ ## #Cached
+ Any)))
+ (record$ #Nil)
+ ["Active" "Compiled" "Cached"]
+ #1)
+
+## (type: Module
+## {#module_hash Nat
+## #module_aliases (List [Text Text])
+## #definitions (List [Text Global])
+## #imports (List Text)
+## #tags (List [Text [Nat (List Name) Bit Type]])
+## #types (List [Text [(List Name) Bit Type]])
+## #module_annotations (Maybe Code)
+## #module_state Module_State})
+("lux def type tagged" Module
+ (#Named [..prelude_module "Module"]
+ (#Product ## "lux.module_hash"
+ Nat
+ (#Product ## "lux.module_aliases"
+ (#Apply (#Product Text Text) List)
+ (#Product ## "lux.definitions"
+ (#Apply (#Product Text Global) List)
+ (#Product ## "lux.imports"
+ (#Apply Text List)
+ (#Product ## "lux.tags"
+ (#Apply (#Product Text
+ (#Product Nat
+ (#Product (#Apply Name List)
+ (#Product Bit
+ Type))))
+ List)
+ (#Product ## "lux.types"
+ (#Apply (#Product Text
+ (#Product (#Apply Name List)
+ (#Product Bit
+ Type)))
+ List)
+ (#Product ## "lux.module_annotations"
+ (#Apply Code Maybe)
+ Module_State))
+ ))))))
+ (record$ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ "All the information contained within a Lux module.")]
+ #Nil))
+ ["module_hash" "module_aliases" "definitions" "imports" "tags" "types" "module_annotations" "module_state"]
+ #1)
+
+## (type: Type_Context
+## {#ex_counter Nat
+## #var_counter Nat
+## #var_bindings (List [Nat (Maybe Type)])})
+("lux def type tagged" Type_Context
+ (#Named [..prelude_module "Type_Context"]
+ (#Product ## ex_counter
+ Nat
+ (#Product ## var_counter
+ Nat
+ ## var_bindings
+ (#Apply (#Product Nat (#Apply Type Maybe))
+ List))))
+ (record$ #Nil)
+ ["ex_counter" "var_counter" "var_bindings"]
+ #1)
+
+## (type: Mode
+## #Build
+## #Eval
+## #Interpreter)
+("lux def type tagged" Mode
+ (#Named [..prelude_module "Mode"]
+ (#Sum ## Build
+ Any
+ (#Sum ## Eval
+ Any
+ ## Interpreter
+ Any)))
+ (record$ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ "A sign that shows the conditions under which the compiler is running.")]
+ #Nil))
+ ["Build" "Eval" "Interpreter"]
+ #1)
+
+## (type: Info
+## {#target Text
+## #version Text
+## #mode Mode})
+("lux def type tagged" Info
+ (#Named [..prelude_module "Info"]
+ (#Product
+ ## target
+ Text
+ (#Product
+ ## version
+ Text
+ ## mode
+ Mode)))
+ (record$ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ "Information about the current version and type of compiler that is running.")]
+ #Nil))
+ ["target" "version" "mode"]
+ #1)
+
+## (type: Lux
+## {#info Info
+## #source Source
+## #location Location
+## #current_module (Maybe Text)
+## #modules (List [Text Module])
+## #scopes (List Scope)
+## #type_context Type_Context
+## #expected (Maybe Type)
+## #seed Nat
+## #scope_type_vars (List Nat)
+## #extensions Any
+## #host Any})
+("lux def type tagged" Lux
+ (#Named [..prelude_module "Lux"]
+ (#Product ## "lux.info"
+ Info
+ (#Product ## "lux.source"
+ Source
+ (#Product ## "lux.location"
+ Location
+ (#Product ## "lux.current_module"
+ (#Apply Text Maybe)
+ (#Product ## "lux.modules"
+ (#Apply (#Product Text Module) List)
+ (#Product ## "lux.scopes"
+ (#Apply Scope List)
+ (#Product ## "lux.type_context"
+ Type_Context
+ (#Product ## "lux.expected"
+ (#Apply Type Maybe)
+ (#Product ## "lux.seed"
+ Nat
+ (#Product ## scope_type_vars
+ (#Apply Nat List)
+ (#Product ## extensions
+ Any
+ ## "lux.host"
+ Any))))))))))))
+ (record$ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ ("lux text concat"
+ ("lux text concat" "Represents the state of the Lux compiler during a run." __paragraph)
+ ("lux text concat"
+ ("lux text concat" "It is provided to macros during their invocation, so they can access compiler data." __paragraph)
+ "Caveat emptor: Avoid fiddling with it, unless you know what you're doing.")))]
+ #Nil))
+ ["info" "source" "location" "current_module" "modules" "scopes" "type_context" "expected" "seed" "scope_type_vars" "extensions" "host"]
+ #1)
+
+## (type: (Meta a)
+## (-> Lux (Either Text [Lux a])))
+("lux def" Meta
+ ("lux type check type"
+ (#Named [..prelude_module "Meta"]
+ (#UnivQ #Nil
+ (#Function Lux
+ (#Apply (#Product Lux (#Parameter 1))
+ (#Apply Text Either))))))
+ (record$ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ ("lux text concat"
+ ("lux text concat" "Computations that can have access to the state of the compiler." __paragraph)
+ "These computations may fail, or modify the state of the compiler."))]
+ (#Cons [(tag$ [..prelude_module "type-args"])
+ (tuple$ (#Cons (text$ "a") #Nil))]
+ #Nil)))
+ #1)
+
+## (type: Macro'
+## (-> (List Code) (Meta (List Code))))
+("lux def" Macro'
+ ("lux type check type"
+ (#Named [..prelude_module "Macro'"]
+ (#Function Code_List (#Apply Code_List Meta))))
+ (record$ #Nil)
+ #1)
+
+## (type: Macro
+## (primitive "#Macro"))
+("lux def" Macro
+ ("lux type check type"
+ (#Named [..prelude_module "Macro"]
+ (#Primitive "#Macro" #Nil)))
+ (record$ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ "Functions that run at compile-time and allow you to transform and extend the language in powerful ways.")]
+ #Nil))
+ #1)
+
+## Base functions & macros
+("lux def" return
+ ("lux type check"
+ (#UnivQ #Nil
+ (#Function (#Parameter 1)
+ (#Function Lux
+ (#Apply (#Product Lux
+ (#Parameter 1))
+ (#Apply Text Either)))))
+ ([_ val]
+ ([_ state]
+ (#Right state val))))
+ (record$ #Nil)
+ #0)
+
+("lux def" fail
+ ("lux type check"
+ (#UnivQ #Nil
+ (#Function Text
+ (#Function Lux
+ (#Apply (#Product Lux
+ (#Parameter 1))
+ (#Apply Text Either)))))
+ ([_ msg]
+ ([_ state]
+ (#Left msg))))
+ (record$ #Nil)
+ #0)
+
+("lux def" let''
+ ("lux macro"
+ ([_ tokens]
+ ({(#Cons lhs (#Cons rhs (#Cons body #Nil)))
+ (return (#Cons (form$ (#Cons (record$ (#Cons [lhs body] #Nil)) (#Cons rhs #Nil)))
+ #Nil))
+
+ _
+ (fail "Wrong syntax for let''")}
+ tokens)))
+ (record$ #.Nil)
+ #0)
+
+("lux def" function''
+ ("lux macro"
+ ([_ tokens]
+ ({(#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil))
+ (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" ""]))
+ (#Cons arg #Nil))))
+ (#Cons ({#Nil
+ body
+
+ _
+ (_ann (#Form (#Cons (_ann (#Identifier [..prelude_module "function''"]))
+ (#Cons (_ann (#Tuple args'))
+ (#Cons body #Nil)))))}
+ args')
+ #Nil))))
+ #Nil))
+
+ (#Cons [_ (#Identifier ["" self])] (#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil)))
+ (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" self]))
+ (#Cons arg #Nil))))
+ (#Cons ({#Nil
+ body
+
+ _
+ (_ann (#Form (#Cons (_ann (#Identifier [..prelude_module "function''"]))
+ (#Cons (_ann (#Tuple args'))
+ (#Cons body #Nil)))))}
+ args')
+ #Nil))))
+ #Nil))
+
+ _
+ (fail "Wrong syntax for function''")}
+ tokens)))
+ (record$ #.Nil)
+ #0)
+
+("lux def" location_code
+ ("lux type check" Code
+ (tuple$ (#Cons (text$ "") (#Cons (nat$ 0) (#Cons (nat$ 0) #Nil)))))
+ (record$ #Nil)
+ #0)
+
+("lux def" meta_code
+ ("lux type check" (#Function Name (#Function Code Code))
+ ([_ tag]
+ ([_ value]
+ (tuple$ (#Cons location_code
+ (#Cons (form$ (#Cons (tag$ tag) (#Cons value #Nil)))
+ #Nil))))))
+ (record$ #Nil)
+ #0)
+
+("lux def" flag_meta
+ ("lux type check" (#Function Text Code)
+ ([_ tag]
+ (tuple$ (#Cons [(meta_code [..prelude_module "Tag"] (tuple$ (#Cons (text$ ..prelude_module) (#Cons (text$ tag) #Nil))))
+ (#Cons [(meta_code [..prelude_module "Bit"] (bit$ #1))
+ #Nil])]))))
+ (record$ #Nil)
+ #0)
+
+("lux def" doc_meta
+ ("lux type check" (#Function Text (#Product Code Code))
+ (function'' [doc] [(tag$ [..prelude_module "doc"]) (text$ doc)]))
+ (record$ #Nil)
+ #0)
+
+("lux def" as_def
+ ("lux type check" (#Function Code (#Function Code (#Function Code (#Function Bit Code))))
+ (function'' [name value annotations exported?]
+ (form$ (#Cons (text$ "lux def") (#Cons name (#Cons value (#Cons annotations (#Cons (bit$ exported?) #Nil))))))))
+ (record$ #Nil)
+ #0)
+
+("lux def" as_checked
+ ("lux type check" (#Function Code (#Function Code Code))
+ (function'' [type value]
+ (form$ (#Cons (text$ "lux type check") (#Cons type (#Cons value #Nil))))))
+ (record$ #Nil)
+ #0)
+
+("lux def" as_function
+ ("lux type check" (#Function Code (#Function (#Apply Code List) (#Function Code Code)))
+ (function'' [self inputs output]
+ (form$ (#Cons (identifier$ [..prelude_module "function''"])
+ (#Cons self
+ (#Cons (tuple$ inputs)
+ (#Cons output #Nil)))))))
+ (record$ #Nil)
+ #0)
+
+("lux def" as_macro
+ ("lux type check" (#Function Code Code)
+ (function'' [expression]
+ (form$ (#Cons (text$ "lux macro")
+ (#Cons expression
+ #Nil)))))
+ (record$ #Nil)
+ #0)
+
+("lux def" def:''
+ ("lux macro"
+ (function'' [tokens]
+ ({(#Cons [[_ (#Tag ["" "export"])]
+ (#Cons [[_ (#Form (#Cons [name args]))]
+ (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])])
+ (return (#Cons [(as_def name (as_checked type (as_function name args body))
+ (form$ (#Cons (identifier$ [..prelude_module "record$"])
+ (#Cons meta
+ #Nil)))
+ #1)
+ #Nil]))
+
+ (#Cons [[_ (#Tag ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])])
+ (return (#Cons [(as_def name (as_checked type body)
+ (form$ (#Cons (identifier$ [..prelude_module "record$"])
+ (#Cons meta
+ #Nil)))
+ #1)
+ #Nil]))
+
+ (#Cons [[_ (#Form (#Cons [name args]))]
+ (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])
+ (return (#Cons [(as_def name (as_checked type (as_function name args body))
+ (form$ (#Cons (identifier$ [..prelude_module "record$"])
+ (#Cons meta
+ #Nil)))
+ #0)
+ #Nil]))
+
+ (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])
+ (return (#Cons [(as_def name (as_checked type body)
+ (form$ (#Cons (identifier$ [..prelude_module "record$"])
+ (#Cons meta
+ #Nil)))
+ #0)
+ #Nil]))
+
+ _
+ (fail "Wrong syntax for def''")}
+ tokens)))
+ (record$ #.Nil)
+ #0)
+
+("lux def" macro:'
+ ("lux macro"
+ (function'' [tokens]
+ ({(#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil))
+ (return (#Cons (as_def name (as_macro (as_function name args body))
+ (form$ (#Cons (identifier$ [..prelude_module "record$"])
+ (#Cons (tag$ [..prelude_module "Nil"])
+ #Nil)))
+ #0)
+ #Nil))
+
+ (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil)))
+ (return (#Cons (as_def name (as_macro (as_function name args body))
+ (form$ (#Cons (identifier$ [..prelude_module "record$"])
+ (#Cons (tag$ [..prelude_module "Nil"])
+ #Nil)))
+ #1)
+ #Nil))
+
+ (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons meta_data (#Cons body #Nil))))
+ (return (#Cons (as_def name (as_macro (as_function name args body))
+ (form$ (#Cons (identifier$ [..prelude_module "record$"])
+ (#Cons meta_data
+ #Nil)))
+ #1)
+ #Nil))
+
+ _
+ (fail "Wrong syntax for macro:'")}
+ tokens)))
+ (record$ #.Nil)
+ #0)
+
+(macro:' #export (comment tokens)
+ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ ("lux text concat"
+ ("lux text concat" "## Throws away any code given to it." __paragraph)
+ ("lux text concat"
+ ("lux text concat" "## Great for commenting-out code, while retaining syntax high-lighting and formatting in your text editor." __paragraph)
+ "(comment +1 +2 +3 +4)")))]
+ #Nil)
+ (return #Nil))
+
+(macro:' ($' tokens)
+ ({(#Cons x #Nil)
+ (return tokens)
+
+ (#Cons x (#Cons y xs))
+ (return (#Cons (form$ (#Cons (identifier$ [..prelude_module "$'"])
+ (#Cons (form$ (#Cons (tag$ [..prelude_module "Apply"])
+ (#Cons y (#Cons x #Nil))))
+ xs)))
+ #Nil))
+
+ _
+ (fail "Wrong syntax for $'")}
+ tokens))
+
+(def:'' (list\map f xs)
+ #Nil
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#Function (#Function (#Parameter 3) (#Parameter 1))
+ (#Function ($' List (#Parameter 3))
+ ($' List (#Parameter 1))))))
+ ({#Nil
+ #Nil
+
+ (#Cons x xs')
+ (#Cons (f x) (list\map f xs'))}
+ xs))
+
+(def:'' RepEnv
+ #Nil
+ Type
+ ($' List (#Product Text Code)))
+
+(def:'' (make_env xs ys)
+ #Nil
+ (#Function ($' List Text) (#Function ($' List Code) RepEnv))
+ ({[(#Cons x xs') (#Cons y ys')]
+ (#Cons [x y] (make_env xs' ys'))
+
+ _
+ #Nil}
+ [xs ys]))
+
+(def:'' (text\= reference sample)
+ #Nil
+ (#Function Text (#Function Text Bit))
+ ("lux text =" reference sample))
+
+(def:'' (get_rep key env)
+ #Nil
+ (#Function Text (#Function RepEnv ($' Maybe Code)))
+ ({#Nil
+ #None
+
+ (#Cons [k v] env')
+ ({#1
+ (#Some v)
+
+ #0
+ (get_rep key env')}
+ (text\= k key))}
+ env))
+
+(def:'' (replace_syntax reps syntax)
+ #Nil
+ (#Function RepEnv (#Function Code Code))
+ ({[_ (#Identifier "" name)]
+ ({(#Some replacement)
+ replacement
+
+ #None
+ syntax}
+ (get_rep name reps))
+
+ [meta (#Form parts)]
+ [meta (#Form (list\map (replace_syntax reps) parts))]
+
+ [meta (#Tuple members)]
+ [meta (#Tuple (list\map (replace_syntax reps) members))]
+
+ [meta (#Record slots)]
+ [meta (#Record (list\map ("lux type check" (#Function (#Product Code Code) (#Product Code Code))
+ (function'' [slot]
+ ({[k v]
+ [(replace_syntax reps k) (replace_syntax reps v)]}
+ slot)))
+ slots))]
+
+ _
+ syntax}
+ syntax))
+
+(def:'' (n/* param subject)
+ (#.Cons (doc_meta "Nat(ural) multiplication.") #.Nil)
+ (#Function Nat (#Function Nat Nat))
+ ("lux type as" Nat
+ ("lux i64 *"
+ ("lux type as" Int param)
+ ("lux type as" Int subject))))
+
+(def:'' (update_parameters code)
+ #Nil
+ (#Function Code Code)
+ ({[_ (#Tuple members)]
+ (tuple$ (list\map update_parameters members))
+
+ [_ (#Record pairs)]
+ (record$ (list\map ("lux type check" (#Function (#Product Code Code) (#Product Code Code))
+ (function'' [pair]
+ (let'' [name val] pair
+ [name (update_parameters val)])))
+ pairs))
+
+ [_ (#Form (#Cons [_ (#Tag "library/lux" "Parameter")] (#Cons [_ (#Nat idx)] #Nil)))]
+ (form$ (#Cons (tag$ [..prelude_module "Parameter"]) (#Cons (nat$ ("lux i64 +" 2 idx)) #Nil)))
+
+ [_ (#Form members)]
+ (form$ (list\map update_parameters members))
+
+ _
+ code}
+ code))
+
+(def:'' (parse_quantified_args args next)
+ #Nil
+ ## (-> (List Code) (-> (List Text) (Meta (List Code))) (Meta (List Code)))
+ (#Function ($' List Code)
+ (#Function (#Function ($' List Text) (#Apply ($' List Code) Meta))
+ (#Apply ($' List Code) Meta)
+ ))
+ ({#Nil
+ (next #Nil)
+
+ (#Cons [_ (#Identifier "" arg_name)] args')
+ (parse_quantified_args args' (function'' [names] (next (#Cons arg_name names))))
+
+ _
+ (fail "Expected identifier.")}
+ args))
+
+(def:'' (make_parameter idx)
+ #Nil
+ (#Function Nat Code)
+ (form$ (#Cons (tag$ [..prelude_module "Parameter"]) (#Cons (nat$ idx) #Nil))))
+
+(def:'' (list\fold f init xs)
+ #Nil
+ ## (All [a b] (-> (-> b a a) a (List b) a))
+ (#UnivQ #Nil (#UnivQ #Nil (#Function (#Function (#Parameter 1)
+ (#Function (#Parameter 3)
+ (#Parameter 3)))
+ (#Function (#Parameter 3)
+ (#Function ($' List (#Parameter 1))
+ (#Parameter 3))))))
+ ({#Nil
+ init
+
+ (#Cons x xs')
+ (list\fold f (f x init) xs')}
+ xs))
+
+(def:'' (list\size list)
+ #Nil
+ (#UnivQ #Nil
+ (#Function ($' List (#Parameter 1)) Nat))
+ (list\fold (function'' [_ acc] ("lux i64 +" 1 acc)) 0 list))
+
+(macro:' #export (All tokens)
+ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ ("lux text concat"
+ ("lux text concat" "## Universal quantification." __paragraph)
+ ("lux text concat"
+ ("lux text concat" "(All [a] (-> a a))" __paragraph)
+ ("lux text concat"
+ ("lux text concat" "## A name can be provided, to specify a recursive type." __paragraph)
+ "(All List [a] (| Any [a (List a)]))"))))]
+ #Nil)
+ (let'' [self_name tokens] ({(#Cons [_ (#Identifier "" self_name)] tokens)
+ [self_name tokens]
+
+ _
+ ["" tokens]}
+ tokens)
+ ({(#Cons [_ (#Tuple args)] (#Cons body #Nil))
+ (parse_quantified_args args
+ (function'' [names]
+ (let'' body' (list\fold ("lux type check" (#Function Text (#Function Code Code))
+ (function'' [name' body']
+ (form$ (#Cons (tag$ [..prelude_module "UnivQ"])
+ (#Cons (tag$ [..prelude_module "Nil"])
+ (#Cons (replace_syntax (#Cons [name' (make_parameter 1)] #Nil)
+ (update_parameters body')) #Nil))))))
+ body
+ names)
+ (return (#Cons ({[#1 _]
+ body'
+
+ [_ #Nil]
+ body'
+
+ [#0 _]
+ (replace_syntax (#Cons [self_name (make_parameter (n/* 2 ("lux i64 -" 1 (list\size names))))]
+ #Nil)
+ body')}
+ [(text\= "" self_name) names])
+ #Nil)))))
+
+ _
+ (fail "Wrong syntax for All")}
+ tokens)))
+
+(macro:' #export (Ex tokens)
+ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ ("lux text concat"
+ ("lux text concat" "## Existential quantification." __paragraph)
+ ("lux text concat"
+ ("lux text concat" "(Ex [a] [(Codec Text a) a])" __paragraph)
+ ("lux text concat"
+ ("lux text concat" "## A name can be provided, to specify a recursive type." __paragraph)
+ "(Ex Self [a] [(Codec Text a) a (List (Self a))])"))))]
+ #Nil)
+ (let'' [self_name tokens] ({(#Cons [_ (#Identifier "" self_name)] tokens)
+ [self_name tokens]
+
+ _
+ ["" tokens]}
+ tokens)
+ ({(#Cons [_ (#Tuple args)] (#Cons body #Nil))
+ (parse_quantified_args args
+ (function'' [names]
+ (let'' body' (list\fold ("lux type check" (#Function Text (#Function Code Code))
+ (function'' [name' body']
+ (form$ (#Cons (tag$ [..prelude_module "ExQ"])
+ (#Cons (tag$ [..prelude_module "Nil"])
+ (#Cons (replace_syntax (#Cons [name' (make_parameter 1)] #Nil)
+ (update_parameters body')) #Nil))))))
+ body
+ names)
+ (return (#Cons ({[#1 _]
+ body'
+
+ [_ #Nil]
+ body'
+
+ [#0 _]
+ (replace_syntax (#Cons [self_name (make_parameter (n/* 2 ("lux i64 -" 1 (list\size names))))]
+ #Nil)
+ body')}
+ [(text\= "" self_name) names])
+ #Nil)))))
+
+ _
+ (fail "Wrong syntax for Ex")}
+ tokens)))
+
+(def:'' (list\reverse list)
+ #Nil
+ (All [a] (#Function ($' List a) ($' List a)))
+ (list\fold ("lux type check" (All [a] (#Function a (#Function ($' List a) ($' List a))))
+ (function'' [head tail] (#Cons head tail)))
+ #Nil
+ list))
+
+(macro:' #export (-> tokens)
+ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ ("lux text concat"
+ ("lux text concat" "## Function types:" __paragraph)
+ ("lux text concat"
+ ("lux text concat" "(-> Int Int Int)" __paragraph)
+ "## This is the type of a function that takes 2 Ints and returns an Int.")))]
+ #Nil)
+ ({(#Cons output inputs)
+ (return (#Cons (list\fold ("lux type check" (#Function Code (#Function Code Code))
+ (function'' [i o] (form$ (#Cons (tag$ [..prelude_module "Function"]) (#Cons i (#Cons o #Nil))))))
+ output
+ inputs)
+ #Nil))
+
+ _
+ (fail "Wrong syntax for ->")}
+ (list\reverse tokens)))
+
+(macro:' #export (list xs)
+ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ ("lux text concat"
+ ("lux text concat" "## List-construction macro." __paragraph)
+ "(list +1 +2 +3)"))]
+ #Nil)
+ (return (#Cons (list\fold (function'' [head tail]
+ (form$ (#Cons (tag$ [..prelude_module "Cons"])
+ (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])]))
+ #Nil))))
+ (tag$ [..prelude_module "Nil"])
+ (list\reverse xs))
+ #Nil)))
+
+(macro:' #export (list& xs)
+ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ ("lux text concat"
+ ("lux text concat" "## List-construction macro, with the last element being a tail-list." __paragraph)
+ ("lux text concat"
+ ("lux text concat" "## In other words, this macro prepends elements to another list." __paragraph)
+ "(list& +1 +2 +3 (list +4 +5 +6))")))]
+ #Nil)
+ ({(#Cons last init)
+ (return (list (list\fold (function'' [head tail]
+ (form$ (list (tag$ [..prelude_module "Cons"])
+ (tuple$ (list head tail)))))
+ last
+ init)))
+
+ _
+ (fail "Wrong syntax for list&")}
+ (list\reverse xs)))
+
+(macro:' #export (& tokens)
+ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ ("lux text concat"
+ ("lux text concat" "## Tuple types:" __paragraph)
+ ("lux text concat"
+ ("lux text concat" "(& Text Int Bit)" __paragraph)
+ ("lux text concat"
+ ("lux text concat" "## Any." __paragraph)
+ "(&)"))))]
+ #Nil)
+ ({#Nil
+ (return (list (identifier$ [..prelude_module "Any"])))
+
+ (#Cons last prevs)
+ (return (list (list\fold (function'' [left right] (form$ (list (tag$ [..prelude_module "Product"]) left right)))
+ last
+ prevs)))}
+ (list\reverse tokens)))
+
+(macro:' #export (| tokens)
+ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ ("lux text concat"
+ ("lux text concat" "## Variant types:" __paragraph)
+ ("lux text concat"
+ ("lux text concat" "(| Text Int Bit)" __paragraph)
+ ("lux text concat"
+ ("lux text concat" "## Nothing." __paragraph)
+ "(|)"))))]
+ #Nil)
+ ({#Nil
+ (return (list (identifier$ [..prelude_module "Nothing"])))
+
+ (#Cons last prevs)
+ (return (list (list\fold (function'' [left right] (form$ (list (tag$ [..prelude_module "Sum"]) left right)))
+ last
+ prevs)))}
+ (list\reverse tokens)))
+
+(macro:' (function' tokens)
+ (let'' [name tokens'] ({(#Cons [[_ (#Identifier ["" name])] tokens'])
+ [name tokens']
+
+ _
+ ["" tokens]}
+ tokens)
+ ({(#Cons [[_ (#Tuple args)] (#Cons [body #Nil])])
+ ({#Nil
+ (fail "function' requires a non-empty arguments tuple.")
+
+ (#Cons [harg targs])
+ (return (list (form$ (list (tuple$ (list (local_identifier$ name)
+ harg))
+ (list\fold (function'' [arg body']
+ (form$ (list (tuple$ (list (local_identifier$ "")
+ arg))
+ body')))
+ body
+ (list\reverse targs))))))}
+ args)
+
+ _
+ (fail "Wrong syntax for function'")}
+ tokens')))
+
+(macro:' (def:''' tokens)
+ ({(#Cons [[_ (#Tag ["" "export"])]
+ (#Cons [[_ (#Form (#Cons [name args]))]
+ (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])])
+ (return (list (form$ (list (text$ "lux def")
+ name
+ (form$ (list (text$ "lux type check")
+ type
+ (form$ (list (identifier$ [..prelude_module "function'"])
+ name
+ (tuple$ args)
+ body))))
+ (form$ (#Cons (identifier$ [..prelude_module "record$"])
+ (#Cons meta
+ #Nil)))
+ (bit$ #1)))))
+
+ (#Cons [[_ (#Tag ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])])
+ (return (list (form$ (list (text$ "lux def")
+ name
+ (form$ (list (text$ "lux type check")
+ type
+ body))
+ (form$ (#Cons (identifier$ [..prelude_module "record$"])
+ (#Cons meta
+ #Nil)))
+ (bit$ #1)))))
+
+ (#Cons [[_ (#Form (#Cons [name args]))]
+ (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])
+ (return (list (form$ (list (text$ "lux def")
+ name
+ (form$ (list (text$ "lux type check")
+ type
+ (form$ (list (identifier$ [..prelude_module "function'"])
+ name
+ (tuple$ args)
+ body))))
+ (form$ (#Cons (identifier$ [..prelude_module "record$"])
+ (#Cons meta
+ #Nil)))
+ (bit$ #0)))))
+
+ (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])
+ (return (list (form$ (list (text$ "lux def")
+ name
+ (form$ (list (text$ "lux type check") type body))
+ (form$ (#Cons (identifier$ [..prelude_module "record$"])
+ (#Cons meta
+ #Nil)))
+ (bit$ #0)))))
+
+ _
+ (fail "Wrong syntax for def:'''")}
+ tokens))
+
+(def:''' (as_pairs xs)
+ #Nil
+ (All [a] (-> ($' List a) ($' List (& a a))))
+ ({(#Cons x (#Cons y xs'))
+ (#Cons [x y] (as_pairs xs'))
+
+ _
+ #Nil}
+ xs))
+
+(macro:' (let' tokens)
+ ({(#Cons [[_ (#Tuple bindings)] (#Cons [body #Nil])])
+ (return (list (list\fold ("lux type check" (-> (& Code Code) Code
+ Code)
+ (function' [binding body]
+ ({[label value]
+ (form$ (list (record$ (list [label body])) value))}
+ binding)))
+ body
+ (list\reverse (as_pairs bindings)))))
+
+ _
+ (fail "Wrong syntax for let'")}
+ tokens))
+
+(def:''' (any? p xs)
+ #Nil
+ (All [a]
+ (-> (-> a Bit) ($' List a) Bit))
+ ({#Nil
+ #0
+
+ (#Cons x xs')
+ ({#1 #1
+ #0 (any? p xs')}
+ (p x))}
+ xs))
+
+(def:''' (wrap_meta content)
+ #Nil
+ (-> Code Code)
+ (tuple$ (list (tuple$ (list (text$ "") (nat$ 0) (nat$ 0)))
+ content)))
+
+(def:''' (untemplate_list tokens)
+ #Nil
+ (-> ($' List Code) Code)
+ ({#Nil
+ (_ann (#Tag [..prelude_module "Nil"]))
+
+ (#Cons [token tokens'])
+ (_ann (#Form (list (_ann (#Tag [..prelude_module "Cons"])) token (untemplate_list tokens'))))}
+ tokens))
+
+(def:''' (list\compose xs ys)
+ #Nil
+ (All [a] (-> ($' List a) ($' List a) ($' List a)))
+ ({(#Cons x xs')
+ (#Cons x (list\compose xs' ys))
+
+ #Nil
+ ys}
+ xs))
+
+(def:''' (_$_joiner op a1 a2)
+ #Nil
+ (-> Code Code Code Code)
+ ({[_ (#Form parts)]
+ (form$ (list\compose parts (list a1 a2)))
+
+ _
+ (form$ (list op a1 a2))}
+ op))
+
+(def:''' (function/flip func)
+ #Nil
+ (All [a b c]
+ (-> (-> a b c) (-> b a c)))
+ (function' [right left]
+ (func left right)))
+
+(macro:' #export (_$ tokens)
+ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ ("lux text concat"
+ ("lux text concat" "## Left-association for the application of binary functions over variadic arguments." ..\n)
+ ("lux text concat"
+ ("lux text concat" "(_$ text\compose ''Hello, '' name ''. How are you?'')" ..\n)
+ ("lux text concat"
+ ("lux text concat" "## =>" ..\n)
+ "(text\compose (text\compose ''Hello, '' name) ''. How are you?'')"))))]
+ #Nil)
+ ({(#Cons op tokens')
+ ({(#Cons first nexts)
+ (return (list (list\fold (function/flip (_$_joiner op)) first nexts)))
+
+ _
+ (fail "Wrong syntax for _$")}
+ tokens')
+
+ _
+ (fail "Wrong syntax for _$")}
+ tokens))
+
+(macro:' #export ($_ tokens)
+ (#Cons [(tag$ [..prelude_module "doc"])
+ (text$ ("lux text concat"
+ ("lux text concat" "## Right-association for the application of binary functions over variadic arguments." ..\n)
+ ("lux text concat"
+ ("lux text concat" "($_ text\compose ''Hello, '' name ''. How are you?'')" ..\n)
+ ("lux text concat"
+ ("lux text concat" "## =>" ..\n)
+ "(text\compose ''Hello, '' (text\compose name ''. How are you?''))"))))]
+ #Nil)
+ ({(#Cons op tokens')
+ ({(#Cons last prevs)
+ (return (list (list\fold (_$_joiner op) last prevs)))
+
+ _
+ (fail "Wrong syntax for $_")}
+ (list\reverse tokens'))
+
+ _
+ (fail "Wrong syntax for $_")}
+ tokens))
+
+## (interface: (Monad m)
+## (: (All [a] (-> a (m a)))
+## wrap)
+## (: (All [a b] (-> (-> a (m b)) (m a) (m b)))
+## bind))
+("lux def type tagged" Monad
+ (#Named [..prelude_module "Monad"]
+ (All [m]
+ (& (All [a] (-> a ($' m a)))
+ (All [a b] (-> (-> a ($' m b))
+ ($' m a)
+ ($' m b))))))
+ (record$ (list))
+ ["wrap" "bind"]
+ #0)
+
+(def:''' maybe_monad
+ #Nil
+ ($' Monad Maybe)
+ {#wrap
+ (function' [x] (#Some x))
+
+ #bind
+ (function' [f ma]
+ ({#None #None
+ (#Some a) (f a)}
+ ma))})
+
+(def:''' meta_monad
+ #Nil
+ ($' Monad Meta)
+ {#wrap
+ (function' [x]
+ (function' [state]
+ (#Right state x)))
+
+ #bind
+ (function' [f ma]
+ (function' [state]
+ ({(#Left msg)
+ (#Left msg)
+
+ (#Right [state' a])
+ (f a state')}
+ (ma state))))})
+
+(macro:' (do tokens)
+ ({(#Cons monad (#Cons [_ (#Tuple bindings)] (#Cons body #Nil)))
+ (let' [g!wrap (local_identifier$ "wrap")
+ g!bind (local_identifier$ " bind ")
+ body' (list\fold ("lux type check" (-> (& Code Code) Code Code)
+ (function' [binding body']
+ (let' [[var value] binding]
+ ({[_ (#Tag "" "let")]
+ (form$ (list (identifier$ [..prelude_module "let'"]) value body'))
+
+ _
+ (form$ (list g!bind
+ (form$ (list (tuple$ (list (local_identifier$ "") var)) body'))
+ value))}
+ var))))
+ body
+ (list\reverse (as_pairs bindings)))]
+ (return (list (form$ (list (record$ (list [(record$ (list [(tag$ [..prelude_module "wrap"]) g!wrap] [(tag$ [..prelude_module "bind"]) g!bind]))
+ body']))
+ monad)))))
+
+ _
+ (fail "Wrong syntax for do")}
+ tokens))
+
+(def:''' (monad\map 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]
+ ({#Nil
+ (wrap #Nil)
+
+ (#Cons x xs')
+ (do m
+ [y (f x)
+ ys (monad\map m f xs')]
+ (wrap (#Cons y ys)))}
+ xs)))
+
+(def:''' (monad\fold m f y xs)
+ #Nil
+ ## (All [m a b]
+ ## (-> (Monad m) (-> a b (m b)) b (List a) (m b)))
+ (All [m a b]
+ (-> ($' Monad m)
+ (-> a b ($' m b))
+ b
+ ($' List a)
+ ($' m b)))
+ (let' [{#wrap wrap #bind _} m]
+ ({#Nil
+ (wrap y)
+
+ (#Cons x xs')
+ (do m
+ [y' (f x y)]
+ (monad\fold m f y' xs'))}
+ xs)))
+
+(macro:' #export (if tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "Picks which expression to evaluate based on a bit test value." __paragraph
+ "(if #1 ''Oh, yeah!'' ''Aw hell naw!'')" __paragraph
+ "=> ''Oh, yeah!''"))])
+ ({(#Cons test (#Cons then (#Cons else #Nil)))
+ (return (list (form$ (list (record$ (list [(bit$ #1) then]
+ [(bit$ #0) else]))
+ test))))
+
+ _
+ (fail "Wrong syntax for if")}
+ tokens))
+
+(def:''' (get k plist)
+ #Nil
+ (All [a]
+ (-> Text ($' List (& Text a)) ($' Maybe a)))
+ ({(#Cons [[k' v] plist'])
+ (if (text\= k k')
+ (#Some v)
+ (get k plist'))
+
+ #Nil
+ #None}
+ plist))
+
+(def:''' (put k v dict)
+ #Nil
+ (All [a]
+ (-> Text a ($' List (& Text a)) ($' List (& Text a))))
+ ({#Nil
+ (list [k v])
+
+ (#Cons [[k' v'] dict'])
+ (if (text\= k k')
+ (#Cons [[k' v] dict'])
+ (#Cons [[k' v'] (put k v dict')]))}
+ dict))
+
+(def:''' (text\compose x y)
+ #Nil
+ (-> Text Text Text)
+ ("lux text concat" x y))
+
+(def:''' (name\encode full_name)
+ #Nil
+ (-> Name Text)
+ (let' [[module name] full_name]
+ ({"" name
+ _ ($_ text\compose module "." name)}
+ module)))
+
+(def:''' (get_meta tag def_meta)
+ #Nil
+ (-> Name Code ($' Maybe Code))
+ (let' [[prefix name] tag]
+ ({[_ (#Record def_meta)]
+ ({(#Cons [key value] def_meta')
+ ({[_ (#Tag [prefix' name'])]
+ ({[#1 #1]
+ (#Some value)
+
+ _
+ (get_meta tag (record$ def_meta'))}
+ [(text\= prefix prefix')
+ (text\= name name')])
+
+ _
+ (get_meta tag (record$ def_meta'))}
+ key)
+
+ #Nil
+ #None}
+ def_meta)
+
+ _
+ #None}
+ def_meta)))
+
+(def:''' (resolve_global_identifier full_name state)
+ #Nil
+ (-> Name ($' Meta Name))
+ (let' [[module name] full_name
+ {#info info #source source #current_module _ #modules modules
+ #scopes scopes #type_context types #host host
+ #seed seed #expected expected #location location #extensions extensions
+ #scope_type_vars scope_type_vars} state]
+ ({(#Some {#module_hash _ #module_aliases _ #definitions definitions #imports _ #tags tags #types types #module_annotations _ #module_state _})
+ ({(#Some constant)
+ ({(#Left real_name)
+ (#Right [state real_name])
+
+ (#Right [exported? def_type def_meta def_value])
+ (#Right [state full_name])}
+ constant)
+
+ #None
+ (#Left ($_ text\compose "Unknown definition: " (name\encode full_name)))}
+ (get name definitions))
+
+ #None
+ (#Left ($_ text\compose "Unknown module: " module " @ " (name\encode full_name)))}
+ (get module modules))))
+
+(def:''' (as_code_list expression)
+ #Nil
+ (-> Code Code)
+ (let' [type (form$ (list (tag$ [..prelude_module "Apply"])
+ (identifier$ [..prelude_module "Code"])
+ (identifier$ [..prelude_module "List"])))]
+ (form$ (list (text$ "lux type check") type expression))))
+
+(def:''' (splice replace? untemplate elems)
+ #Nil
+ (-> Bit (-> Code ($' Meta Code)) ($' List Code) ($' Meta Code))
+ ({#1
+ ({#Nil
+ (return (tag$ [..prelude_module "Nil"]))
+
+ (#Cons lastI inits)
+ (do meta_monad
+ [lastO ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))]
+ (wrap (as_code_list spliced))
+
+ _
+ (do meta_monad
+ [lastO (untemplate lastI)]
+ (wrap (as_code_list (form$ (list (tag$ [..prelude_module "Cons"])
+ (tuple$ (list lastO (tag$ [..prelude_module "Nil"]))))))))}
+ lastI)]
+ (monad\fold meta_monad
+ (function' [leftI rightO]
+ ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))]
+ (let' [g!in-module (form$ (list (text$ "lux in-module")
+ (text$ ..prelude_module)
+ (identifier$ [..prelude_module "list\compose"])))]
+ (wrap (form$ (list g!in-module (as_code_list spliced) rightO))))
+
+ _
+ (do meta_monad
+ [leftO (untemplate leftI)]
+ (wrap (form$ (list (tag$ [..prelude_module "Cons"]) (tuple$ (list leftO rightO))))))}
+ leftI))
+ lastO
+ inits))}
+ (list\reverse elems))
+ #0
+ (do meta_monad
+ [=elems (monad\map meta_monad untemplate elems)]
+ (wrap (untemplate_list =elems)))}
+ replace?))
+
+(def:''' (untemplate_text value)
+ #Nil
+ (-> Text Code)
+ (wrap_meta (form$ (list (tag$ [..prelude_module "Text"]) (text$ value)))))
+
+(def:''' (untemplate replace? subst token)
+ #Nil
+ (-> Bit Text Code ($' Meta Code))
+ ({[_ [_ (#Bit value)]]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Bit"]) (bit$ value)))))
+
+ [_ [_ (#Nat value)]]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Nat"]) (nat$ value)))))
+
+ [_ [_ (#Int value)]]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Int"]) (int$ value)))))
+
+ [_ [_ (#Rev value)]]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Rev"]) (rev$ value)))))
+
+ [_ [_ (#Frac value)]]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Frac"]) (frac$ value)))))
+
+ [_ [_ (#Text value)]]
+ (return (untemplate_text value))
+
+ [#0 [_ (#Tag [module name])]]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Tag"]) (tuple$ (list (text$ module) (text$ name)))))))
+
+ [#1 [_ (#Tag [module name])]]
+ (let' [module' ({""
+ subst
+
+ _
+ module}
+ module)]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Tag"]) (tuple$ (list (text$ module') (text$ name))))))))
+
+ [#1 [_ (#Identifier [module name])]]
+ (do meta_monad
+ [real_name ({""
+ (if (text\= "" subst)
+ (wrap [module name])
+ (resolve_global_identifier [subst name]))
+
+ _
+ (wrap [module name])}
+ module)
+ #let [[module name] real_name]]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Identifier"]) (tuple$ (list (text$ module) (text$ name))))))))
+
+ [#0 [_ (#Identifier [module name])]]
+ (return (wrap_meta (form$ (list (tag$ [..prelude_module "Identifier"]) (tuple$ (list (text$ module) (text$ name)))))))
+
+ [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~"])] (#Cons [unquoted #Nil])]))]]
+ (return (form$ (list (text$ "lux type check")
+ (identifier$ [..prelude_module "Code"])
+ unquoted)))
+
+ [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~!"])] (#Cons [dependent #Nil])]))]]
+ (do meta_monad
+ [independent (untemplate replace? subst dependent)]
+ (wrap (wrap_meta (form$ (list (tag$ [..prelude_module "Form"])
+ (untemplate_list (list (untemplate_text "lux in-module")
+ (untemplate_text subst)
+ independent)))))))
+
+ [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~'"])] (#Cons [keep_quoted #Nil])]))]]
+ (untemplate #0 subst keep_quoted)
+
+ [_ [meta (#Form elems)]]
+ (do meta_monad
+ [output (splice replace? (untemplate replace? subst) elems)
+ #let [[_ output'] (wrap_meta (form$ (list (tag$ [..prelude_module "Form"]) output)))]]
+ (wrap [meta output']))
+
+ [_ [meta (#Tuple elems)]]
+ (do meta_monad
+ [output (splice replace? (untemplate replace? subst) elems)
+ #let [[_ output'] (wrap_meta (form$ (list (tag$ [..prelude_module "Tuple"]) output)))]]
+ (wrap [meta output']))
+
+ [_ [_ (#Record fields)]]
+ (do meta_monad
+ [=fields (monad\map meta_monad
+ ("lux type check" (-> (& Code Code) ($' Meta Code))
+ (function' [kv]
+ (let' [[k v] kv]
+ (do meta_monad
+ [=k (untemplate replace? subst k)
+ =v (untemplate replace? subst v)]
+ (wrap (tuple$ (list =k =v)))))))
+ fields)]
+ (wrap (wrap_meta (form$ (list (tag$ [..prelude_module "Record"]) (untemplate_list =fields))))))}
+ [replace? token]))
+
+(macro:' #export (primitive tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Macro to treat define new primitive types." __paragraph
+ "(primitive ''java.lang.Object'')" __paragraph
+ "(primitive ''java.util.List'' [(primitive ''java.lang.Long'')])"))])
+ ({(#Cons [_ (#Text class_name)] #Nil)
+ (return (list (form$ (list (tag$ [..prelude_module "Primitive"]) (text$ class_name) (tag$ [..prelude_module "Nil"])))))
+
+ (#Cons [_ (#Text class_name)] (#Cons [_ (#Tuple params)] #Nil))
+ (return (list (form$ (list (tag$ [..prelude_module "Primitive"]) (text$ class_name) (untemplate_list params)))))
+
+ _
+ (fail "Wrong syntax for primitive")}
+ tokens))
+
+(def:'' (current_module_name state)
+ #Nil
+ ($' Meta Text)
+ ({{#info info #source source #current_module current_module #modules modules
+ #scopes scopes #type_context types #host host
+ #seed seed #expected expected #location location #extensions extensions
+ #scope_type_vars scope_type_vars}
+ ({(#Some module_name)
+ (#Right [state module_name])
+
+ _
+ (#Left "Cannot get the module name without a module!")}
+ current_module)}
+ state))
+
+(macro:' #export (` tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Hygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms." __paragraph
+ "## 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." __paragraph
+ "(` (def: (~ name) (function ((~' _) (~+ args)) (~ body))))"))])
+ ({(#Cons template #Nil)
+ (do meta_monad
+ [current_module current_module_name
+ =template (untemplate #1 current_module template)]
+ (wrap (list (form$ (list (text$ "lux type check")
+ (identifier$ [..prelude_module "Code"])
+ =template)))))
+
+ _
+ (fail "Wrong syntax for `")}
+ tokens))
+
+(macro:' #export (`' tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Unhygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms." __paragraph
+ "(`' (def: (~ name) (function (_ (~+ args)) (~ body))))"))])
+ ({(#Cons template #Nil)
+ (do meta_monad
+ [=template (untemplate #1 "" template)]
+ (wrap (list (form$ (list (text$ "lux type check") (identifier$ [..prelude_module "Code"]) =template)))))
+
+ _
+ (fail "Wrong syntax for `")}
+ tokens))
+
+(macro:' #export (' tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Quotation as a macro." __paragraph
+ "(' YOLO)"))])
+ ({(#Cons template #Nil)
+ (do meta_monad
+ [=template (untemplate #0 "" template)]
+ (wrap (list (form$ (list (text$ "lux type check") (identifier$ [..prelude_module "Code"]) =template)))))
+
+ _
+ (fail "Wrong syntax for '")}
+ tokens))
+
+(macro:' #export (|> tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Piping macro." __paragraph
+ "(|> elems (list\map int\encode) (interpose '' '') (fold text\compose ''''))" __paragraph
+ "## =>" __paragraph
+ "(fold text\compose '''' (interpose '' '' (list\map int\encode elems)))"))])
+ ({(#Cons [init apps])
+ (return (list (list\fold ("lux type check" (-> Code Code Code)
+ (function' [app acc]
+ ({[_ (#Tuple parts)]
+ (tuple$ (list\compose parts (list acc)))
+
+ [_ (#Form parts)]
+ (form$ (list\compose parts (list acc)))
+
+ _
+ (` ((~ app) (~ acc)))}
+ app)))
+ init
+ apps)))
+
+ _
+ (fail "Wrong syntax for |>")}
+ tokens))
+
+(macro:' #export (<| tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Reverse piping macro." __paragraph
+ "(<| (fold text\compose '''') (interpose '' '') (list\map int\encode) elems)" __paragraph
+ "## =>" __paragraph
+ "(fold text\compose '''' (interpose '' '' (list\map int\encode elems)))"))])
+ ({(#Cons [init apps])
+ (return (list (list\fold ("lux type check" (-> Code Code Code)
+ (function' [app acc]
+ ({[_ (#Tuple parts)]
+ (tuple$ (list\compose parts (list acc)))
+
+ [_ (#Form parts)]
+ (form$ (list\compose parts (list acc)))
+
+ _
+ (` ((~ app) (~ acc)))}
+ app)))
+ init
+ apps)))
+
+ _
+ (fail "Wrong syntax for <|")}
+ (list\reverse tokens)))
+
+(def:''' (compose f g)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ "Function composition.")])
+ (All [a b c]
+ (-> (-> b c) (-> a b) (-> a c)))
+ (function' [x] (f (g x))))
+
+(def:''' (get_name x)
+ #Nil
+ (-> Code ($' Maybe Name))
+ ({[_ (#Identifier sname)]
+ (#Some sname)
+
+ _
+ #None}
+ x))
+
+(def:''' (get_tag x)
+ #Nil
+ (-> Code ($' Maybe Name))
+ ({[_ (#Tag sname)]
+ (#Some sname)
+
+ _
+ #None}
+ x))
+
+(def:''' (get_short x)
+ #Nil
+ (-> Code ($' Maybe Text))
+ ({[_ (#Identifier "" sname)]
+ (#Some sname)
+
+ _
+ #None}
+ x))
+
+(def:''' (tuple->list tuple)
+ #Nil
+ (-> Code ($' Maybe ($' List Code)))
+ ({[_ (#Tuple members)]
+ (#Some members)
+
+ _
+ #None}
+ tuple))
+
+(def:''' (apply_template env template)
+ #Nil
+ (-> RepEnv Code Code)
+ ({[_ (#Identifier "" sname)]
+ ({(#Some subst)
+ subst
+
+ _
+ template}
+ (get_rep sname env))
+
+ [meta (#Tuple elems)]
+ [meta (#Tuple (list\map (apply_template env) elems))]
+
+ [meta (#Form elems)]
+ [meta (#Form (list\map (apply_template env) elems))]
+
+ [meta (#Record members)]
+ [meta (#Record (list\map ("lux type check" (-> (& Code Code) (& Code Code))
+ (function' [kv]
+ (let' [[slot value] kv]
+ [(apply_template env slot) (apply_template env value)])))
+ members))]
+
+ _
+ template}
+ template))
+
+(def:''' (every? p xs)
+ #Nil
+ (All [a]
+ (-> (-> a Bit) ($' List a) Bit))
+ (list\fold (function' [_2 _1] (if _1 (p _2) #0)) #1 xs))
+
+(def:''' (high_bits value)
+ (list)
+ (-> ($' I64 Any) I64)
+ ("lux i64 right-shift" 32 value))
+
+(def:''' low_mask
+ (list)
+ I64
+ (|> 1 ("lux i64 left-shift" 32) ("lux i64 -" 1)))
+
+(def:''' (low_bits value)
+ (list)
+ (-> ($' I64 Any) I64)
+ ("lux i64 and" low_mask value))
+
+(def:''' (n/< reference sample)
+ (list)
+ (-> Nat Nat Bit)
+ (let' [referenceH (high_bits reference)
+ sampleH (high_bits sample)]
+ (if ("lux i64 <" referenceH sampleH)
+ #1
+ (if ("lux i64 =" referenceH sampleH)
+ ("lux i64 <"
+ (low_bits reference)
+ (low_bits sample))
+ #0))))
+
+(def:''' (n/<= reference sample)
+ (list)
+ (-> Nat Nat Bit)
+ (if (n/< reference sample)
+ #1
+ ("lux i64 =" reference sample)))
+
+(def:''' (list\join xs)
+ #Nil
+ (All [a]
+ (-> ($' List ($' List a)) ($' List a)))
+ (list\fold list\compose #Nil (list\reverse xs)))
+
+(macro:' #export (template tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary." __paragraph
+ "(template [<name> <diff>]" ..\n
+ " " "[(def: #export <name> (-> Int Int) (+ <diff>))]" __paragraph
+ " " "[inc +1]" ..\n
+ " " "[dec -1]"))])
+ ({(#Cons [[_ (#Tuple bindings)] (#Cons [[_ (#Tuple templates)] data])])
+ ({[(#Some bindings') (#Some data')]
+ (let' [apply ("lux type check" (-> RepEnv ($' List Code))
+ (function' [env] (list\map (apply_template env) templates)))
+ num_bindings (list\size bindings')]
+ (if (every? (function' [size] ("lux i64 =" num_bindings size))
+ (list\map list\size data'))
+ (|> data'
+ (list\map (compose apply (make_env bindings')))
+ list\join
+ return)
+ (fail "Irregular arguments tuples for template.")))
+
+ _
+ (fail "Wrong syntax for template")}
+ [(monad\map maybe_monad get_short bindings)
+ (monad\map maybe_monad tuple->list data)])
+
+ _
+ (fail "Wrong syntax for template")}
+ tokens))
+
+(def:''' (n// param subject)
+ (list)
+ (-> Nat Nat Nat)
+ (if ("lux i64 <" +0 ("lux type as" Int param))
+ (if (n/< param subject)
+ 0
+ 1)
+ (let' [quotient (|> subject
+ ("lux i64 right-shift" 1)
+ ("lux i64 /" ("lux type as" Int param))
+ ("lux i64 left-shift" 1))
+ flat ("lux i64 *"
+ ("lux type as" Int param)
+ ("lux type as" Int quotient))
+ remainder ("lux i64 -" flat subject)]
+ (if (n/< param remainder)
+ quotient
+ ("lux i64 +" 1 quotient)))))
+
+(def:''' (n/% param subject)
+ (list)
+ (-> Nat Nat Nat)
+ (let' [flat ("lux i64 *"
+ ("lux type as" Int param)
+ ("lux type as" Int (n// param subject)))]
+ ("lux i64 -" flat subject)))
+
+(def:''' (n/min left right)
+ (list)
+ (-> Nat Nat Nat)
+ (if (n/< right left)
+ left
+ right))
+
+(def:''' (bit\encode x)
+ #Nil
+ (-> Bit Text)
+ (if x "#1" "#0"))
+
+(def:''' (digit::format digit)
+ #Nil
+ (-> Nat Text)
+ ({0 "0"
+ 1 "1" 2 "2" 3 "3"
+ 4 "4" 5 "5" 6 "6"
+ 7 "7" 8 "8" 9 "9"
+ _ ("lux io error" "@digit::format Undefined behavior.")}
+ digit))
+
+(def:''' (nat\encode value)
+ #Nil
+ (-> Nat Text)
+ ({0
+ "0"
+
+ _
+ (let' [loop ("lux type check" (-> Nat Text Text)
+ (function' recur [input output]
+ (if ("lux i64 =" 0 input)
+ output
+ (recur (n// 10 input)
+ (text\compose (|> input (n/% 10) digit::format)
+ output)))))]
+ (loop value ""))}
+ value))
+
+(def:''' (int\abs value)
+ #Nil
+ (-> Int Int)
+ (if ("lux i64 <" +0 value)
+ ("lux i64 *" -1 value)
+ value))
+
+(def:''' (int\encode value)
+ #Nil
+ (-> Int Text)
+ (if ("lux i64 =" +0 value)
+ "+0"
+ (let' [sign (if ("lux i64 <" value +0)
+ "+"
+ "-")]
+ (("lux type check" (-> Int Text Text)
+ (function' recur [input output]
+ (if ("lux i64 =" +0 input)
+ (text\compose sign output)
+ (recur ("lux i64 /" +10 input)
+ (text\compose (|> input ("lux i64 %" +10) ("lux type as" Nat) digit::format)
+ output)))))
+ (|> value ("lux i64 /" +10) int\abs)
+ (|> value ("lux i64 %" +10) int\abs ("lux type as" Nat) digit::format)))))
+
+(def:''' (frac\encode x)
+ #Nil
+ (-> Frac Text)
+ ("lux f64 encode" x))
+
+(def:''' (multiple? div n)
+ #Nil
+ (-> Nat Nat Bit)
+ (|> n (n/% div) ("lux i64 =" 0)))
+
+(def:''' #export (not x)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Bit negation." __paragraph
+ "(not #1) => #0" __paragraph
+ "(not #0) => #1"))])
+ (-> Bit Bit)
+ (if x #0 #1))
+
+(def:''' (macro_type? type)
+ (list)
+ (-> Type Bit)
+ ({(#Named ["library/lux" "Macro"] (#Primitive "#Macro" #Nil))
+ #1
+
+ _
+ #0}
+ type))
+
+(def:''' (find_macro' modules current_module module name)
+ #Nil
+ (-> ($' List (& Text Module))
+ Text Text Text
+ ($' Maybe Macro))
+ (do maybe_monad
+ [$module (get module modules)
+ gdef (let' [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags #types types #module_annotations _ #module_state _} ("lux type check" Module $module)]
+ (get name bindings))]
+ ({(#Left [r_module r_name])
+ (find_macro' modules current_module r_module r_name)
+
+ (#Right [exported? def_type def_meta def_value])
+ (if (macro_type? def_type)
+ (if exported?
+ (#Some ("lux type as" Macro def_value))
+ (if (text\= module current_module)
+ (#Some ("lux type as" Macro def_value))
+ #None))
+ #None)}
+ ("lux type check" Global gdef))))
+
+(def:''' (normalize name)
+ #Nil
+ (-> Name ($' Meta Name))
+ ({["" name]
+ (do meta_monad
+ [module_name current_module_name]
+ (wrap [module_name name]))
+
+ _
+ (return name)}
+ name))
+
+(def:''' (find_macro full_name)
+ #Nil
+ (-> Name ($' Meta ($' Maybe Macro)))
+ (do meta_monad
+ [current_module current_module_name]
+ (let' [[module name] full_name]
+ (function' [state]
+ ({{#info info #source source #current_module _ #modules modules
+ #scopes scopes #type_context types #host host
+ #seed seed #expected expected
+ #location location #extensions extensions
+ #scope_type_vars scope_type_vars}
+ (#Right state (find_macro' modules current_module module name))}
+ state)))))
+
+(def:''' (macro? name)
+ #Nil
+ (-> Name ($' Meta Bit))
+ (do meta_monad
+ [name (normalize name)
+ output (find_macro name)]
+ (wrap ({(#Some _) #1
+ #None #0}
+ output))))
+
+(def:''' (interpose sep xs)
+ #Nil
+ (All [a]
+ (-> a ($' List a) ($' List a)))
+ ({#Nil
+ xs
+
+ (#Cons [x #Nil])
+ xs
+
+ (#Cons [x xs'])
+ (list& x sep (interpose sep xs'))}
+ xs))
+
+(def:''' (macro_expand_once token)
+ #Nil
+ (-> Code ($' Meta ($' List Code)))
+ ({[_ (#Form (#Cons [_ (#Identifier macro_name)] args))]
+ (do meta_monad
+ [macro_name' (normalize macro_name)
+ ?macro (find_macro macro_name')]
+ ({(#Some macro)
+ (("lux type as" Macro' macro) args)
+
+ #None
+ (return (list token))}
+ ?macro))
+
+ _
+ (return (list token))}
+ token))
+
+(def:''' (macro_expand token)
+ #Nil
+ (-> Code ($' Meta ($' List Code)))
+ ({[_ (#Form (#Cons [_ (#Identifier macro_name)] args))]
+ (do meta_monad
+ [macro_name' (normalize macro_name)
+ ?macro (find_macro macro_name')]
+ ({(#Some macro)
+ (do meta_monad
+ [expansion (("lux type as" Macro' macro) args)
+ expansion' (monad\map meta_monad macro_expand expansion)]
+ (wrap (list\join expansion')))
+
+ #None
+ (return (list token))}
+ ?macro))
+
+ _
+ (return (list token))}
+ token))
+
+(def:''' (macro_expand_all syntax)
+ #Nil
+ (-> Code ($' Meta ($' List Code)))
+ ({[_ (#Form (#Cons [_ (#Identifier macro_name)] args))]
+ (do meta_monad
+ [macro_name' (normalize macro_name)
+ ?macro (find_macro macro_name')]
+ ({(#Some macro)
+ (do meta_monad
+ [expansion (("lux type as" Macro' macro) args)
+ expansion' (monad\map meta_monad macro_expand_all expansion)]
+ (wrap (list\join expansion')))
+
+ #None
+ (do meta_monad
+ [args' (monad\map meta_monad macro_expand_all args)]
+ (wrap (list (form$ (#Cons (identifier$ macro_name) (list\join args'))))))}
+ ?macro))
+
+ [_ (#Form members)]
+ (do meta_monad
+ [members' (monad\map meta_monad macro_expand_all members)]
+ (wrap (list (form$ (list\join members')))))
+
+ [_ (#Tuple members)]
+ (do meta_monad
+ [members' (monad\map meta_monad macro_expand_all members)]
+ (wrap (list (tuple$ (list\join members')))))
+
+ [_ (#Record pairs)]
+ (do meta_monad
+ [pairs' (monad\map meta_monad
+ (function' [kv]
+ (let' [[key val] kv]
+ (do meta_monad
+ [val' (macro_expand_all val)]
+ ({(#Cons val'' #Nil)
+ (return [key val''])
+
+ _
+ (fail "The value-part of a KV-pair in a record must macro-expand to a single Code.")}
+ val'))))
+ pairs)]
+ (wrap (list (record$ pairs'))))
+
+ _
+ (return (list syntax))}
+ syntax))
+
+(def:''' (walk_type type)
+ #Nil
+ (-> Code Code)
+ ({[_ (#Form (#Cons [_ (#Tag tag)] parts))]
+ (form$ (#Cons [(tag$ tag) (list\map walk_type parts)]))
+
+ [_ (#Tuple members)]
+ (` (& (~+ (list\map walk_type members))))
+
+ [_ (#Form (#Cons [_ (#Text "lux in-module")]
+ (#Cons [_ (#Text module)]
+ (#Cons type'
+ #Nil))))]
+ (` ("lux in-module" (~ (text$ module)) (~ (walk_type type'))))
+
+ [_ (#Form (#Cons [_ (#Identifier ["" ":~"])] (#Cons expression #Nil)))]
+ expression
+
+ [_ (#Form (#Cons type_fn args))]
+ (list\fold ("lux type check" (-> Code Code Code)
+ (function' [arg type_fn] (` (#.Apply (~ arg) (~ type_fn)))))
+ (walk_type type_fn)
+ (list\map walk_type args))
+
+ _
+ type}
+ type))
+
+(macro:' #export (type tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Takes a type expression and returns it's representation as data-structure." __paragraph
+ "(type (All [a] (Maybe (List a))))"))])
+ ({(#Cons type #Nil)
+ (do meta_monad
+ [type+ (macro_expand_all type)]
+ ({(#Cons type' #Nil)
+ (wrap (list (walk_type type')))
+
+ _
+ (fail "The expansion of the type-syntax had to yield a single element.")}
+ type+))
+
+ _
+ (fail "Wrong syntax for type")}
+ tokens))
+
+(macro:' #export (: tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## The type-annotation macro." __paragraph
+ "(: (List Int) (list +1 +2 +3))"))])
+ ({(#Cons type (#Cons value #Nil))
+ (return (list (` ("lux type check" (type (~ type)) (~ value)))))
+
+ _
+ (fail "Wrong syntax for :")}
+ tokens))
+
+(macro:' #export (:as tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## The type-coercion macro." __paragraph
+ "(:as Dinosaur (list +1 +2 +3))"))])
+ ({(#Cons type (#Cons value #Nil))
+ (return (list (` ("lux type as" (type (~ type)) (~ value)))))
+
+ _
+ (fail "Wrong syntax for :as")}
+ tokens))
+
+(def:''' (empty? xs)
+ #Nil
+ (All [a] (-> ($' List a) Bit))
+ ({#Nil #1
+ _ #0}
+ xs))
+
+(template [<name> <type> <value>]
+ [(def:''' (<name> xy)
+ #Nil
+ (All [a b] (-> (& a b) <type>))
+ (let' [[x y] xy] <value>))]
+
+ [first a x]
+ [second b y])
+
+(def:''' (unfold_type_def type_codes)
+ #Nil
+ (-> ($' List Code) ($' Meta (& Code ($' Maybe ($' List Text)))))
+ ({(#Cons [_ (#Record pairs)] #Nil)
+ (do meta_monad
+ [members (monad\map meta_monad
+ (: (-> [Code Code] (Meta [Text Code]))
+ (function' [pair]
+ ({[[_ (#Tag "" member_name)] member_type]
+ (return [member_name member_type])
+
+ _
+ (fail "Wrong syntax for variant case.")}
+ pair)))
+ pairs)]
+ (return [(` (& (~+ (list\map second members))))
+ (#Some (list\map first members))]))
+
+ (#Cons type #Nil)
+ ({[_ (#Tag "" member_name)]
+ (return [(` .Any) (#Some (list member_name))])
+
+ [_ (#Form (#Cons [_ (#Tag "" member_name)] member_types))]
+ (return [(` (& (~+ member_types))) (#Some (list member_name))])
+
+ _
+ (return [type #None])}
+ type)
+
+ (#Cons case cases)
+ (do meta_monad
+ [members (monad\map meta_monad
+ (: (-> Code (Meta [Text Code]))
+ (function' [case]
+ ({[_ (#Tag "" member_name)]
+ (return [member_name (` .Any)])
+
+ [_ (#Form (#Cons [_ (#Tag "" member_name)] (#Cons member_type #Nil)))]
+ (return [member_name member_type])
+
+ [_ (#Form (#Cons [_ (#Tag "" member_name)] member_types))]
+ (return [member_name (` (& (~+ member_types)))])
+
+ _
+ (fail "Wrong syntax for variant case.")}
+ case)))
+ (list& case cases))]
+ (return [(` (| (~+ (list\map second members))))
+ (#Some (list\map first members))]))
+
+ _
+ (fail "Improper type-definition syntax")}
+ type_codes))
+
+(def:''' (gensym prefix state)
+ #Nil
+ (-> Text ($' Meta Code))
+ ({{#info info #source source #current_module _ #modules modules
+ #scopes scopes #type_context types #host host
+ #seed seed #expected expected
+ #location location #extensions extensions
+ #scope_type_vars scope_type_vars}
+ (#Right {#info info #source source #current_module _ #modules modules
+ #scopes scopes #type_context types #host host
+ #seed ("lux i64 +" 1 seed) #expected expected
+ #location location #extensions extensions
+ #scope_type_vars scope_type_vars}
+ (local_identifier$ ($_ text\compose "__gensym__" prefix (nat\encode seed))))}
+ state))
+
+(macro:' #export (Rec tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Parameter-less recursive types." __paragraph
+ "## A name has to be given to the whole type, to use it within its body." __paragraph
+ "(Rec Self [Int (List Self)])"))])
+ ({(#Cons [_ (#Identifier "" name)] (#Cons body #Nil))
+ (let' [body' (replace_syntax (list [name (` (#.Apply (~ (make_parameter 1)) (~ (make_parameter 0))))])
+ (update_parameters body))]
+ (return (list (` (#.Apply .Nothing (#.UnivQ #.Nil (~ body')))))))
+
+ _
+ (fail "Wrong syntax for Rec")}
+ tokens))
+
+(macro:' #export (exec tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Sequential execution of expressions (great for side-effects)." __paragraph
+ "(exec" ..\n
+ " " "(log! ''#1'')" ..\n
+ " " "(log! ''#2'')" ..\n
+ " " "(log! ''#3'')" ..\n
+ "''YOLO'')"))])
+ ({(#Cons value actions)
+ (let' [dummy (local_identifier$ "")]
+ (return (list (list\fold ("lux type check" (-> Code Code Code)
+ (function' [pre post] (` ({(~ dummy) (~ post)}
+ (~ pre)))))
+ value
+ actions))))
+
+ _
+ (fail "Wrong syntax for exec")}
+ (list\reverse tokens)))
+
+(macro:' (def:' tokens)
+ (let' [[export? tokens'] ({(#Cons [_ (#Tag ["" "export"])] tokens')
+ [#1 tokens']
+
+ _
+ [#0 tokens]}
+ tokens)
+ parts (: (Maybe [Code (List Code) (Maybe Code) Code])
+ ({(#Cons [_ (#Form (#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 [_ (#Form (#Cons name args))] (#Cons body #Nil))
+ (#Some name args #None body)
+
+ (#Cons name (#Cons body #Nil))
+ (#Some name #Nil #None body)
+
+ _
+ #None}
+ tokens'))]
+ ({(#Some name args ?type body)
+ (let' [body' ({#Nil
+ body
+
+ _
+ (` (function' (~ name) [(~+ args)] (~ body)))}
+ args)
+ body'' ({(#Some type)
+ (` (: (~ type) (~ body')))
+
+ #None
+ body'}
+ ?type)]
+ (return (list (` ("lux def" (~ name)
+ (~ body'')
+ [(~ location_code)
+ (#.Record #.Nil)]
+ (~ (bit$ export?)))))))
+
+ #None
+ (fail "Wrong syntax for def'")}
+ parts)))
+
+(def:' (rejoin_pair pair)
+ (-> [Code Code] (List Code))
+ (let' [[left right] pair]
+ (list left right)))
+
+(def:' (text\encode original)
+ (-> Text Text)
+ ($_ text\compose ..double_quote original ..double_quote))
+
+(def:' (code\encode code)
+ (-> Code Text)
+ ({[_ (#Bit value)]
+ (bit\encode value)
+
+ [_ (#Nat value)]
+ (nat\encode value)
+
+ [_ (#Int value)]
+ (int\encode value)
+
+ [_ (#Rev value)]
+ ("lux io error" "@code\encode Undefined behavior.")
+
+ [_ (#Frac value)]
+ (frac\encode value)
+
+ [_ (#Text value)]
+ (text\encode value)
+
+ [_ (#Identifier [prefix name])]
+ (if (text\= "" prefix)
+ name
+ ($_ text\compose prefix "." name))
+
+ [_ (#Tag [prefix name])]
+ (if (text\= "" prefix)
+ ($_ text\compose "#" name)
+ ($_ text\compose "#" prefix "." name))
+
+ [_ (#Form xs)]
+ ($_ text\compose "(" (|> xs
+ (list\map code\encode)
+ (interpose " ")
+ list\reverse
+ (list\fold text\compose "")) ")")
+
+ [_ (#Tuple xs)]
+ ($_ text\compose "[" (|> xs
+ (list\map code\encode)
+ (interpose " ")
+ list\reverse
+ (list\fold text\compose "")) "]")
+
+ [_ (#Record kvs)]
+ ($_ text\compose "{" (|> kvs
+ (list\map (function' [kv] ({[k v] ($_ text\compose (code\encode k) " " (code\encode v))}
+ kv)))
+ (interpose " ")
+ list\reverse
+ (list\fold text\compose "")) "}")}
+ code))
+
+(def:' (expander branches)
+ (-> (List Code) (Meta (List Code)))
+ ({(#Cons [_ (#Form (#Cons [_ (#Identifier macro_name)] macro_args))]
+ (#Cons body
+ branches'))
+ (do meta_monad
+ [??? (macro? macro_name)]
+ (if ???
+ (do meta_monad
+ [init_expansion (macro_expand_once (form$ (list& (identifier$ macro_name) (form$ macro_args) body branches')))]
+ (expander init_expansion))
+ (do meta_monad
+ [sub_expansion (expander branches')]
+ (wrap (list& (form$ (list& (identifier$ macro_name) macro_args))
+ body
+ sub_expansion)))))
+
+ (#Cons pattern (#Cons body branches'))
+ (do meta_monad
+ [sub_expansion (expander branches')]
+ (wrap (list& pattern body sub_expansion)))
+
+ #Nil
+ (do meta_monad [] (wrap (list)))
+
+ _
+ (fail ($_ text\compose "'lux.case' expects an even number of tokens: " (|> branches
+ (list\map code\encode)
+ (interpose " ")
+ list\reverse
+ (list\fold text\compose ""))))}
+ branches))
+
+(macro:' #export (case tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## The pattern-matching macro." ..\n
+ "## Allows the usage of macros within the patterns to provide custom syntax." ..\n
+ "(case (: (List Int) (list +1 +2 +3))" ..\n
+ " " "(#Cons x (#Cons y (#Cons z #Nil)))" ..\n
+ " " "(#Some ($_ * x y z))" __paragraph
+ " " "_" ..\n
+ " " "#None)"))])
+ ({(#Cons value branches)
+ (do meta_monad
+ [expansion (expander branches)]
+ (wrap (list (` ((~ (record$ (as_pairs expansion))) (~ value))))))
+
+ _
+ (fail "Wrong syntax for case")}
+ tokens))
+
+(macro:' #export (^ tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Macro-expanding patterns." ..\n
+ "## It's a special macro meant to be used with 'case'." ..\n
+ "(case (: (List Int) (list +1 +2 +3))" ..\n
+ " (^ (list x y z))" ..\n
+ " (#Some ($_ * x y z))"
+ __paragraph
+ " _" ..\n
+ " #None)"))])
+ (case tokens
+ (#Cons [_ (#Form (#Cons pattern #Nil))] (#Cons body branches))
+ (do meta_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 [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Or-patterns." ..\n
+ "## It's a special macro meant to be used with 'case'." ..\n
+ "(type: Weekday #Monday #Tuesday #Wednesday #Thursday #Friday #Saturday #Sunday)"
+ __paragraph
+ "(def: (weekend? day)" ..\n
+ " (-> Weekday Bit)" ..\n
+ " (case day" ..\n
+ " (^or #Saturday #Sunday)" ..\n
+ " #1"
+ __paragraph
+ " _" ..\n
+ " #0))"))])
+ (case tokens
+ (^ (list& [_ (#Form patterns)] body branches))
+ (case patterns
+ #Nil
+ (fail "^or cannot have 0 patterns")
+
+ _
+ (let' [pairs (|> patterns
+ (list\map (function' [pattern] (list pattern body)))
+ (list\join))]
+ (return (list\compose pairs branches))))
+ _
+ (fail "Wrong syntax for ^or")))
+
+(def:' (identifier? code)
+ (-> Code Bit)
+ (case code
+ [_ (#Identifier _)]
+ #1
+
+ _
+ #0))
+
+(macro:' #export (let tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Creates local bindings." ..\n
+ "## Can (optionally) use pattern-matching macros when binding." ..\n
+ "(let [x (foo bar)" ..\n
+ " y (baz quux)]" ..\n
+ " (op x y))"))])
+ (case tokens
+ (^ (list [_ (#Tuple bindings)] body))
+ (if (multiple? 2 (list\size bindings))
+ (|> bindings as_pairs list\reverse
+ (list\fold (: (-> [Code Code] Code Code)
+ (function' [lr body']
+ (let' [[l r] lr]
+ (if (identifier? l)
+ (` ({(~ l) (~ body')} (~ r)))
+ (` (case (~ r) (~ l) (~ body')))))))
+ body)
+ list
+ return)
+ (fail "let requires an even number of parts"))
+
+ _
+ (fail "Wrong syntax for let")))
+
+(macro:' #export (function tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Syntax for creating functions." ..\n
+ "## Allows for giving the function itself a name, for the sake of recursion." ..\n
+ "(: (All [a b] (-> a b a))" ..\n
+ " (function (_ x y) x))"
+ __paragraph
+ "(: (All [a b] (-> a b a))" ..\n
+ " (function (const x y) x))"))])
+ (case (: (Maybe [Text Code (List Code) Code])
+ (case tokens
+ (^ (list [_ (#Form (list& [_ (#Identifier ["" name])] head tail))] body))
+ (#Some name head tail body)
+
+ _
+ #None))
+ (#Some g!name head tail body)
+ (let [g!blank (local_identifier$ "")
+ nest (: (-> Code (-> Code Code Code))
+ (function' [g!name]
+ (function' [arg body']
+ (if (identifier? arg)
+ (` ([(~ g!name) (~ arg)] (~ body')))
+ (` ([(~ g!name) (~ g!blank)]
+ (.case (~ g!blank) (~ arg) (~ body'))))))))]
+ (return (list (nest (..local_identifier$ g!name) head
+ (list\fold (nest g!blank) body (list\reverse tail))))))
+
+ #None
+ (fail "Wrong syntax for function")))
+
+(def:' (process_def_meta_value code)
+ (-> Code Code)
+ (case code
+ [_ (#Bit value)]
+ (meta_code [..prelude_module "Bit"] (bit$ value))
+
+ [_ (#Nat value)]
+ (meta_code [..prelude_module "Nat"] (nat$ value))
+
+ [_ (#Int value)]
+ (meta_code [..prelude_module "Int"] (int$ value))
+
+ [_ (#Rev value)]
+ (meta_code [..prelude_module "Rev"] (rev$ value))
+
+ [_ (#Frac value)]
+ (meta_code [..prelude_module "Frac"] (frac$ value))
+
+ [_ (#Text value)]
+ (meta_code [..prelude_module "Text"] (text$ value))
+
+ [_ (#Tag [prefix name])]
+ (meta_code [..prelude_module "Tag"] (` [(~ (text$ prefix)) (~ (text$ name))]))
+
+ (^or [_ (#Form _)] [_ (#Identifier _)])
+ code
+
+ [_ (#Tuple xs)]
+ (|> xs
+ (list\map process_def_meta_value)
+ untemplate_list
+ (meta_code [..prelude_module "Tuple"]))
+
+ [_ (#Record kvs)]
+ (|> kvs
+ (list\map (: (-> [Code Code] Code)
+ (function (_ [k v])
+ (` [(~ (process_def_meta_value k))
+ (~ (process_def_meta_value v))]))))
+ untemplate_list
+ (meta_code [..prelude_module "Record"]))
+ ))
+
+(def:' (process_def_meta kvs)
+ (-> (List [Code Code]) Code)
+ (untemplate_list (list\map (: (-> [Code Code] Code)
+ (function (_ [k v])
+ (` [(~ (process_def_meta_value k))
+ (~ (process_def_meta_value v))])))
+ kvs)))
+
+(def:' (with_func_args args meta)
+ (-> (List Code) Code Code)
+ (case args
+ #Nil
+ meta
+
+ _
+ (` (#.Cons [[(~ location_code) (#.Tag [..prelude_module "func-args"])]
+ [(~ location_code) (#.Tuple (.list (~+ (list\map (function (_ arg)
+ (` [(~ location_code) (#.Text (~ (text$ (code\encode arg))))]))
+ args))))]]
+ (~ meta)))))
+
+(def:' (with_type_args args)
+ (-> (List Code) Code)
+ (` {#.type-args [(~+ (list\map (function (_ arg) (text$ (code\encode arg)))
+ args))]}))
+
+(def:' (export^ tokens)
+ (-> (List Code) [Bit (List Code)])
+ (case tokens
+ (#Cons [_ (#Tag [_ "export"])] tokens')
+ [#1 tokens']
+
+ _
+ [#0 tokens]))
+
+(def:' (export ?)
+ (-> Bit (List Code))
+ (if ?
+ (list (' #export))
+ (list)))
+
+(macro:' #export (def: tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Defines global constants/functions." ..\n
+ "(def: (rejoin_pair pair)" ..\n
+ " (-> [Code Code] (List Code))" ..\n
+ " (let [[left right] pair]" ..\n
+ " (list left right)))"
+ __paragraph
+ "(def: branching_exponent" ..\n
+ " Int" ..\n
+ " +5)"))])
+ (let [[exported? tokens'] (export^ tokens)
+ parts (: (Maybe [Code (List Code) (Maybe Code) Code (List [Code Code])])
+ (case tokens'
+ (^ (list [_ (#Form (#Cons name args))] [_ (#Record meta_kvs)] type body))
+ (#Some [name args (#Some type) body meta_kvs])
+
+ (^ (list name [_ (#Record meta_kvs)] type body))
+ (#Some [name #Nil (#Some type) body meta_kvs])
+
+ (^ (list [_ (#Form (#Cons name args))] [_ (#Record meta_kvs)] body))
+ (#Some [name args #None body meta_kvs])
+
+ (^ (list name [_ (#Record meta_kvs)] body))
+ (#Some [name #Nil #None body meta_kvs])
+
+ (^ (list [_ (#Form (#Cons name args))] type body))
+ (#Some [name args (#Some type) body #Nil])
+
+ (^ (list name type body))
+ (#Some [name #Nil (#Some type) body #Nil])
+
+ (^ (list [_ (#Form (#Cons name args))] body))
+ (#Some [name args #None body #Nil])
+
+ (^ (list name body))
+ (#Some [name #Nil #None body #Nil])
+
+ _
+ #None))]
+ (case parts
+ (#Some name args ?type body meta)
+ (let [body (case args
+ #Nil
+ body
+
+ _
+ (` (function ((~ name) (~+ args)) (~ body))))
+ body (case ?type
+ (#Some type)
+ (` (: (~ type) (~ body)))
+
+ #None
+ body)
+ =meta (process_def_meta meta)]
+ (return (list (` ("lux def" (~ name)
+ (~ body)
+ [(~ location_code)
+ (#.Record (~ (with_func_args args =meta)))]
+ (~ (bit$ exported?)))))))
+
+ #None
+ (fail "Wrong syntax for def:"))))
+
+(def: (meta_code_add addition meta)
+ (-> [Code Code] Code Code)
+ (case [addition meta]
+ [[name value] [location (#Record pairs)]]
+ [location (#Record (#Cons [name value] pairs))]
+
+ _
+ meta))
+
+(def: (meta_code_merge addition base)
+ (-> Code Code Code)
+ (case addition
+ [location (#Record pairs)]
+ (list\fold meta_code_add base pairs)
+
+ _
+ base))
+
+(macro:' #export (macro: tokens)
+ (list [(tag$ [..prelude_module "doc"])
+ (text$ ($_ "lux text concat"
+ "## Macro-definition macro." ..\n
+ "(macro: #export (name_of tokens)" ..\n
+ " (case tokens" ..\n
+ " (^template [<tag>]" ..\n
+ " [(^ (list [_ (<tag> [prefix name])]))" ..\n
+ " (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))])" ..\n
+ " ([#Identifier] [#Tag])"
+ __paragraph
+ " _" ..\n
+ " (fail ''Wrong syntax for name_of'')))"))])
+ (let [[exported? tokens] (export^ tokens)
+ name+args+meta+body?? (: (Maybe [Name (List Code) (List [Code Code]) Code])
+ (case tokens
+ (^ (list [_ (#Form (list& [_ (#Identifier name)] args))] body))
+ (#Some [name args (list) body])
+
+ (^ (list [_ (#Identifier name)] body))
+ (#Some [name #Nil (list) body])
+
+ (^ (list [_ (#Form (list& [_ (#Identifier name)] args))] [_ (#Record meta_rec_parts)] body))
+ (#Some [name args meta_rec_parts body])
+
+ (^ (list [_ (#Identifier name)] [_ (#Record meta_rec_parts)] body))
+ (#Some [name #Nil meta_rec_parts body])
+
+ _
+ #None))]
+ (case name+args+meta+body??
+ (#Some [name args meta body])
+ (let [name (identifier$ name)
+ body (case args
+ #Nil
+ body
+
+ _
+ (` ("lux macro"
+ (function ((~ name) (~+ args)) (~ body)))))
+ =meta (process_def_meta meta)]
+ (return (list (` ("lux def" (~ name)
+ (~ body)
+ [(~ location_code)
+ (#Record (~ =meta))]
+ (~ (bit$ exported?)))))))
+
+ #None
+ (fail "Wrong syntax for macro:"))))
+
+(macro: #export (interface: tokens)
+ {#.doc (text$ ($_ "lux text concat"
+ "## Definition of signatures ala ML." ..\n
+ "(interface: #export (Ord a)" ..\n
+ " (: (Equivalence a)" ..\n
+ " eq)" ..\n
+ " (: (-> a a Bit)" ..\n
+ " <)" ..\n
+ " (: (-> a a Bit)" ..\n
+ " <=)" ..\n
+ " (: (-> a a Bit)" ..\n
+ " >)" ..\n
+ " (: (-> a a Bit)" ..\n
+ " >=))"))}
+ (let [[exported? tokens'] (export^ tokens)
+ ?parts (: (Maybe [Name (List Code) Code (List Code)])
+ (case tokens'
+ (^ (list& [_ (#Form (list& [_ (#Identifier name)] args))] [meta_rec_location (#Record meta_rec_parts)] sigs))
+ (#Some name args [meta_rec_location (#Record meta_rec_parts)] sigs)
+
+ (^ (list& [_ (#Identifier name)] [meta_rec_location (#Record meta_rec_parts)] sigs))
+ (#Some name #Nil [meta_rec_location (#Record meta_rec_parts)] sigs)
+
+ (^ (list& [_ (#Form (list& [_ (#Identifier name)] args))] sigs))
+ (#Some name args (` {}) sigs)
+
+ (^ (list& [_ (#Identifier name)] sigs))
+ (#Some name #Nil (` {}) sigs)
+
+ _
+ #None))]
+ (case ?parts
+ (#Some name args meta sigs)
+ (do meta_monad
+ [name+ (normalize name)
+ sigs' (monad\map meta_monad macro_expand sigs)
+ members (: (Meta (List [Text Code]))
+ (monad\map meta_monad
+ (: (-> Code (Meta [Text Code]))
+ (function (_ token)
+ (case token
+ (^ [_ (#Form (list [_ (#Text "lux type check")] type [_ (#Identifier ["" name])]))])
+ (wrap [name type])
+
+ _
+ (fail "Signatures require typed members!"))))
+ (list\join sigs')))
+ #let [[_module _name] name+
+ def_name (identifier$ name)
+ sig_type (record$ (list\map (: (-> [Text Code] [Code Code])
+ (function (_ [m_name m_type])
+ [(local_tag$ m_name) m_type]))
+ members))
+ sig_meta (meta_code_merge (` {#.sig? #1})
+ meta)
+ usage (case args
+ #Nil
+ def_name
+
+ _
+ (` ((~ def_name) (~+ args))))]]
+ (return (list (` (..type: (~+ (export exported?)) (~ usage) (~ sig_meta) (~ sig_type))))))
+
+ #None
+ (fail "Wrong syntax for interface:"))))
+
+(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))))
+
+(template [<name> <form> <message> <doc_msg>]
+ [(macro: #export (<name> tokens)
+ {#.doc <doc_msg>}
+ (case (list\reverse tokens)
+ (^ (list& last init))
+ (return (list (list\fold (: (-> Code Code Code)
+ (function (_ pre post) (` <form>)))
+ last
+ init)))
+
+ _
+ (fail <message>)))]
+
+ [and (if (~ pre) (~ post) #0) "'and' requires >=1 clauses." "Short-circuiting 'and': (and #1 #0 #1) ## => #0"]
+ [or (if (~ pre) #1 (~ post)) "'or' requires >=1 clauses." "Short-circuiting 'or': (or #1 #0 #1) ## => #1"])
+
+(def: (index_of part text)
+ (-> Text Text (Maybe Nat))
+ ("lux text index" 0 part text))
+
+(def: #export (error! message)
+ {#.doc (text$ ($_ "lux text concat"
+ "## Causes an error, with the given error message." ..\n
+ "(error! ''OH NO!'')"))}
+ (-> Text Nothing)
+ ("lux io error" message))
+
+(macro: (default tokens state)
+ {#.doc (text$ ($_ "lux text concat"
+ "## Allows you to provide a default value that will be used" ..\n
+ "## if a (Maybe x) value turns out to be #.None."
+ __paragraph
+ "(default +20 (#.Some +10)) ## => +10"
+ __paragraph
+ "(default +20 #.None) ## => +20"))}
+ (case tokens
+ (^ (list else maybe))
+ (let [g!temp (: Code [dummy_location (#Identifier ["" ""])])
+ code (` (case (~ maybe)
+ (#.Some (~ g!temp))
+ (~ g!temp)
+
+ #.None
+ (~ else)))]
+ (#Right [state (list code)]))
+
+ _
+ (#Left "Wrong syntax for default")))
+
+(def: (text\split_all_with splitter input)
+ (-> Text Text (List Text))
+ (case (..index_of splitter input)
+ #None
+ (list input)
+
+ (#Some idx)
+ (list& ("lux text clip" 0 idx input)
+ (text\split_all_with splitter
+ (let [after_offset ("lux i64 +" 1 idx)
+ after_length ("lux i64 -"
+ after_offset
+ ("lux text size" input))]
+ ("lux text clip" after_offset after_length input))))))
+
+(def: (nth idx xs)
+ (All [a]
+ (-> Nat (List a) (Maybe a)))
+ (case xs
+ #Nil
+ #None
+
+ (#Cons x xs')
+ (if ("lux i64 =" 0 idx)
+ (#Some x)
+ (nth ("lux i64 -" 1 idx) xs')
+ )))
+
+(def: (beta_reduce env type)
+ (-> (List Type) Type Type)
+ (case type
+ (#Sum left right)
+ (#Sum (beta_reduce env left) (beta_reduce env right))
+
+ (#Product left right)
+ (#Product (beta_reduce env left) (beta_reduce env right))
+
+ (#Apply arg func)
+ (#Apply (beta_reduce env arg) (beta_reduce env func))
+
+ (#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)
+
+ (#Function ?input ?output)
+ (#Function (beta_reduce env ?input) (beta_reduce env ?output))
+
+ (#Parameter idx)
+ (case (nth idx env)
+ (#Some parameter)
+ parameter
+
+ _
+ type)
+
+ (#Named 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))
+
+ (#Apply A F)
+ (do maybe_monad
+ [type_fn* (apply_type F A)]
+ (apply_type type_fn* param))
+
+ (#Named name type)
+ (apply_type type param)
+
+ _
+ #None))
+
+(template [<name> <tag>]
+ [(def: (<name> type)
+ (-> Type (List Type))
+ (case type
+ (<tag> left right)
+ (list& left (<name> right))
+
+ _
+ (list type)))]
+
+ [flatten_variant #Sum]
+ [flatten_tuple #Product]
+ [flatten_lambda #Function]
+ )
+
+(def: (flatten_app type)
+ (-> Type [Type (List Type)])
+ (case type
+ (#Apply head func')
+ (let [[func tail] (flatten_app func')]
+ [func (#Cons head tail)])
+
+ _
+ [type (list)]))
+
+(def: (resolve_struct_type type)
+ (-> Type (Maybe (List Type)))
+ (case type
+ (#Product _)
+ (#Some (flatten_tuple type))
+
+ (#Apply arg func)
+ (do maybe_monad
+ [output (apply_type func arg)]
+ (resolve_struct_type output))
+
+ (#UnivQ _ body)
+ (resolve_struct_type body)
+
+ (#ExQ _ body)
+ (resolve_struct_type body)
+
+ (#Named name type)
+ (resolve_struct_type type)
+
+ (#Sum _)
+ #None
+
+ _
+ (#Some (list type))))
+
+(def: (find_module name)
+ (-> Text (Meta Module))
+ (function (_ state)
+ (let [{#info info #source source #current_module _ #modules modules
+ #scopes scopes #type_context types #host host
+ #seed seed #expected expected #location location #extensions extensions
+ #scope_type_vars scope_type_vars} state]
+ (case (get name modules)
+ (#Some module)
+ (#Right state module)
+
+ _
+ (#Left ($_ text\compose "Unknown module: " name))))))
+
+(def: get_current_module
+ (Meta Module)
+ (do meta_monad
+ [module_name current_module_name]
+ (find_module module_name)))
+
+(def: (resolve_tag [module name])
+ (-> Name (Meta [Nat (List Name) Bit Type]))
+ (do meta_monad
+ [=module (find_module module)
+ #let [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags_table #types types #module_annotations _ #module_state _} =module]]
+ (case (get name tags_table)
+ (#Some output)
+ (return output)
+
+ _
+ (fail (text\compose "Unknown tag: " (name\encode [module name]))))))
+
+(def: (resolve_type_tags type)
+ (-> Type (Meta (Maybe [(List Name) (List Type)])))
+ (case type
+ (#Apply arg func)
+ (resolve_type_tags func)
+
+ (#UnivQ env body)
+ (resolve_type_tags body)
+
+ (#ExQ env body)
+ (resolve_type_tags body)
+
+ (#Named [module name] unnamed)
+ (do meta_monad
+ [=module (find_module module)
+ #let [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags #types types #module_annotations _ #module_state _} =module]]
+ (case (get name types)
+ (#Some [tags exported? (#Named _ _type)])
+ (case (resolve_struct_type _type)
+ (#Some members)
+ (return (#Some [tags members]))
+
+ _
+ (return #None))
+
+ _
+ (resolve_type_tags unnamed)))
+
+ _
+ (return #None)))
+
+(def: get_expected_type
+ (Meta Type)
+ (function (_ state)
+ (let [{#info info #source source #current_module _ #modules modules
+ #scopes scopes #type_context types #host host
+ #seed seed #expected expected #location location #extensions extensions
+ #scope_type_vars scope_type_vars} state]
+ (case expected
+ (#Some type)
+ (#Right state type)
+
+ #None
+ (#Left "Not expecting any type.")))))
+
+(macro: #export (implementation tokens)
+ {#.doc "Not meant to be used directly. Prefer 'implementation:'."}
+ (do meta_monad
+ [tokens' (monad\map meta_monad macro_expand tokens)
+ struct_type get_expected_type
+ tags+type (resolve_type_tags struct_type)
+ tags (: (Meta (List Name))
+ (case tags+type
+ (#Some [tags _])
+ (return tags)
+
+ _
+ (fail "No tags available for type.")))
+ #let [tag_mappings (: (List [Text Code])
+ (list\map (function (_ tag) [(second tag) (tag$ tag)])
+ tags))]
+ members (monad\map meta_monad
+ (: (-> Code (Meta [Code Code]))
+ (function (_ token)
+ (case token
+ (^ [_ (#Form (list [_ (#Text "lux def")] [_ (#Identifier "" tag_name)] value meta [_ (#Bit #0)]))])
+ (case (get tag_name tag_mappings)
+ (#Some tag)
+ (wrap [tag value])
+
+ _
+ (fail (text\compose "Unknown implementation member: " tag_name)))
+
+ _
+ (fail "Invalid implementation member."))))
+ (list\join tokens'))]
+ (wrap (list (record$ members)))))
+
+(def: (text\join_with separator parts)
+ (-> Text (List Text) Text)
+ (case parts
+ #Nil
+ ""
+
+ (#Cons head tail)
+ (list\fold (function (_ right left)
+ ($_ text\compose left separator right))
+ head
+ tail)))
+
+(macro: #export (implementation: tokens)
+ {#.doc (text$ ($_ "lux text concat"
+ "## Definition of structures ala ML." ..\n
+ "(implementation: #export order (Order Int)" ..\n
+ " (def: &equivalence equivalence)" ..\n
+ " (def: (< test subject)" ..\n
+ " (< test subject))" ..\n
+ " (def: (<= test subject)" ..\n
+ " (or (< test subject)" ..\n
+ " (= test subject)))" ..\n
+ " (def: (> test subject)" ..\n
+ " (> test subject))" ..\n
+ " (def: (>= test subject)" ..\n
+ " (or (> test subject)" ..\n
+ " (= test subject))))"))}
+ (let [[exported? tokens'] (export^ tokens)
+ ?parts (: (Maybe [Code (List Code) Code Code (List Code)])
+ (case tokens'
+ (^ (list& [_ (#Form (list& name args))] [meta_rec_location (#Record meta_rec_parts)] type definitions))
+ (#Some name args type [meta_rec_location (#Record meta_rec_parts)] definitions)
+
+ (^ (list& name [meta_rec_location (#Record meta_rec_parts)] type definitions))
+ (#Some name #Nil type [meta_rec_location (#Record meta_rec_parts)] definitions)
+
+ (^ (list& [_ (#Form (list& name args))] type definitions))
+ (#Some name args type (` {}) definitions)
+
+ (^ (list& name type definitions))
+ (#Some name #Nil type (` {}) definitions)
+
+ _
+ #None))]
+ (case ?parts
+ (#Some [name args type meta definitions])
+ (let [usage (case args
+ #Nil
+ name
+
+ _
+ (` ((~ name) (~+ args))))]
+ (return (list (` (..def: (~+ (export exported?)) (~ usage)
+ (~ (meta_code_merge (` {#.implementation? #1})
+ meta))
+ (~ type)
+ (implementation (~+ definitions)))))))
+
+ #None
+ (fail "Wrong syntax for implementation:"))))
+
+(def: (function\identity x) (All [a] (-> a a)) x)
+
+(macro: #export (type: tokens)
+ {#.doc (text$ ($_ "lux text concat"
+ "## The type-definition macro." ..\n
+ "(type: (List a) #Nil (#Cons a (List a)))"))}
+ (let [[exported? tokens'] (export^ tokens)
+ [rec? tokens'] (case tokens'
+ (#Cons [_ (#Tag [_ "rec"])] tokens')
+ [#1 tokens']
+
+ _
+ [#0 tokens'])
+ parts (: (Maybe [Text (List Code) (List [Code Code]) (List Code)])
+ (case tokens'
+ (^ (list [_ (#Identifier "" name)] [meta_location (#Record meta_parts)] [type_location (#Record type_parts)]))
+ (#Some [name #Nil meta_parts (list [type_location (#Record type_parts)])])
+
+ (^ (list& [_ (#Identifier "" name)] [meta_location (#Record meta_parts)] type_code1 type_codes))
+ (#Some [name #Nil meta_parts (#Cons type_code1 type_codes)])
+
+ (^ (list& [_ (#Identifier "" name)] type_codes))
+ (#Some [name #Nil (list) type_codes])
+
+ (^ (list [_ (#Form (#Cons [_ (#Identifier "" name)] args))] [meta_location (#Record meta_parts)] [type_location (#Record type_parts)]))
+ (#Some [name args meta_parts (list [type_location (#Record type_parts)])])
+
+ (^ (list& [_ (#Form (#Cons [_ (#Identifier "" name)] args))] [meta_location (#Record meta_parts)] type_code1 type_codes))
+ (#Some [name args meta_parts (#Cons type_code1 type_codes)])
+
+ (^ (list& [_ (#Form (#Cons [_ (#Identifier "" name)] args))] type_codes))
+ (#Some [name args (list) type_codes])
+
+ _
+ #None))]
+ (case parts
+ (#Some name args meta type_codes)
+ (do meta_monad
+ [type+tags?? (unfold_type_def type_codes)
+ module_name current_module_name]
+ (let [type_name (local_identifier$ name)
+ [type tags??] type+tags??
+ type' (: (Maybe Code)
+ (if rec?
+ (if (empty? args)
+ (let [g!param (local_identifier$ "")
+ prime_name (local_identifier$ name)
+ type+ (replace_syntax (list [name (` ((~ prime_name) .Nothing))]) type)]
+ (#Some (` ((All (~ prime_name) [(~ g!param)] (~ type+))
+ .Nothing))))
+ #None)
+ (case args
+ #Nil
+ (#Some type)
+
+ _
+ (#Some (` (.All (~ type_name) [(~+ args)] (~ type)))))))
+ total_meta (let [meta (process_def_meta meta)
+ meta (if rec?
+ (` (#.Cons (~ (flag_meta "type-rec?")) (~ meta)))
+ meta)]
+ (` [(~ location_code)
+ (#.Record (~ meta))]))]
+ (case type'
+ (#Some type'')
+ (let [typeC (` (#.Named [(~ (text$ module_name))
+ (~ (text$ name))]
+ (.type (~ type''))))]
+ (return (list (case tags??
+ (#Some tags)
+ (` ("lux def type tagged" (~ type_name)
+ (~ typeC)
+ (~ total_meta)
+ [(~+ (list\map text$ tags))]
+ (~ (bit$ exported?))))
+
+ _
+ (` ("lux def" (~ type_name)
+ ("lux type check type"
+ (~ typeC))
+ (~ total_meta)
+ (~ (bit$ exported?))))))))
+
+ #None
+ (fail "Wrong syntax for type:"))))
+
+ #None
+ (fail "Wrong syntax for type:"))
+ ))
+
+(template [<name> <to>]
+ [(def: #export (<name> value)
+ (-> (I64 Any) <to>)
+ (:as <to> value))]
+
+ [i64 I64]
+ [nat Nat]
+ [int Int]
+ [rev Rev]
+ )
+
+(type: Referrals
+ #All
+ (#Only (List Text))
+ (#Exclude (List Text))
+ #Ignore
+ #Nothing)
+
+(type: Openings
+ [Text (List Text)])
+
+(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 Code) (Meta (List Text)))
+ (monad\map meta_monad
+ (: (-> Code (Meta Text))
+ (function (_ def)
+ (case def
+ [_ (#Identifier ["" name])]
+ (return name)
+
+ _
+ (fail "#only/#+ and #exclude/#- require identifiers."))))
+ defs))
+
+(def: (parse_referrals tokens)
+ (-> (List Code) (Meta [Referrals (List Code)]))
+ (case tokens
+ (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "+"])] defs))] tokens'))
+ (^ (list& [_ (#Form (list& [_ (#Tag ["" "only"])] defs))] tokens')))
+ (do meta_monad
+ [defs' (extract_defs defs)]
+ (wrap [(#Only defs') tokens']))
+
+ (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "-"])] defs))] tokens'))
+ (^ (list& [_ (#Form (list& [_ (#Tag ["" "exclude"])] defs))] tokens')))
+ (do meta_monad
+ [defs' (extract_defs defs)]
+ (wrap [(#Exclude defs') tokens']))
+
+ (^or (^ (list& [_ (#Tag ["" "*"])] tokens'))
+ (^ (list& [_ (#Tag ["" "all"])] tokens')))
+ (return [#All tokens'])
+
+ (^or (^ (list& [_ (#Tag ["" "_"])] tokens'))
+ (^ (list& [_ (#Tag ["" "nothing"])] tokens')))
+ (return [#Ignore tokens'])
+
+ _
+ (return [#Nothing tokens])))
+
+(def: (parse_openings parts)
+ (-> (List Code) (Meta [(List Openings) (List Code)]))
+ (case parts
+ #.Nil
+ (return [#.Nil #.Nil])
+
+ (^ (list& [_ (#Form (list& [_ (#Text prefix)] structs))] parts'))
+ (do meta_monad
+ [structs' (monad\map meta_monad
+ (function (_ struct)
+ (case struct
+ [_ (#Identifier ["" struct_name])]
+ (return struct_name)
+
+ _
+ (fail "Expected all implementations of opening form to be identifiers.")))
+ structs)
+ next+remainder (parse_openings parts')]
+ (let [[next remainder] next+remainder]
+ (return [(#.Cons [prefix structs'] next)
+ remainder])))
+
+ _
+ (return [#.Nil parts])))
+
+(def: (text\split! at x)
+ (-> Nat Text [Text Text])
+ [("lux text clip" 0 at x)
+ ("lux text clip" at (|> x "lux text size" ("lux i64 -" at)) x)])
+
+(def: (text\split_with token sample)
+ (-> Text Text (Maybe [Text Text]))
+ (do ..maybe_monad
+ [index (..index_of token sample)
+ #let [[pre post'] (text\split! index sample)
+ [_ post] (text\split! ("lux text size" token) post')]]
+ (wrap [pre post])))
+
+(def: (replace_all pattern replacement template)
+ (-> Text Text Text Text)
+ ((: (-> Text Text Text)
+ (function (recur left right)
+ (case (..text\split_with pattern right)
+ (#.Some [pre post])
+ (recur ($_ "lux text concat" left pre replacement) post)
+
+ #.None
+ ("lux text concat" left right))))
+ "" template))
+
+(def: contextual_reference "#")
+(def: self_reference ".")
+
+(def: (de_alias context self aliased)
+ (-> Text Text Text Text)
+ (|> aliased
+ (replace_all ..self_reference self)
+ (replace_all ..contextual_reference context)))
+
+(def: #export module_separator
+ "/")
+
+(def: parallel_hierarchy_sigil
+ "\")
+
+(def: (normalize_parallel_path' hierarchy root)
+ (-> Text Text Text)
+ (case [(text\split_with ..module_separator hierarchy)
+ (text\split_with ..parallel_hierarchy_sigil root)]
+ [(#.Some [_ hierarchy'])
+ (#.Some ["" root'])]
+ (normalize_parallel_path' hierarchy' root')
+
+ _
+ (case root
+ "" hierarchy
+ _ ($_ text\compose root ..module_separator hierarchy))))
+
+(def: (normalize_parallel_path hierarchy root)
+ (-> Text Text (Maybe Text))
+ (case (text\split_with ..parallel_hierarchy_sigil root)
+ (#.Some ["" root'])
+ (#.Some (normalize_parallel_path' hierarchy root'))
+
+ _
+ #.None))
+
+(def: (count_relatives relatives input)
+ (-> Nat Text Nat)
+ (case ("lux text index" relatives ..module_separator input)
+ #None
+ relatives
+
+ (#Some found)
+ (if ("lux i64 =" relatives found)
+ (count_relatives ("lux i64 +" 1 relatives) input)
+ relatives)))
+
+(def: (list\take amount list)
+ (All [a] (-> Nat (List a) (List a)))
+ (case [amount list]
+ (^or [0 _] [_ #Nil])
+ #Nil
+
+ [_ (#Cons head tail)]
+ (#Cons head (list\take ("lux i64 -" 1 amount) tail))))
+
+(def: (list\drop amount list)
+ (All [a] (-> Nat (List a) (List a)))
+ (case [amount list]
+ (^or [0 _] [_ #Nil])
+ list
+
+ [_ (#Cons _ tail)]
+ (list\drop ("lux i64 -" 1 amount) tail)))
+
+(def: (clean_module nested? relative_root module)
+ (-> Bit Text Text (Meta Text))
+ (case (count_relatives 0 module)
+ 0
+ (return (if nested?
+ ($_ "lux text concat" relative_root ..module_separator module)
+ module))
+
+ relatives
+ (let [parts (text\split_all_with ..module_separator relative_root)
+ jumps ("lux i64 -" 1 relatives)]
+ (if (n/< (list\size parts) jumps)
+ (let [prefix (|> parts
+ list\reverse
+ (list\drop jumps)
+ list\reverse
+ (interpose ..module_separator)
+ (text\join_with ""))
+ clean ("lux text clip" relatives (|> module "lux text size" ("lux i64 -" relatives)) module)
+ output (case ("lux text size" clean)
+ 0 prefix
+ _ ($_ text\compose prefix ..module_separator clean))]
+ (return output))
+ (fail ($_ "lux text concat"
+ "Cannot climb the module hierarchy..." ..\n
+ "Importing module: " module ..\n
+ " Relative Root: " relative_root ..\n))))))
+
+(def: (alter_domain alteration domain import)
+ (-> Nat Text Importation Importation)
+ (let [[import_name import_alias import_refer] import
+ original (text\split_all_with ..module_separator import_name)
+ truncated (list\drop (.nat alteration) original)
+ parallel (case domain
+ ""
+ truncated
+
+ _
+ (list& domain truncated))]
+ {#import_name (text\join_with ..module_separator parallel)
+ #import_alias import_alias
+ #import_refer import_refer}))
+
+(def: (parse_imports nested? relative_root context_alias imports)
+ (-> Bit Text Text (List Code) (Meta (List Importation)))
+ (do meta_monad
+ [imports' (monad\map meta_monad
+ (: (-> Code (Meta (List Importation)))
+ (function (_ token)
+ (case token
+ ## Simple
+ [_ (#Identifier ["" m_name])]
+ (do meta_monad
+ [m_name (clean_module nested? relative_root m_name)]
+ (wrap (list {#import_name m_name
+ #import_alias #None
+ #import_refer {#refer_defs #All
+ #refer_open (list)}})))
+
+ ## Nested
+ (^ [_ (#Tuple (list& [_ (#Identifier ["" m_name])] extra))])
+ (do meta_monad
+ [import_name (case (normalize_parallel_path relative_root m_name)
+ (#.Some parallel_path)
+ (wrap parallel_path)
+
+ #.None
+ (clean_module nested? relative_root m_name))
+ referral+extra (parse_referrals extra)
+ #let [[referral extra] referral+extra]
+ openings+extra (parse_openings extra)
+ #let [[openings extra] openings+extra]
+ sub_imports (parse_imports #1 import_name context_alias extra)]
+ (wrap (case [referral openings]
+ [#Nothing #Nil]
+ sub_imports
+
+ _
+ (list& {#import_name import_name
+ #import_alias #None
+ #import_refer {#refer_defs referral
+ #refer_open openings}}
+ sub_imports))))
+
+ (^ [_ (#Tuple (list& [_ (#Text alias)] [_ (#Identifier ["" m_name])] extra))])
+ (do meta_monad
+ [import_name (case (normalize_parallel_path relative_root m_name)
+ (#.Some parallel_path)
+ (wrap parallel_path)
+
+ #.None
+ (clean_module nested? relative_root m_name))
+ referral+extra (parse_referrals extra)
+ #let [[referral extra] referral+extra]
+ openings+extra (parse_openings extra)
+ #let [[openings extra] openings+extra
+ de_aliased (de_alias context_alias m_name alias)]
+ sub_imports (parse_imports #1 import_name de_aliased extra)]
+ (wrap (case [referral openings]
+ [#Ignore #Nil]
+ sub_imports
+
+ _
+ (list& {#import_name import_name
+ #import_alias (#Some de_aliased)
+ #import_refer {#refer_defs referral
+ #refer_open openings}}
+ sub_imports))))
+
+ ## Unrecognized syntax.
+ _
+ (do meta_monad
+ [current_module current_module_name]
+ (fail ($_ text\compose
+ "Wrong syntax for import @ " current_module
+ ..\n (code\encode token)))))))
+ imports)]
+ (wrap (list\join imports'))))
+
+(def: (exported_definitions module state)
+ (-> Text (Meta (List Text)))
+ (let [[current_module modules] (case state
+ {#info info #source source #current_module current_module #modules modules
+ #scopes scopes #type_context types #host host
+ #seed seed #expected expected #location location #extensions extensions
+ #scope_type_vars scope_type_vars}
+ [current_module modules])]
+ (case (get module modules)
+ (#Some =module)
+ (let [to_alias (list\map (: (-> [Text Global]
+ (List Text))
+ (function (_ [name definition])
+ (case definition
+ (#Left _)
+ (list)
+
+ (#Right [exported? def_type def_meta def_value])
+ (if exported?
+ (list name)
+ (list)))))
+ (let [{#module_hash _ #module_aliases _ #definitions definitions #imports _ #tags tags #types types #module_annotations _ #module_state _} =module]
+ definitions))]
+ (#Right state (list\join to_alias)))
+
+ #None
+ (#Left ($_ text\compose
+ "Unknown module: " (text\encode module) ..\n
+ "Current module: " (case current_module
+ (#Some current_module)
+ (text\encode current_module)
+
+ #None
+ "???") ..\n
+ "Known modules: " (|> modules
+ (list\map (function (_ [name module])
+ (text$ name)))
+ tuple$
+ code\encode))))
+ ))
+
+(def: (filter p xs)
+ (All [a] (-> (-> a Bit) (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 Bit)
+ (let [output (list\fold (function (_ case prev)
+ (or prev
+ (text\= case name)))
+ #0
+ 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 Lux (Maybe Type))
+ (case state
+ {#info info #source source #current_module _ #modules modules
+ #scopes scopes #type_context types #host host
+ #seed seed #expected expected #location location #extensions extensions
+ #scope_type_vars scope_type_vars}
+ (find (: (-> Scope (Maybe Type))
+ (function (_ env)
+ (case env
+ {#name _
+ #inner _
+ #locals {#counter _ #mappings locals}
+ #captured {#counter _ #mappings closure}}
+ (try_both (find (: (-> [Text [Type Any]] (Maybe Type))
+ (function (_ [bname [type _]])
+ (if (text\= name bname)
+ (#Some type)
+ #None))))
+ (: (List [Text [Type Any]]) locals)
+ (: (List [Text [Type Any]]) closure)))))
+ scopes)))
+
+(def: (find_def_type name state)
+ (-> Name Lux (Maybe Type))
+ (let [[v_prefix v_name] name
+ {#info info #source source #current_module _ #modules modules
+ #scopes scopes #type_context types #host host
+ #seed seed #expected expected #location location #extensions extensions
+ #scope_type_vars scope_type_vars} state]
+ (case (get v_prefix modules)
+ #None
+ #None
+
+ (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #tags tags #types types #module_annotations _ #module_state _})
+ (case (get v_name definitions)
+ #None
+ #None
+
+ (#Some definition)
+ (case definition
+ (#Left de_aliased)
+ (find_def_type de_aliased state)
+
+ (#Right [exported? def_type def_meta def_value])
+ (#Some def_type))))))
+
+(def: (find_def_value name state)
+ (-> Name (Meta [Type Any]))
+ (let [[v_prefix v_name] name
+ {#info info #source source #current_module _ #modules modules
+ #scopes scopes #type_context types #host host
+ #seed seed #expected expected #location location #extensions extensions
+ #scope_type_vars scope_type_vars} state]
+ (case (get v_prefix modules)
+ #None
+ (#Left (text\compose "Unknown definition: " (name\encode name)))
+
+ (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #tags tags #types types #module_annotations _ #module_state _})
+ (case (get v_name definitions)
+ #None
+ (#Left (text\compose "Unknown definition: " (name\encode name)))
+
+ (#Some definition)
+ (case definition
+ (#Left de_aliased)
+ (find_def_value de_aliased state)
+
+ (#Right [exported? def_type def_meta def_value])
+ (#Right [state [def_type def_value]]))))))
+
+(def: (find_type_var idx bindings)
+ (-> Nat (List [Nat (Maybe Type)]) (Maybe Type))
+ (case bindings
+ #Nil
+ #Nil
+
+ (#Cons [var bound] bindings')
+ (if ("lux i64 =" idx var)
+ bound
+ (find_type_var idx bindings'))))
+
+(def: (find_type full_name)
+ (-> Name (Meta Type))
+ (do meta_monad
+ [#let [[module name] full_name]
+ current_module current_module_name]
+ (function (_ compiler)
+ (let [temp (if (text\= "" module)
+ (case (find_in_env name compiler)
+ (#Some struct_type)
+ (#Right [compiler struct_type])
+
+ _
+ (case (find_def_type [current_module name] compiler)
+ (#Some struct_type)
+ (#Right [compiler struct_type])
+
+ _
+ (#Left ($_ text\compose "Unknown var: " (name\encode full_name)))))
+ (case (find_def_type full_name compiler)
+ (#Some struct_type)
+ (#Right [compiler struct_type])
+
+ _
+ (#Left ($_ text\compose "Unknown var: " (name\encode full_name)))))]
+ (case temp
+ (#Right [compiler (#Var type_id)])
+ (let [{#info _ #source _ #current_module _ #modules _
+ #scopes _ #type_context type_context #host _
+ #seed _ #expected _ #location _ #extensions extensions
+ #scope_type_vars _} compiler
+ {#ex_counter _ #var_counter _ #var_bindings var_bindings} type_context]
+ (case (find_type_var type_id var_bindings)
+ #None
+ temp
+
+ (#Some actualT)
+ (#Right [compiler actualT])))
+
+ _
+ temp))
+ )))
+
+(def: (zip/2 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] (zip/2 xs' ys'))
+
+ _
+ (list))
+
+ _
+ (list)))
+
+(def: (type\encode type)
+ (-> Type Text)
+ (case type
+ (#Primitive name params)
+ (case params
+ #Nil
+ name
+
+ _
+ ($_ text\compose "(" name " " (|> params (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) ")"))
+
+ (#Sum _)
+ ($_ text\compose "(| " (|> (flatten_variant type) (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) ")")
+
+ (#Product _)
+ ($_ text\compose "[" (|> (flatten_tuple type) (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) "]")
+
+ (#Function _)
+ ($_ text\compose "(-> " (|> (flatten_lambda type) (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) ")")
+
+ (#Parameter id)
+ (nat\encode id)
+
+ (#Var id)
+ ($_ text\compose "⌈v:" (nat\encode id) "⌋")
+
+ (#Ex id)
+ ($_ text\compose "⟨e:" (nat\encode id) "⟩")
+
+ (#UnivQ env body)
+ ($_ text\compose "(All " (type\encode body) ")")
+
+ (#ExQ env body)
+ ($_ text\compose "(Ex " (type\encode body) ")")
+
+ (#Apply _)
+ (let [[func args] (flatten_app type)]
+ ($_ text\compose
+ "(" (type\encode func) " "
+ (|> args (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose ""))
+ ")"))
+
+ (#Named name _)
+ (name\encode name)
+ ))
+
+(macro: #export (^open tokens)
+ {#.doc (text$ ($_ "lux text concat"
+ "## Same as the 'open' macro, but meant to be used as a pattern-matching macro for generating local bindings." ..\n
+ "## Takes an 'alias' text for the generated local bindings." ..\n
+ "(def: #export (range (^open ''.'') from to)" ..\n
+ " (All [a] (-> (Enum a) a a (List a)))" ..\n
+ " (range' <= succ from to))"))}
+ (case tokens
+ (^ (list& [_ (#Form (list [_ (#Text alias)]))] body branches))
+ (do meta_monad
+ [g!temp (gensym "temp")]
+ (wrap (list& g!temp (` (..^open (~ g!temp) (~ (text$ alias)) (~ body))) branches)))
+
+ (^ (list [_ (#Identifier name)] [_ (#Text alias)] body))
+ (do meta_monad
+ [init_type (find_type name)
+ struct_evidence (resolve_type_tags init_type)]
+ (case struct_evidence
+ #None
+ (fail (text\compose "Can only 'open' structs: " (type\encode init_type)))
+
+ (#Some tags&members)
+ (do meta_monad
+ [full_body ((: (-> Name [(List Name) (List Type)] Code (Meta Code))
+ (function (recur source [tags members] target)
+ (let [locals (list\map (function (_ [t_module t_name])
+ ["" (de_alias "" t_name alias)])
+ tags)
+ pattern (tuple$ (list\map identifier$ locals))]
+ (do meta_monad
+ [enhanced_target (monad\fold meta_monad
+ (function (_ [m_local m_type] enhanced_target)
+ (do meta_monad
+ [m_implementation (resolve_type_tags m_type)]
+ (case m_implementation
+ (#Some m_tags&members)
+ (recur m_local
+ m_tags&members
+ enhanced_target)
+
+ #None
+ (wrap enhanced_target))))
+ target
+ (zip/2 locals members))]
+ (wrap (` ({(~ pattern) (~ enhanced_target)} (~ (identifier$ source)))))))))
+ name tags&members body)]
+ (wrap (list full_body)))))
+
+ _
+ (fail "Wrong syntax for ^open")))
+
+(macro: #export (cond tokens)
+ {#.doc (text$ ($_ "lux text concat"
+ "## Branching structures with multiple test conditions." ..\n
+ "(cond (even? num) ''even''" ..\n
+ " (odd? num) ''odd''"
+ __paragraph
+ " ## else_branch" ..\n
+ " ''???'')"))}
+ (if ("lux i64 =" 0 (n/% 2 (list\size tokens)))
+ (fail "cond requires an uneven number of arguments.")
+ (case (list\reverse tokens)
+ (^ (list& else branches'))
+ (return (list (list\fold (: (-> [Code Code] Code Code)
+ (function (_ branch else)
+ (let [[right left] branch]
+ (` (if (~ left) (~ right) (~ else))))))
+ else
+ (as_pairs branches'))))
+
+ _
+ (fail "Wrong syntax for cond"))))
+
+(def: (enumeration' idx xs)
+ (All [a] (-> Nat (List a) (List [Nat a])))
+ (case xs
+ (#Cons x xs')
+ (#Cons [idx x] (enumeration' ("lux i64 +" 1 idx) xs'))
+
+ #Nil
+ #Nil))
+
+(def: (enumeration xs)
+ (All [a] (-> (List a) (List [Nat a])))
+ (enumeration' 0 xs))
+
+(macro: #export (get@ tokens)
+ {#.doc (text$ ($_ "lux text concat"
+ "## Accesses the value of a record at a given tag." ..\n
+ "(get@ #field my_record)"
+ __paragraph
+ "## Can also work with multiple levels of nesting:" ..\n
+ "(get@ [#foo #bar #baz] my_record)"
+ __paragraph
+ "## And, if only the slot/path is given, generates an accessor function:" ..\n
+ "(let [getter (get@ [#foo #bar #baz])]" ..\n
+ " (getter my_record))"))}
+ (case tokens
+ (^ (list [_ (#Tag slot')] record))
+ (do meta_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$ (list\map (: (-> [Name [Nat Type]] [Code Code])
+ (function (_ [[r_prefix r_name] [r_idx r_type]])
+ [(tag$ [r_prefix r_name])
+ (if ("lux i64 =" idx r_idx)
+ g!output
+ g!_)]))
+ (zip/2 tags (enumeration members))))]
+ (return (list (` ({(~ pattern) (~ g!output)} (~ record))))))
+
+ _
+ (fail "get@ can only use records.")))
+
+ (^ (list [_ (#Tuple slots)] record))
+ (return (list (list\fold (: (-> Code Code Code)
+ (function (_ slot inner)
+ (` (..get@ (~ slot) (~ inner)))))
+ record
+ slots)))
+
+ (^ (list selector))
+ (do meta_monad
+ [g!_ (gensym "_")
+ g!record (gensym "record")]
+ (wrap (list (` (function ((~ g!_) (~ g!record)) (..get@ (~ selector) (~ g!record)))))))
+
+ _
+ (fail "Wrong syntax for get@")))
+
+(def: (open_field alias tags my_tag_index [module short] source type)
+ (-> Text (List Name) Nat Name Code Type (Meta (List Code)))
+ (do meta_monad
+ [output (resolve_type_tags type)
+ g!_ (gensym "g!_")
+ #let [g!output (local_identifier$ short)
+ pattern (|> tags
+ enumeration
+ (list\map (function (_ [tag_idx tag])
+ (if ("lux i64 =" my_tag_index tag_idx)
+ g!output
+ g!_)))
+ tuple$)
+ source+ (` ({(~ pattern) (~ g!output)} (~ source)))]]
+ (case output
+ (#Some [tags' members'])
+ (do meta_monad
+ [decls' (monad\map meta_monad
+ (: (-> [Nat Name Type] (Meta (List Code)))
+ (function (_ [sub_tag_index sname stype])
+ (open_field alias tags' sub_tag_index sname source+ stype)))
+ (enumeration (zip/2 tags' members')))]
+ (return (list\join decls')))
+
+ _
+ (return (list (` ("lux def" (~ (local_identifier$ (de_alias "" short alias)))
+ (~ source+)
+ [(~ location_code) (#.Record #Nil)]
+ #0)))))))
+
+(macro: #export (open: tokens)
+ {#.doc (text$ ($_ "lux text concat"
+ "## Opens a implementation and generates a definition for each of its members (including nested members)."
+ __paragraph
+ "## For example:" ..\n
+ "(open: ''i:.'' number)"
+ __paragraph
+ "## Will generate:" ..\n
+ "(def: i:+ (\ number +))" ..\n
+ "(def: i:- (\ number -))" ..\n
+ "(def: i:* (\ number *))" ..\n
+ "..."))}
+ (case tokens
+ (^ (list [_ (#Text alias)] struct))
+ (case struct
+ [_ (#Identifier struct_name)]
+ (do meta_monad
+ [struct_type (find_type struct_name)
+ output (resolve_type_tags struct_type)
+ #let [source (identifier$ struct_name)]]
+ (case output
+ (#Some [tags members])
+ (do meta_monad
+ [decls' (monad\map meta_monad (: (-> [Nat Name Type] (Meta (List Code)))
+ (function (_ [tag_index sname stype])
+ (open_field alias tags tag_index sname source stype)))
+ (enumeration (zip/2 tags members)))]
+ (return (list\join decls')))
+
+ _
+ (fail (text\compose "Can only 'open:' structs: " (type\encode struct_type)))))
+
+ _
+ (do meta_monad
+ [g!struct (gensym "struct")]
+ (return (list (` ("lux def" (~ g!struct) (~ struct)
+ [(~ location_code) (#.Record #Nil)]
+ #0))
+ (` (..open: (~ (text$ alias)) (~ g!struct)))))))
+
+ _
+ (fail "Wrong syntax for open:")))
+
+(macro: #export (|>> tokens)
+ {#.doc (text$ ($_ "lux text concat"
+ "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..\n
+ "(|>> (list\map int\encode) (interpose '' '') (fold text\compose ''''))" ..\n
+ "## =>" ..\n
+ "(function (_ <arg>) (fold text\compose '''' (interpose '' '' (list\map int\encode <arg>))))"))}
+ (do meta_monad
+ [g!_ (gensym "_")
+ g!arg (gensym "arg")]
+ (return (list (` (function ((~ g!_) (~ g!arg)) (|> (~ g!arg) (~+ tokens))))))))
+
+(macro: #export (<<| tokens)
+ {#.doc (text$ ($_ "lux text concat"
+ "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..\n
+ "(<<| (fold text\compose '''') (interpose '' '') (list\map int\encode))" ..\n
+ "## =>" ..\n
+ "(function (_ <arg>) (fold text\compose '''' (interpose '' '' (list\map int\encode <arg>))))"))}
+ (do meta_monad
+ [g!_ (gensym "_")
+ g!arg (gensym "arg")]
+ (return (list (` (function ((~ g!_) (~ g!arg)) (<| (~+ tokens) (~ g!arg))))))))
+
+(def: (imported_by? import_name module_name)
+ (-> Text Text (Meta Bit))
+ (do meta_monad
+ [module (find_module module_name)
+ #let [{#module_hash _ #module_aliases _ #definitions _ #imports imports #tags _ #types _ #module_annotations _ #module_state _} module]]
+ (wrap (is_member? imports import_name))))
+
+(def: (read_refer module_name options)
+ (-> Text (List Code) (Meta Refer))
+ (do meta_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]
+ (case options
+ #Nil
+ (wrap {#refer_defs referral
+ #refer_open openings})
+
+ _
+ (fail ($_ text\compose "Wrong syntax for refer @ " current_module
+ ..\n (|> options
+ (list\map code\encode)
+ (interpose " ")
+ (list\fold text\compose "")))))))
+
+(def: (write_refer module_name [r_defs r_opens])
+ (-> Text Refer (Meta (List Code)))
+ (do meta_monad
+ [current_module current_module_name
+ #let [test_referrals (: (-> Text (List Text) (List Text) (Meta (List Any)))
+ (function (_ module_name all_defs referred_defs)
+ (monad\map meta_monad
+ (: (-> Text (Meta Any))
+ (function (_ _def)
+ (if (is_member? all_defs _def)
+ (return [])
+ (fail ($_ text\compose _def " is not defined in module " module_name " @ " current_module)))))
+ referred_defs)))]
+ defs' (case r_defs
+ #All
+ (exported_definitions module_name)
+
+ (#Only +defs)
+ (do meta_monad
+ [*defs (exported_definitions module_name)
+ _ (test_referrals module_name *defs +defs)]
+ (wrap +defs))
+
+ (#Exclude _defs)
+ (do meta_monad
+ [*defs (exported_definitions module_name)
+ _ (test_referrals module_name *defs _defs)]
+ (wrap (filter (|>> (is_member? _defs) not) *defs)))
+
+ #Ignore
+ (wrap (list))
+
+ #Nothing
+ (wrap (list)))
+ #let [defs (list\map (: (-> Text Code)
+ (function (_ def)
+ (` ("lux def alias" (~ (local_identifier$ def)) (~ (identifier$ [module_name def]))))))
+ defs')
+ openings (|> r_opens
+ (list\map (: (-> Openings (List Code))
+ (function (_ [alias structs])
+ (list\map (function (_ name)
+ (` (open: (~ (text$ alias)) (~ (identifier$ [module_name name])))))
+ structs))))
+ list\join)]]
+ (wrap (list\compose defs openings))
+ ))
+
+(macro: #export (refer tokens)
+ (case tokens
+ (^ (list& [_ (#Text module_name)] options))
+ (do meta_monad
+ [=refer (read_refer module_name options)]
+ (write_refer module_name =refer))
+
+ _
+ (fail "Wrong syntax for refer")))
+
+(def: (refer_to_code module_name module_alias' [r_defs r_opens])
+ (-> Text (Maybe Text) Refer Code)
+ (let [module_alias (..default module_name module_alias')
+ localizations (: (List Code)
+ (case r_defs
+ #All
+ (list (' #*))
+
+ (#Only defs)
+ (list (form$ (list& (' #+) (list\map local_identifier$ defs))))
+
+ (#Exclude defs)
+ (list (form$ (list& (' #-) (list\map local_identifier$ defs))))
+
+ #Ignore
+ (list)
+
+ #Nothing
+ (list)))
+ openings (list\map (function (_ [alias structs])
+ (form$ (list& (text$ (..replace_all ..contextual_reference module_alias alias))
+ (list\map local_identifier$ structs))))
+ r_opens)]
+ (` (..refer (~ (text$ module_name))
+ (~+ localizations)
+ (~+ openings)))))
+
+(macro: #export (module: tokens)
+ {#.doc (text$ ($_ "lux text concat"
+ "## Module_definition macro."
+ __paragraph
+ "## Can take optional annotations and allows the specification of modules to import."
+ __paragraph
+ "## Example" ..\n
+ "(.module: {#.doc ''Some documentation...''}" ..\n
+ " [lux #*" ..\n
+ " [control" ..\n
+ " [''M'' monad #*]]" ..\n
+ " [data" ..\n
+ " maybe" ..\n
+ " [''.'' name (''#/.'' codec)]]" ..\n
+ " [macro" ..\n
+ " code]]" ..\n
+ " [//" ..\n
+ " [type (''.'' equivalence)]])"))}
+ (do meta_monad
+ [#let [[_meta _imports] (: [(List [Code Code]) (List Code)]
+ (case tokens
+ (^ (list& [_ (#Record _meta)] _imports))
+ [_meta _imports]
+
+ _
+ [(list) tokens]))]
+ current_module current_module_name
+ imports (parse_imports #0 current_module "" _imports)
+ #let [=imports (|> imports
+ (list\map (: (-> Importation Code)
+ (function (_ [m_name m_alias =refer])
+ (` [(~ (text$ m_name)) (~ (text$ (default "" m_alias)))]))))
+ tuple$)
+ =refers (list\map (: (-> Importation Code)
+ (function (_ [m_name m_alias =refer])
+ (refer_to_code m_name m_alias =refer)))
+ imports)
+ =module (` ("lux def module" [(~ location_code)
+ (#.Record (~ (process_def_meta _meta)))]
+ (~ =imports)))]]
+ (wrap (#Cons =module =refers))))
+
+(macro: #export (\ tokens)
+ {#.doc (text$ ($_ "lux text concat"
+ "## Allows accessing the value of a implementation's member." ..\n
+ "(\ codec encode)"
+ __paragraph
+ "## Also allows using that value as a function." ..\n
+ "(\ codec encode +123)"))}
+ (case tokens
+ (^ (list struct [_ (#Identifier member)]))
+ (return (list (` (let [(^open (~ (text$ ..self_reference))) (~ struct)] (~ (identifier$ member))))))
+
+ (^ (list& struct member args))
+ (return (list (` ((..\ (~ struct) (~ member)) (~+ args)))))
+
+ _
+ (fail "Wrong syntax for \")))
+
+(macro: #export (set@ tokens)
+ {#.doc (text$ ($_ "lux text concat"
+ "## Sets the value of a record at a given tag." ..\n
+ "(set@ #name ''Lux'' lang)"
+ __paragraph
+ "## Can also work with multiple levels of nesting:" ..\n
+ "(set@ [#foo #bar #baz] value my_record)"
+ __paragraph
+ "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..\n
+ "(let [setter (set@ [#foo #bar #baz] value)] (setter my_record))" ..\n
+ "(let [setter (set@ [#foo #bar #baz])] (setter value my_record))"))}
+ (case tokens
+ (^ (list [_ (#Tag slot')] value record))
+ (do meta_monad
+ [slot (normalize slot')
+ output (resolve_tag slot)
+ #let [[idx tags exported? type] output]]
+ (case (resolve_struct_type type)
+ (#Some members)
+ (do meta_monad
+ [pattern' (monad\map meta_monad
+ (: (-> [Name [Nat Type]] (Meta [Name Nat Code]))
+ (function (_ [r_slot_name [r_idx r_type]])
+ (do meta_monad
+ [g!slot (gensym "")]
+ (return [r_slot_name r_idx g!slot]))))
+ (zip/2 tags (enumeration members)))]
+ (let [pattern (record$ (list\map (: (-> [Name Nat Code] [Code Code])
+ (function (_ [r_slot_name r_idx r_var])
+ [(tag$ r_slot_name)
+ r_var]))
+ pattern'))
+ output (record$ (list\map (: (-> [Name Nat Code] [Code Code])
+ (function (_ [r_slot_name r_idx r_var])
+ [(tag$ r_slot_name)
+ (if ("lux i64 =" idx r_idx)
+ value
+ r_var)]))
+ pattern'))]
+ (return (list (` ({(~ pattern) (~ output)} (~ record)))))))
+
+ _
+ (fail "set@ can only use records.")))
+
+ (^ (list [_ (#Tuple slots)] value record))
+ (case slots
+ #Nil
+ (fail "Wrong syntax for set@")
+
+ _
+ (do meta_monad
+ [bindings (monad\map meta_monad
+ (: (-> Code (Meta Code))
+ (function (_ _) (gensym "temp")))
+ slots)
+ #let [pairs (zip/2 slots bindings)
+ update_expr (list\fold (: (-> [Code Code] Code Code)
+ (function (_ [s b] v)
+ (` (..set@ (~ s) (~ v) (~ b)))))
+ value
+ (list\reverse pairs))
+ [_ accesses'] (list\fold (: (-> [Code Code] [Code (List (List Code))] [Code (List (List Code))])
+ (function (_ [new_slot new_binding] [old_record accesses'])
+ [(` (get@ (~ new_slot) (~ new_binding)))
+ (#Cons (list new_binding old_record) accesses')]))
+ [record (: (List (List Code)) #Nil)]
+ pairs)
+ accesses (list\join (list\reverse accesses'))]]
+ (wrap (list (` (let [(~+ accesses)]
+ (~ update_expr)))))))
+
+ (^ (list selector value))
+ (do meta_monad
+ [g!_ (gensym "_")
+ g!record (gensym "record")]
+ (wrap (list (` (function ((~ g!_) (~ g!record))
+ (..set@ (~ selector) (~ value) (~ g!record)))))))
+
+ (^ (list selector))
+ (do meta_monad
+ [g!_ (gensym "_")
+ g!value (gensym "value")
+ g!record (gensym "record")]
+ (wrap (list (` (function ((~ g!_) (~ g!value) (~ g!record))
+ (..set@ (~ selector) (~ g!value) (~ g!record)))))))
+
+ _
+ (fail "Wrong syntax for set@")))
+
+(macro: #export (update@ tokens)
+ {#.doc (text$ ($_ "lux text concat"
+ "## Modifies the value of a record at a given tag, based on some function." ..\n
+ "(update@ #age inc person)"
+ __paragraph
+ "## Can also work with multiple levels of nesting:" ..\n
+ "(update@ [#foo #bar #baz] func my_record)"
+ __paragraph
+ "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..\n
+ "(let [updater (update@ [#foo #bar #baz] func)] (updater my_record))" ..\n
+ "(let [updater (update@ [#foo #bar #baz])] (updater func my_record))"))}
+ (case tokens
+ (^ (list [_ (#Tag slot')] fun record))
+ (do meta_monad
+ [slot (normalize slot')
+ output (resolve_tag slot)
+ #let [[idx tags exported? type] output]]
+ (case (resolve_struct_type type)
+ (#Some members)
+ (do meta_monad
+ [pattern' (monad\map meta_monad
+ (: (-> [Name [Nat Type]] (Meta [Name Nat Code]))
+ (function (_ [r_slot_name [r_idx r_type]])
+ (do meta_monad
+ [g!slot (gensym "")]
+ (return [r_slot_name r_idx g!slot]))))
+ (zip/2 tags (enumeration members)))]
+ (let [pattern (record$ (list\map (: (-> [Name Nat Code] [Code Code])
+ (function (_ [r_slot_name r_idx r_var])
+ [(tag$ r_slot_name)
+ r_var]))
+ pattern'))
+ output (record$ (list\map (: (-> [Name Nat Code] [Code Code])
+ (function (_ [r_slot_name r_idx r_var])
+ [(tag$ r_slot_name)
+ (if ("lux i64 =" idx r_idx)
+ (` ((~ fun) (~ r_var)))
+ r_var)]))
+ pattern'))]
+ (return (list (` ({(~ pattern) (~ output)} (~ record)))))))
+
+ _
+ (fail "update@ can only use records.")))
+
+ (^ (list [_ (#Tuple slots)] fun record))
+ (case slots
+ #Nil
+ (fail "Wrong syntax for update@")
+
+ _
+ (do meta_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 meta_monad
+ [g!_ (gensym "_")
+ g!record (gensym "record")]
+ (wrap (list (` (function ((~ g!_) (~ g!record))
+ (..update@ (~ selector) (~ fun) (~ g!record)))))))
+
+ (^ (list selector))
+ (do meta_monad
+ [g!_ (gensym "_")
+ g!fun (gensym "fun")
+ g!record (gensym "record")]
+ (wrap (list (` (function ((~ g!_) (~ g!fun) (~ g!record))
+ (..update@ (~ selector) (~ g!fun) (~ g!record)))))))
+
+ _
+ (fail "Wrong syntax for update@")))
+
+(macro: #export (^template tokens)
+ {#.doc (text$ ($_ "lux text concat"
+ "## It's similar to template, but meant to be used during pattern-matching." ..\n
+ "(def: (beta_reduce env type)" ..\n
+ " (-> (List Type) Type Type)" ..\n
+ " (case type" ..\n
+ " (#.Primitive name params)" ..\n
+ " (#.Primitive name (list\map (beta_reduce env) params))"
+ __paragraph
+ " (^template [<tag>]" ..\n
+ " [(<tag> left right)" ..\n
+ " (<tag> (beta_reduce env left) (beta_reduce env right))])" ..\n
+ " ([#.Sum] [#.Product])"
+ __paragraph
+ " (^template [<tag>]" ..\n
+ " [(<tag> left right)" ..\n
+ " (<tag> (beta_reduce env left) (beta_reduce env right))])" ..\n
+ " ([#.Function] [#.Apply])"
+ __paragraph
+ " (^template [<tag>]" ..\n
+ " [(<tag> old_env def)" ..\n
+ " (case old_env" ..\n
+ " #.Nil" ..\n
+ " (<tag> env def)"
+ __paragraph
+ " _" ..\n
+ " type)])" ..\n
+ " ([#.UnivQ] [#.ExQ])"
+ __paragraph
+ " (#.Parameter idx)" ..\n
+ " (default type (list.nth idx env))"
+ __paragraph
+ " _" ..\n
+ " type" ..\n
+ " ))"))}
+ (case tokens
+ (^ (list& [_ (#Form (list [_ (#Tuple bindings)]
+ [_ (#Tuple templates)]))]
+ [_ (#Form data)]
+ branches))
+ (case (: (Maybe (List Code))
+ (do maybe_monad
+ [bindings' (monad\map maybe_monad get_short bindings)
+ data' (monad\map maybe_monad tuple->list data)]
+ (let [num_bindings (list\size bindings')]
+ (if (every? (|>> ("lux i64 =" num_bindings))
+ (list\map list\size data'))
+ (let [apply (: (-> RepEnv (List Code))
+ (function (_ env) (list\map (apply_template env) templates)))]
+ (|> data'
+ (list\map (compose apply (make_env bindings')))
+ list\join
+ wrap))
+ #None))))
+ (#Some output)
+ (return (list\compose output branches))
+
+ #None
+ (fail "Wrong syntax for ^template"))
+
+ _
+ (fail "Wrong syntax for ^template")))
+
+(def: (find_baseline_column code)
+ (-> Code Nat)
+ (case code
+ (^template [<tag>]
+ [[[_ _ column] (<tag> _)]
+ column])
+ ([#Bit]
+ [#Nat]
+ [#Int]
+ [#Rev]
+ [#Frac]
+ [#Text]
+ [#Identifier]
+ [#Tag])
+
+ (^template [<tag>]
+ [[[_ _ column] (<tag> parts)]
+ (list\fold n/min column (list\map find_baseline_column parts))])
+ ([#Form]
+ [#Tuple])
+
+ [[_ _ column] (#Record pairs)]
+ (list\fold n/min column
+ (list\compose (list\map (|>> first find_baseline_column) pairs)
+ (list\map (|>> second find_baseline_column) pairs)))
+ ))
+
+(type: Doc_Fragment
+ (#Doc_Comment Text)
+ (#Doc_Example Code))
+
+(def: (identify_doc_fragment code)
+ (-> Code Doc_Fragment)
+ (case code
+ [_ (#Text comment)]
+ (#Doc_Comment comment)
+
+ _
+ (#Doc_Example code)))
+
+(template [<name> <extension> <doc>]
+ [(def: #export <name>
+ {#.doc <doc>}
+ (All [s] (-> (I64 s) (I64 s)))
+ (|>> (<extension> 1)))]
+
+ [inc "lux i64 +" "Increment function."]
+ [dec "lux i64 -" "Decrement function."]
+ )
+
+(def: tag\encode
+ (-> Name Text)
+ (|>> name\encode (text\compose "#")))
+
+(def: (repeat n x)
+ (All [a] (-> Int a (List a)))
+ (if ("lux i64 <" n +0)
+ (#Cons x (repeat ("lux i64 +" -1 n) x))
+ #Nil))
+
+(def: (location_padding baseline [_ old_line old_column] [_ new_line new_column])
+ (-> Nat Location Location Text)
+ (if ("lux i64 =" old_line new_line)
+ (text\join_with "" (repeat (.int ("lux i64 -" old_column new_column)) " "))
+ (let [extra_lines (text\join_with "" (repeat (.int ("lux i64 -" old_line new_line)) ..\n))
+ space_padding (text\join_with "" (repeat (.int ("lux i64 -" baseline new_column)) " "))]
+ (text\compose extra_lines space_padding))))
+
+(def: (text\size x)
+ (-> Text Nat)
+ ("lux text size" x))
+
+(def: (update_location [file line column] code_text)
+ (-> Location Text Location)
+ [file line ("lux i64 +" column (text\size code_text))])
+
+(def: (delim_update_location [file line column])
+ (-> Location Location)
+ [file line (inc column)])
+
+(def: rejoin_all_pairs
+ (-> (List [Code Code]) (List Code))
+ (|>> (list\map rejoin_pair) list\join))
+
+(def: (doc_example->Text prev_location baseline example)
+ (-> Location Nat Code [Location Text])
+ (case example
+ (^template [<tag> <encode>]
+ [[new_location (<tag> value)]
+ (let [as_text (<encode> value)]
+ [(update_location new_location as_text)
+ (text\compose (location_padding baseline prev_location new_location)
+ as_text)])])
+ ([#Bit bit\encode]
+ [#Nat nat\encode]
+ [#Int int\encode]
+ [#Frac frac\encode]
+ [#Text text\encode]
+ [#Identifier name\encode]
+ [#Tag tag\encode])
+
+ (^template [<tag> <open> <close> <prep>]
+ [[group_location (<tag> parts)]
+ (let [[group_location' parts_text] (list\fold (function (_ part [last_location text_accum])
+ (let [[part_location part_text] (doc_example->Text last_location baseline part)]
+ [part_location (text\compose text_accum part_text)]))
+ [(delim_update_location group_location) ""]
+ (<prep> parts))]
+ [(delim_update_location group_location')
+ ($_ text\compose (location_padding baseline prev_location group_location)
+ <open>
+ parts_text
+ <close>)])])
+ ([#Form "(" ")" ..function\identity]
+ [#Tuple "[" "]" ..function\identity]
+ [#Record "{" "}" rejoin_all_pairs])
+
+ [new_location (#Rev value)]
+ ("lux io error" "@doc_example->Text Undefined behavior.")
+ ))
+
+(def: (with_baseline baseline [file line column])
+ (-> Nat Location Location)
+ [file line baseline])
+
+(def: (doc_fragment->Text fragment)
+ (-> Doc_Fragment Text)
+ (case fragment
+ (#Doc_Comment comment)
+ (|> comment
+ (text\split_all_with ..\n)
+ (list\map (function (_ line) ($_ text\compose "## " line ..\n)))
+ (text\join_with ""))
+
+ (#Doc_Example example)
+ (let [baseline (find_baseline_column example)
+ [location _] example
+ [_ text] (doc_example->Text (with_baseline baseline location) baseline example)]
+ (text\compose text __paragraph))))
+
+(macro: #export (doc tokens)
+ {#.doc (text$ ($_ "lux text concat"
+ "## Creates code documentation, embedding text as comments and properly formatting the forms it's being given."
+ __paragraph
+ "## For Example:" ..\n
+ "(doc ''Allows arbitrary looping, using the 'recur' form to re-start the loop.''" ..\n
+ " ''Can be used in monadic code to create monadic loops.''" ..\n
+ " (loop [count +0" ..\n
+ " x init]" ..\n
+ " (if (< +10 count)" ..\n
+ " (recur (inc count) (f x))" ..\n
+ " x)))"))}
+ (return (list (` [(~ location_code)
+ (#.Text (~ (|> tokens
+ (list\map (|>> identify_doc_fragment doc_fragment->Text))
+ (text\join_with "")
+ 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_to_code type)
+ (-> Type Code)
+ (case type
+ (#Primitive name params)
+ (` (#.Primitive (~ (text$ name)) (~ (untemplate_list (list\map type_to_code params)))))
+
+ (^template [<tag>]
+ [(<tag> left right)
+ (` (<tag> (~ (type_to_code left)) (~ (type_to_code right))))])
+ ([#.Sum] [#.Product]
+ [#.Function]
+ [#.Apply])
+
+ (^template [<tag>]
+ [(<tag> id)
+ (` (<tag> (~ (nat$ id))))])
+ ([#.Parameter] [#.Var] [#.Ex])
+
+ (^template [<tag>]
+ [(<tag> env type)
+ (let [env' (untemplate_list (list\map type_to_code env))]
+ (` (<tag> (~ env') (~ (type_to_code type)))))])
+ ([#.UnivQ] [#.ExQ])
+
+ (#Named [module name] anonymous)
+ ## TODO: Generate the explicit type definition instead of using
+ ## the "identifier$" shortcut below.
+ ## (` (#.Named [(~ (text$ module)) (~ (text$ name))]
+ ## (~ (type_to_code anonymous))))
+ (identifier$ [module name])))
+
+(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))
+
+ "Loops can also be given custom names."
+ (loop my_loop
+ [count +0
+ x init]
+ (if (< +10 count)
+ (my_loop (inc count) (f x))
+ x)))}
+ (let [?params (case tokens
+ (^ (list name [_ (#Tuple bindings)] body))
+ (#.Some [name bindings body])
+
+ (^ (list [_ (#Tuple bindings)] body))
+ (#.Some [(local_identifier$ "recur") bindings body])
+
+ _
+ #.None)]
+ (case ?params
+ (#.Some [name bindings body])
+ (let [pairs (as_pairs bindings)
+ vars (list\map first pairs)
+ inits (list\map second pairs)]
+ (if (every? identifier? inits)
+ (do meta_monad
+ [inits' (: (Meta (List Name))
+ (case (monad\map maybe_monad get_name inits)
+ (#Some inits') (return inits')
+ #None (fail "Wrong syntax for loop")))
+ init_types (monad\map meta_monad find_type inits')
+ expected get_expected_type]
+ (return (list (` (("lux type check"
+ (-> (~+ (list\map type_to_code init_types))
+ (~ (type_to_code expected)))
+ (function ((~ name) (~+ vars))
+ (~ body)))
+ (~+ inits))))))
+ (do meta_monad
+ [aliases (monad\map meta_monad
+ (: (-> Code (Meta Code))
+ (function (_ _) (gensym "")))
+ inits)]
+ (return (list (` (let [(~+ (interleave aliases inits))]
+ (.loop (~ name)
+ [(~+ (interleave vars aliases))]
+ (~ body)))))))))
+
+ #.None
+ (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& [_ (#Form (list [_ (#Tuple (list& hslot' tslots'))]))] body branches))
+ (do meta_monad
+ [slots (: (Meta [Name (List Name)])
+ (case (: (Maybe [Name (List Name)])
+ (do maybe_monad
+ [hslot (get_tag hslot')
+ tslots (monad\map maybe_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 (monad\map meta_monad normalize tslots)
+ output (resolve_tag hslot)
+ g!_ (gensym "_")
+ #let [[idx tags exported? type] output
+ slot_pairings (list\map (: (-> Name [Text Code])
+ (function (_ [module name])
+ [name (local_identifier$ name)]))
+ (list& hslot tslots))
+ pattern (record$ (list\map (: (-> Name [Code Code])
+ (function (_ [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 Code) Code (Maybe (List Code)))
+ (case target
+ (^or [_ (#Bit _)] [_ (#Nat _)] [_ (#Int _)] [_ (#Rev _)] [_ (#Frac _)] [_ (#Text _)] [_ (#Tag _)])
+ (#Some (list target))
+
+ [_ (#Identifier [prefix name])]
+ (if (and (text\= "" prefix)
+ (text\= label name))
+ (#Some tokens)
+ (#Some (list target)))
+
+ (^template [<tag>]
+ [[location (<tag> elems)]
+ (do maybe_monad
+ [placements (monad\map maybe_monad (place_tokens label tokens) elems)]
+ (wrap (list [location (<tag> (list\join placements))])))])
+ ([#Tuple]
+ [#Form])
+
+ [location (#Record pairs)]
+ (do maybe_monad
+ [=pairs (monad\map maybe_monad
+ (: (-> [Code Code] (Maybe [Code Code]))
+ (function (_ [slot value])
+ (do maybe_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 [location (#Record =pairs)])))
+ ))
+
+(macro: #export (with_expansions tokens)
+ {#.doc (doc "Controlled macro-expansion."
+ "Bind an arbitraty number of Code nodes resulting from macro-expansion to local bindings."
+ "Wherever a binding appears, the bound Code nodes will be spliced in there."
+ (test: "Code operations & implementations"
+ (with_expansions
+ [<tests> (template [<expr> <text>]
+ [(compare <text> (\ Code/encode encode <expr>))]
+
+ [(bit #1) "#1"]
+ [(int +123) "+123"]
+ [(frac +123.0) "+123.0"]
+ [(text "123") "'123'"]
+ [(tag ["yolo" "lol"]) "#yolo.lol"]
+ [(identifier ["yolo" "lol"]) "yolo.lol"]
+ [(form (list (bit #1))) "(#1)"]
+ [(tuple (list (bit #1))) "[#1]"]
+ [(record (list [(bit #1) (int +123)])) "{#1 +123}"]
+ )]
+ (test_all <tests>))))}
+ (case tokens
+ (^ (list& [_ (#Tuple bindings)] bodies))
+ (case bindings
+ (^ (list& [_ (#Identifier ["" var_name])] macro_expr bindings'))
+ (do meta_monad
+ [expansion (macro_expand_once macro_expr)]
+ (case (place_tokens var_name expansion (` (.with_expansions
+ [(~+ bindings')]
+ (~+ bodies))))
+ (#Some output)
+ (wrap output)
+
+ _
+ (fail "[with_expansions] Improper macro expansion.")))
+
+ #Nil
+ (return bodies)
+
+ _
+ (fail "Wrong syntax for with_expansions"))
+
+ _
+ (fail "Wrong syntax for with_expansions")))
+
+(def: (flatten_alias type)
+ (-> Type Type)
+ (case type
+ (^template [<name>]
+ [(#Named ["library/lux" <name>] _)
+ type])
+ (["Bit"]
+ ["Nat"]
+ ["Int"]
+ ["Rev"]
+ ["Frac"]
+ ["Text"])
+
+ (#Named _ type')
+ (flatten_alias type')
+
+ _
+ type))
+
+(def: (anti_quote_def name)
+ (-> Name (Meta Code))
+ (do meta_monad
+ [type+value (find_def_value name)
+ #let [[type value] type+value]]
+ (case (flatten_alias type)
+ (^template [<name> <type> <wrapper>]
+ [(#Named ["library/lux" <name>] _)
+ (wrap (<wrapper> (:as <type> value)))])
+ (["Bit" Bit bit$]
+ ["Nat" Nat nat$]
+ ["Int" Int int$]
+ ["Rev" Rev rev$]
+ ["Frac" Frac frac$]
+ ["Text" Text text$])
+
+ _
+ (fail (text\compose "Cannot anti-quote type: " (name\encode name))))))
+
+(def: (anti_quote token)
+ (-> Code (Meta Code))
+ (case token
+ [_ (#Identifier [def_prefix def_name])]
+ (if (text\= "" def_prefix)
+ (do meta_monad
+ [current_module current_module_name]
+ (anti_quote_def [current_module def_name]))
+ (anti_quote_def [def_prefix def_name]))
+
+ (^template [<tag>]
+ [[meta (<tag> parts)]
+ (do meta_monad
+ [=parts (monad\map meta_monad anti_quote parts)]
+ (wrap [meta (<tag> =parts)]))])
+ ([#Form]
+ [#Tuple])
+
+ [meta (#Record pairs)]
+ (do meta_monad
+ [=pairs (monad\map meta_monad
+ (: (-> [Code Code] (Meta [Code Code]))
+ (function (_ [slot value])
+ (do meta_monad
+ [=value (anti_quote value)]
+ (wrap [slot =value]))))
+ pairs)]
+ (wrap [meta (#Record =pairs)]))
+
+ _
+ (\ meta_monad return token)
+ ## TODO: Figure out why this doesn't work:
+ ## (\ meta_monad wrap token)
+ ))
+
+(macro: #export (static tokens)
+ (case tokens
+ (^ (list pattern))
+ (do meta_monad
+ [pattern' (anti_quote pattern)]
+ (wrap (list pattern')))
+
+ _
+ (fail "Wrong syntax for 'static'.")))
+
+(type: Multi_Level_Case
+ [Code (List [Code Code])])
+
+(def: (case_level^ level)
+ (-> Code (Meta [Code Code]))
+ (case level
+ (^ [_ (#Tuple (list expr binding))])
+ (return [expr binding])
+
+ _
+ (return [level (` #1)])
+ ))
+
+(def: (multi_level_case^ levels)
+ (-> (List Code) (Meta Multi_Level_Case))
+ (case levels
+ #Nil
+ (fail "Multi-level patterns cannot be empty.")
+
+ (#Cons init extras)
+ (do meta_monad
+ [extras' (monad\map meta_monad case_level^ extras)]
+ (wrap [init extras']))))
+
+(def: (multi_level_case$ g!_ [[init_pattern levels] body])
+ (-> Code [Multi_Level_Case Code] (List Code))
+ (let [inner_pattern_body (list\fold (function (_ [calculation pattern] success)
+ (let [bind? (case pattern
+ [_ (#.Identifier _)]
+ #1
+
+ _
+ #0)]
+ (` (case (~ calculation)
+ (~ pattern)
+ (~ success)
+
+ (~+ (if bind?
+ (list)
+ (list g!_ (` #.None))))))))
+ (` (#.Some (~ body)))
+ (: (List [Code Code]) (list\reverse levels)))]
+ (list init_pattern inner_pattern_body)))
+
+(macro: #export (^multi 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)
+ (^multi (#.Some [chunk uri']) [(text\= static chunk) #1])
+ (match_uri endpoint? parts' uri')
+
+ _
+ (#.Left (format "Static part " (%t static) " does not match URI: " uri)))
+
+ "Short-cuts can be taken when using bit tests."
+ "The example above can be rewritten as..."
+ (case (split (size static) uri)
+ (^multi (#.Some [chunk uri']) (text\= static chunk))
+ (match_uri endpoint? parts' uri')
+
+ _
+ (#.Left (format "Static part " (%t static) " does not match URI: " uri))))}
+ (case tokens
+ (^ (list& [_meta (#Form levels)] body next_branches))
+ (do meta_monad
+ [mlc (multi_level_case^ levels)
+ #let [initial_bind? (case mlc
+ [[_ (#.Identifier _)] _]
+ #1
+
+ _
+ #0)]
+ expected get_expected_type
+ g!temp (gensym "temp")]
+ (let [output (list g!temp
+ (` ({(#Some (~ g!temp))
+ (~ g!temp)
+
+ #None
+ (case (~ g!temp)
+ (~+ next_branches))}
+ ("lux type check" (#.Apply (~ (type_to_code expected)) Maybe)
+ (case (~ g!temp)
+ (~+ (multi_level_case$ g!temp [mlc body]))
+
+ (~+ (if initial_bind?
+ (list)
+ (list g!temp (` #.None)))))))))]
+ (wrap output)))
+
+ _
+ (fail "Wrong syntax for ^multi")))
+
+## TODO: Allow asking the compiler for the name of the definition
+## currently being defined. That name can then be fed into
+## 'wrong_syntax_error' for easier maintenance of the error_messages.
+(def: wrong_syntax_error
+ (-> Name Text)
+ (|>> name\encode
+ (text\compose "Wrong syntax for ")))
+
+(macro: #export (name_of tokens)
+ {#.doc (doc "Given an identifier or a tag, gives back a 2 tuple with the prefix and name parts, both as Text."
+ (name_of #.doc)
+ "=>"
+ [..prelude_module "doc"])}
+ (case tokens
+ (^template [<tag>]
+ [(^ (list [_ (<tag> [prefix name])]))
+ (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))])
+ ([#Identifier] [#Tag])
+
+ _
+ (fail (..wrong_syntax_error [..prelude_module "name_of"]))))
+
+(def: (get_scope_type_vars state)
+ (Meta (List Nat))
+ (case state
+ {#info info #source source #current_module _ #modules modules
+ #scopes scopes #type_context types #host host
+ #seed seed #expected expected #location location #extensions extensions
+ #scope_type_vars scope_type_vars}
+ (#Right state scope_type_vars)
+ ))
+
+(def: (list_at idx xs)
+ (All [a] (-> Nat (List a) (Maybe a)))
+ (case xs
+ #Nil
+ #None
+
+ (#Cons x xs')
+ (if ("lux i64 =" 0 idx)
+ (#Some x)
+ (list_at (dec idx) xs'))))
+
+(macro: #export ($ tokens)
+ {#.doc (doc "Allows you to refer to the type-variables in a polymorphic function's type, by their index."
+ "In the example below, 0 corresponds to the 'a' variable."
+ (def: #export (from_list list)
+ (All [a] (-> (List a) (Row a)))
+ (list\fold add
+ (: (Row ($ 0))
+ empty)
+ list)))}
+ (case tokens
+ (^ (list [_ (#Nat idx)]))
+ (do meta_monad
+ [stvs get_scope_type_vars]
+ (case (list_at idx (list\reverse stvs))
+ (#Some var_id)
+ (wrap (list (` (#Ex (~ (nat$ var_id))))))
+
+ #None
+ (fail (text\compose "Indexed-type does not exist: " (nat\encode idx)))))
+
+ _
+ (fail (..wrong_syntax_error (name_of ..$)))))
+
+(def: #export (is? reference sample)
+ {#.doc (doc "Tests whether the 2 values are identical (not just 'equal')."
+ "This one should succeed:"
+ (let [value +5]
+ (is? value value))
+
+ "This one should fail:"
+ (is? +5 (+ +2 +3)))}
+ (All [a] (-> a a Bit))
+ ("lux is" reference sample))
+
+(macro: #export (^@ tokens)
+ {#.doc (doc "Allows you to simultaneously bind and de-structure a value."
+ (def: (hash (^@ set [Hash<a> _]))
+ (list\fold (function (_ elem acc) (+ (\ Hash<a> hash elem) acc))
+ 0
+ (to_list set))))}
+ (case tokens
+ (^ (list& [_meta (#Form (list [_ (#Identifier ["" name])] pattern))] body branches))
+ (let [g!whole (local_identifier$ name)]
+ (return (list& g!whole
+ (` (case (~ g!whole) (~ pattern) (~ body)))
+ branches)))
+
+ _
+ (fail (..wrong_syntax_error (name_of ..^@)))))
+
+(macro: #export (^|> tokens)
+ {#.doc (doc "Pipes the value being pattern-matched against prior to binding it to a variable."
+ (case input
+ (^|> value [inc (% 10) (max 1)])
+ (foo value)))}
+ (case tokens
+ (^ (list& [_meta (#Form (list [_ (#Identifier ["" name])] [_ (#Tuple steps)]))] body branches))
+ (let [g!name (local_identifier$ name)]
+ (return (list& g!name
+ (` (let [(~ g!name) (|> (~ g!name) (~+ steps))]
+ (~ body)))
+ branches)))
+
+ _
+ (fail (..wrong_syntax_error (name_of ..^|>)))))
+
+(macro: #export (:assume tokens)
+ {#.doc (doc "Coerces the given expression to the type of whatever is expected."
+ (: Dinosaur (:assume (list +1 +2 +3))))}
+ (case tokens
+ (^ (list expr))
+ (do meta_monad
+ [type get_expected_type]
+ (wrap (list (` ("lux type as" (~ (type_to_code type)) (~ expr))))))
+
+ _
+ (fail (..wrong_syntax_error (name_of ..:assume)))))
+
+(def: location
+ {#.doc "The location of the current expression being analyzed."}
+ (Meta Location)
+ (function (_ compiler)
+ (#Right [compiler (get@ #location compiler)])))
+
+(macro: #export (undefined tokens)
+ {#.doc (doc "Meant to be used as a stand-in for functions with undefined implementations."
+ "Undefined expressions will type-check against everything, so they make good dummy implementations."
+ "However, if an undefined expression is ever evaluated, it will raise a runtime error."
+ (def: (square x)
+ (-> Int Int)
+ (undefined)))}
+ (case tokens
+ #Nil
+ (do meta_monad
+ [location ..location
+ #let [[module line column] location
+ location ($_ "lux text concat" (text\encode module) "," (nat\encode line) "," (nat\encode column))
+ message ($_ "lux text concat" "Undefined behavior @ " location)]]
+ (wrap (list (` (..error! (~ (text$ message)))))))
+
+ _
+ (fail (..wrong_syntax_error (name_of ..undefined)))))
+
+(macro: #export (:of tokens)
+ {#.doc (doc "Generates the type corresponding to a given expression."
+ "Example #1:"
+ (let [my_num +123]
+ (:of my_num))
+ "=="
+ Int
+ "-------------------"
+ "Example #2:"
+ (:of +123)
+ "=="
+ Int)}
+ (case tokens
+ (^ (list [_ (#Identifier var_name)]))
+ (do meta_monad
+ [var_type (find_type var_name)]
+ (wrap (list (type_to_code var_type))))
+
+ (^ (list expression))
+ (do meta_monad
+ [g!temp (gensym "g!temp")]
+ (wrap (list (` (let [(~ g!temp) (~ expression)]
+ (..:of (~ g!temp)))))))
+
+ _
+ (fail (..wrong_syntax_error (name_of ..:of)))))
+
+(def: (parse_complex_declaration tokens)
+ (-> (List Code) (Meta [[Text (List Text)] (List Code)]))
+ (case tokens
+ (^ (list& [_ (#Form (list& [_ (#Identifier ["" name])] args'))] tokens'))
+ (do meta_monad
+ [args (monad\map meta_monad
+ (function (_ arg')
+ (case arg'
+ [_ (#Identifier ["" arg_name])]
+ (wrap arg_name)
+
+ _
+ (fail "Could not parse an argument.")))
+ args')]
+ (wrap [[name args] tokens']))
+
+ _
+ (fail "Could not parse a complex declaration.")
+ ))
+
+(def: (parse_any tokens)
+ (-> (List Code) (Meta [Code (List Code)]))
+ (case tokens
+ (^ (list& token tokens'))
+ (return [token tokens'])
+
+ _
+ (fail "Could not parse anything.")
+ ))
+
+(def: (parse_many tokens)
+ (-> (List Code) (Meta [(List Code) (List Code)]))
+ (case tokens
+ (^ (list& head tail))
+ (return [tokens (list)])
+
+ _
+ (fail "Could not parse anything.")
+ ))
+
+(def: (parse_end tokens)
+ (-> (List Code) (Meta Any))
+ (case tokens
+ (^ (list))
+ (return [])
+
+ _
+ (fail "Expected input Codes to be empty.")
+ ))
+
+(def: (parse_anns tokens)
+ (-> (List Code) (Meta [Code (List Code)]))
+ (case tokens
+ (^ (list& [_ (#Record _anns)] tokens'))
+ (return [(record$ _anns) tokens'])
+
+ _
+ (return [(' {}) tokens])
+ ))
+
+(macro: #export (template: tokens)
+ {#.doc (doc "Define macros in the style of template and ^template."
+ "For simple macros that do not need any fancy features."
+ (template: (square x)
+ (* x x)))}
+ (do meta_monad
+ [#let [[export? tokens] (export^ tokens)]
+ name+args|tokens (parse_complex_declaration tokens)
+ #let [[[name args] tokens] name+args|tokens]
+ anns|tokens (parse_anns tokens)
+ #let [[anns tokens] anns|tokens]
+ input_templates|tokens (parse_many tokens)
+ #let [[input_templates tokens] input_templates|tokens]
+ _ (parse_end tokens)
+ g!tokens (gensym "tokens")
+ g!compiler (gensym "compiler")
+ g!_ (gensym "_")
+ #let [rep_env (list\map (function (_ arg)
+ [arg (` ((~' ~) (~ (local_identifier$ arg))))])
+ args)]
+ this_module current_module_name]
+ (wrap (list (` (macro: (~+ (export export?))
+ ((~ (local_identifier$ name)) (~ g!tokens) (~ g!compiler))
+ (~ anns)
+ (case (~ g!tokens)
+ (^ (list (~+ (list\map local_identifier$ args))))
+ (#.Right [(~ g!compiler)
+ (list (~+ (list\map (function (_ template)
+ (` (`' (~ (replace_syntax rep_env template)))))
+ input_templates)))])
+
+ (~ g!_)
+ (#.Left (~ (text$ (..wrong_syntax_error [this_module name]))))
+ )))))
+ ))
+
+(macro: #export (as_is tokens compiler)
+ (#Right [compiler tokens]))
+
+(macro: #export (char tokens compiler)
+ (case tokens
+ (^multi (^ (list [_ (#Text input)]))
+ (|> input "lux text size" ("lux i64 =" 1)))
+ (|> input ("lux text char" 0)
+ nat$ list
+ [compiler] #Right)
+
+ _
+ (#Left (..wrong_syntax_error (name_of ..char)))))
+
+(def: target
+ (Meta Text)
+ (function (_ compiler)
+ (#Right [compiler (get@ [#info #target] compiler)])))
+
+(def: (resolve_target choice)
+ (-> Code (Meta Text))
+ (case choice
+ [_ (#Text platform)]
+ (..return platform)
+
+ [_ (#Identifier identifier)]
+ (do meta_monad
+ [identifier (..resolve_global_identifier identifier)
+ type+value (..find_def_value identifier)
+ #let [[type value] type+value]]
+ (case (..flatten_alias type)
+ (^or (#Primitive "#Text" #Nil)
+ (#Named ["library/lux" "Text"] (#Primitive "#Text" #Nil)))
+ (wrap (:as ..Text value))
+
+ _
+ (fail ($_ text\compose
+ "Invalid target platform (must be a value of type Text): " (name\encode identifier)
+ " : " (..code\encode (..type_to_code type))))))
+
+ _
+ (fail ($_ text\compose
+ "Invalid target platform syntax: " (..code\encode choice)
+ ..\n "Must be either a text literal or an identifier."))))
+
+(def: (target_pick target options default)
+ (-> Text (List [Code Code]) (Maybe Code) (Meta (List Code)))
+ (case options
+ #Nil
+ (case default
+ #.None
+ (fail ($_ text\compose "No code for target platform: " target))
+
+ (#.Some default)
+ (return (list default)))
+
+ (#Cons [key pick] options')
+ (do meta_monad
+ [platform (..resolve_target key)]
+ (if (text\= target platform)
+ (return (list pick))
+ (target_pick target options' default)))))
+
+(macro: #export (for tokens)
+ (do meta_monad
+ [target ..target]
+ (case tokens
+ (^ (list [_ (#Record options)]))
+ (target_pick target options #.None)
+
+ (^ (list [_ (#Record options)] default))
+ (target_pick target options (#.Some default))
+
+ _
+ (fail (..wrong_syntax_error (name_of ..for))))))
+
+(template [<name> <type> <output>]
+ [(def: (<name> xy)
+ (All [a b] (-> [a b] <type>))
+ (let [[x y] xy]
+ <output>))]
+
+ [left a x]
+ [right b y])
+
+(def: (label_code code)
+ (-> Code (Meta [(List [Code Code]) Code]))
+ (case code
+ (^ [ann (#Form (list [_ (#Identifier ["" "~~"])] expansion))])
+ (do meta_monad
+ [g!expansion (gensym "g!expansion")]
+ (wrap [(list [g!expansion expansion]) g!expansion]))
+
+ (^template [<tag>]
+ [[ann (<tag> parts)]
+ (do meta_monad
+ [=parts (monad\map meta_monad label_code parts)]
+ (wrap [(list\fold list\compose (list) (list\map left =parts))
+ [ann (<tag> (list\map right =parts))]]))])
+ ([#Form] [#Tuple])
+
+ [ann (#Record kvs)]
+ (do meta_monad
+ [=kvs (monad\map meta_monad
+ (function (_ [key val])
+ (do meta_monad
+ [=key (label_code key)
+ =val (label_code val)
+ #let [[key_labels key_labelled] =key
+ [val_labels val_labelled] =val]]
+ (wrap [(list\compose key_labels val_labels) [key_labelled val_labelled]])))
+ kvs)]
+ (wrap [(list\fold list\compose (list) (list\map left =kvs))
+ [ann (#Record (list\map right =kvs))]]))
+
+ _
+ (return [(list) code])))
+
+(macro: #export (`` tokens)
+ (case tokens
+ (^ (list raw))
+ (do meta_monad
+ [=raw (label_code raw)
+ #let [[labels labelled] =raw]]
+ (wrap (list (` (with_expansions [(~+ (|> labels
+ (list\map (function (_ [label expansion]) (list label expansion)))
+ list\join))]
+ (~ labelled))))))
+
+ _
+ (fail (..wrong_syntax_error (name_of ..``)))
+ ))
+
+(def: (name$ [module name])
+ (-> Name Code)
+ (` [(~ (text$ module)) (~ (text$ name))]))
+
+(def: (untemplate_list& last inits)
+ (-> Code (List Code) Code)
+ (case inits
+ #Nil
+ last
+
+ (#Cons [init inits'])
+ (` (#.Cons (~ init) (~ (untemplate_list& last inits'))))))
+
+(def: (untemplate_record g!meta untemplate_pattern fields)
+ (-> Code (-> Code (Meta Code))
+ (-> (List [Code Code]) (Meta Code)))
+ (do meta_monad
+ [=fields (monad\map meta_monad
+ (function (_ [key value])
+ (do meta_monad
+ [=key (untemplate_pattern key)
+ =value (untemplate_pattern value)]
+ (wrap (` [(~ =key) (~ =value)]))))
+ fields)]
+ (wrap (` [(~ g!meta) (#.Record (~ (untemplate_list =fields)))]))))
+
+(template [<tag> <name>]
+ [(def: (<name> g!meta untemplate_pattern elems)
+ (-> Code (-> Code (Meta Code))
+ (-> (List Code) (Meta Code)))
+ (case (list\reverse elems)
+ (#Cons [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))]
+ inits)
+ (do meta_monad
+ [=inits (monad\map meta_monad untemplate_pattern (list\reverse inits))]
+ (wrap (` [(~ g!meta) (<tag> (~ (untemplate_list& spliced =inits)))])))
+
+ _
+ (do meta_monad
+ [=elems (monad\map meta_monad untemplate_pattern elems)]
+ (wrap (` [(~ g!meta) (<tag> (~ (untemplate_list =elems)))])))))]
+
+ [#.Tuple untemplate_tuple]
+ [#.Form untemplate_form]
+ )
+
+(def: (untemplate_pattern pattern)
+ (-> Code (Meta Code))
+ (do meta_monad
+ [g!meta (gensym "g!meta")]
+ (case pattern
+ (^template [<tag> <gen>]
+ [[_ (<tag> value)]
+ (wrap (` [(~ g!meta) (<tag> (~ (<gen> value)))]))])
+ ([#.Bit bit$]
+ [#.Nat nat$]
+ [#.Int int$]
+ [#.Rev rev$]
+ [#.Frac frac$]
+ [#.Text text$]
+ [#.Tag name$]
+ [#.Identifier name$])
+
+ [_ (#Form (#Cons [[_ (#Identifier ["" "~"])] (#Cons [unquoted #Nil])]))]
+ (return unquoted)
+
+ [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))]
+ (fail "Cannot use (~+) inside of ^code unless it is the last element in a form or a tuple.")
+
+ (^template [<tag> <untemplate>]
+ [[_ (<tag> elems)]
+ (<untemplate> g!meta untemplate_pattern elems)])
+ ([#.Tuple ..untemplate_tuple]
+ [#.Form ..untemplate_form])
+
+ [_ (#Record fields)]
+ (..untemplate_record g!meta untemplate_pattern fields)
+ )))
+
+(macro: #export (^code tokens)
+ (case tokens
+ (^ (list& [_meta (#Form (list template))] body branches))
+ (do meta_monad
+ [pattern (untemplate_pattern template)]
+ (wrap (list& pattern body branches)))
+
+ (^ (list template))
+ (do meta_monad
+ [pattern (untemplate_pattern template)]
+ (wrap (list pattern)))
+
+ _
+ (fail (..wrong_syntax_error (name_of ..^code)))))
+
+(template [<zero> <one>]
+ [(def: #export <zero> #0)
+ (def: #export <one> #1)]
+
+ [false true]
+ [no yes]
+ [off on]
+ )
+
+(macro: #export (:let tokens)
+ (case tokens
+ (^ (list [_ (#Tuple bindings)] bodyT))
+ (if (multiple? 2 (list\size bindings))
+ (return (list (` (..with_expansions [(~+ (|> bindings
+ ..as_pairs
+ (list\map (function (_ [localT valueT])
+ (list localT (` (..as_is (~ valueT))))))
+ (list\fold list\compose (list))))]
+ (~ bodyT)))))
+ (..fail ":let requires an even number of parts"))
+
+ _
+ (..fail (..wrong_syntax_error (name_of ..:let)))))
+
+(macro: #export (try tokens)
+ {#.doc (doc (case (try (risky_computation input))
+ (#.Right success)
+ (do_something success)
+
+ (#.Left error)
+ (recover_from_failure error)))}
+ (case tokens
+ (^ (list expression))
+ (do meta_monad
+ [g!_ (gensym "g!_")]
+ (wrap (list (` ("lux try"
+ (.function ((~ g!_) (~ g!_))
+ (~ expression)))))))
+
+ _
+ (..fail (..wrong_syntax_error (name_of ..try)))))
diff --git a/stdlib/source/library/lux/abstract/algebra.lux b/stdlib/source/library/lux/abstract/algebra.lux
new file mode 100644
index 000000000..8e611b513
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/algebra.lux
@@ -0,0 +1,17 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ [functor (#+ Fix)]]]])
+
+(type: #export (Algebra f a)
+ (-> (f a) a))
+
+(type: #export (CoAlgebra f a)
+ (-> a (f a)))
+
+(type: #export (RAlgebra f a)
+ (-> (f (& (Fix f) a)) a))
+
+(type: #export (RCoAlgebra f a)
+ (-> a (f (| (Fix f) a))))
diff --git a/stdlib/source/library/lux/abstract/apply.lux b/stdlib/source/library/lux/abstract/apply.lux
new file mode 100644
index 000000000..0f63efc65
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/apply.lux
@@ -0,0 +1,37 @@
+(.module:
+ [library
+ [lux #*]]
+ [//
+ [monad (#+ Monad)]
+ ["." functor (#+ Functor)]])
+
+(interface: #export (Apply f)
+ {#.doc "Applicative functors."}
+ (: (Functor f)
+ &functor)
+ (: (All [a b]
+ (-> (f (-> a b)) (f a) (f b)))
+ apply))
+
+(implementation: #export (compose f-monad f-apply g-apply)
+ {#.doc "Applicative functor composition."}
+ (All [F G]
+ (-> (Monad F) (Apply F) (Apply G)
+ ## TODO: Replace (All [a] (F (G a))) with (functor.Then F G)
+ (Apply (All [a] (F (G a))))))
+
+ (def: &functor (functor.compose (get@ #&functor f-apply) (get@ #&functor g-apply)))
+
+ (def: (apply fgf fgx)
+ ## TODO: Switch from this version to the one below (in comments) ASAP.
+ (let [fgf' (\ f-apply apply
+ (\ f-monad wrap (\ g-apply apply))
+ fgf)]
+ (\ f-apply apply fgf' fgx))
+ ## (let [applyF (\ f-apply apply)
+ ## applyG (\ g-apply apply)]
+ ## ($_ applyF
+ ## (\ f-monad wrap applyG)
+ ## fgf
+ ## fgx))
+ ))
diff --git a/stdlib/source/library/lux/abstract/codec.lux b/stdlib/source/library/lux/abstract/codec.lux
new file mode 100644
index 000000000..2d734673f
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/codec.lux
@@ -0,0 +1,29 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ ["." try (#+ Try)]]]]
+ [//
+ [monad (#+ do)]
+ ["." functor]])
+
+(interface: #export (Codec m a)
+ {#.doc "A way to move back-and-forth between a type and an alternative representation for it."}
+ (: (-> a m)
+ encode)
+ (: (-> m (Try a))
+ decode))
+
+(implementation: #export (compose cb-codec ba-codec)
+ {#.doc "Codec composition."}
+ (All [a b c]
+ (-> (Codec c b) (Codec b a)
+ (Codec c a)))
+ (def: encode
+ (|>> (\ ba-codec encode)
+ (\ cb-codec encode)))
+
+ (def: (decode cy)
+ (do try.monad
+ [by (\ cb-codec decode cy)]
+ (\ ba-codec decode by))))
diff --git a/stdlib/source/library/lux/abstract/comonad.lux b/stdlib/source/library/lux/abstract/comonad.lux
new file mode 100644
index 000000000..362556f50
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/comonad.lux
@@ -0,0 +1,79 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [collection
+ ["." list ("#\." fold)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [meta
+ ["." location]]]]
+ [//
+ [functor (#+ Functor)]])
+
+(interface: #export (CoMonad w)
+ {#.doc (doc "CoMonads are the opposite/complement to monads."
+ "CoMonadic structures are often infinite in size and built upon lazily-evaluated functions.")}
+ (: (Functor w)
+ &functor)
+ (: (All [a]
+ (-> (w a) a))
+ unwrap)
+ (: (All [a]
+ (-> (w a) (w (w a))))
+ split))
+
+(macro: #export (be tokens state)
+ {#.doc (doc "A co-monadic parallel to the 'do' macro."
+ (let [square (function (_ n) (* n n))]
+ (be comonad
+ [inputs (iterate inc +2)]
+ (square (head inputs)))))}
+ (case (: (Maybe [(Maybe Text) Code (List Code) Code])
+ (case tokens
+ (^ (list [_ (#.Record (list [[_ (#.Identifier ["" name])] comonad]))] [_ (#.Tuple bindings)] body))
+ (#.Some [(#.Some name) comonad bindings body])
+
+ (^ (list comonad [_ (#.Tuple bindings)] body))
+ (#.Some [#.None comonad bindings body])
+
+ _
+ #.None))
+ (#.Some [?name comonad bindings body])
+ (if (|> bindings list.size (n.% 2) (n.= 0))
+ (let [[module short] (name_of ..be)
+ gensym (: (-> Text Code)
+ (|>> ($_ "lux text concat" module " " short " ") [""] #.Identifier [location.dummy]))
+ g!_ (gensym "_")
+ g!map (gensym "map")
+ g!split (gensym "split")
+ body' (list\fold (: (-> [Code Code] Code Code)
+ (function (_ binding body')
+ (let [[var value] binding]
+ (case var
+ [_ (#.Tag ["" "let"])]
+ (` (let (~ value) (~ body')))
+
+ _
+ (` (|> (~ value) (~ g!split) ((~ g!map) (function ((~ g!_) (~ var)) (~ body')))))
+ ))))
+ body
+ (list.reverse (list.as_pairs bindings)))]
+ (#.Right [state (list (case ?name
+ (#.Some name)
+ (let [name [location.dummy (#.Identifier ["" name])]]
+ (` ({(~ name)
+ ({[(~ g!map) (~' unwrap) (~ g!split)]
+ (~ body')}
+ (~ name))}
+ (~ comonad))))
+
+ #.None
+ (` ({[(~ g!map) (~' unwrap) (~ g!split)]
+ (~ body')}
+ (~ comonad)))))]))
+ (#.Left "'be' bindings must have an even number of parts."))
+
+ #.None
+ (#.Left "Wrong syntax for 'be'")))
diff --git a/stdlib/source/library/lux/abstract/comonad/cofree.lux b/stdlib/source/library/lux/abstract/comonad/cofree.lux
new file mode 100644
index 000000000..c0236f079
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/comonad/cofree.lux
@@ -0,0 +1,28 @@
+(.module:
+ [library
+ [lux #*]]
+ [// (#+ CoMonad)
+ [//
+ [functor (#+ Functor)]]])
+
+(type: #export (CoFree F a)
+ {#.doc "The CoFree CoMonad."}
+ [a (F (CoFree F a))])
+
+(implementation: #export (functor dsl)
+ (All [F] (-> (Functor F) (Functor (CoFree F))))
+
+ (def: (map f [head tail])
+ [(f head) (\ dsl map (map f) tail)]))
+
+(implementation: #export (comonad dsl)
+ (All [F] (-> (Functor F) (CoMonad (CoFree F))))
+
+ (def: &functor (..functor dsl))
+
+ (def: (unwrap [head tail])
+ head)
+
+ (def: (split [head tail])
+ [[head tail]
+ (\ dsl map split tail)]))
diff --git a/stdlib/source/library/lux/abstract/enum.lux b/stdlib/source/library/lux/abstract/enum.lux
new file mode 100644
index 000000000..e80975172
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/enum.lux
@@ -0,0 +1,26 @@
+(.module:
+ [library
+ [lux #*]]
+ [//
+ ["." order (#+ Order)]])
+
+(interface: #export (Enum e)
+ {#.doc "Enumerable types, with a notion of moving forward and backwards through a type's instances."}
+ (: (Order e) &order)
+ (: (-> e e) succ)
+ (: (-> e e) pred))
+
+(def: #export (range enum from to)
+ {#.doc "An inclusive [from, to] range of values."}
+ (All [a] (-> (Enum a) a a (List a)))
+ (let [(^open "/\.") enum]
+ (loop [end to
+ output #.Nil]
+ (cond (/\< end from)
+ (recur (/\pred end) (#.Cons end output))
+
+ (/\< from end)
+ (recur (/\succ end) (#.Cons end output))
+
+ ## (/\= end from)
+ (#.Cons end output)))))
diff --git a/stdlib/source/library/lux/abstract/equivalence.lux b/stdlib/source/library/lux/abstract/equivalence.lux
new file mode 100644
index 000000000..bb21f7711
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/equivalence.lux
@@ -0,0 +1,25 @@
+(.module:
+ [library
+ [lux #*]]
+ [//
+ [functor
+ ["." contravariant]]])
+
+(interface: #export (Equivalence a)
+ {#.doc "Equivalence for a type's instances."}
+ (: (-> a a Bit)
+ =))
+
+(def: #export (rec sub)
+ (All [a] (-> (-> (Equivalence a) (Equivalence a)) (Equivalence a)))
+ (implementation
+ (def: (= left right)
+ (sub = left right))))
+
+(implementation: #export functor
+ (contravariant.Functor Equivalence)
+
+ (def: (map f equivalence)
+ (implementation
+ (def: (= reference sample)
+ (\ equivalence = (f reference) (f sample))))))
diff --git a/stdlib/source/library/lux/abstract/fold.lux b/stdlib/source/library/lux/abstract/fold.lux
new file mode 100644
index 000000000..168d743be
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/fold.lux
@@ -0,0 +1,17 @@
+(.module:
+ [library
+ [lux #*]]
+ [//
+ [monoid (#+ Monoid)]])
+
+(interface: #export (Fold F)
+ {#.doc "Iterate over a structure's values to build a summary value."}
+ (: (All [a b]
+ (-> (-> b a a) a (F b) a))
+ fold))
+
+(def: #export (with-monoid monoid fold value)
+ (All [F a]
+ (-> (Monoid a) (Fold F) (F a) a))
+ (let [(^open "/\.") monoid]
+ (fold /\compose /\identity value)))
diff --git a/stdlib/source/library/lux/abstract/functor.lux b/stdlib/source/library/lux/abstract/functor.lux
new file mode 100644
index 000000000..fb56625e8
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/functor.lux
@@ -0,0 +1,45 @@
+(.module: [library
+ lux])
+
+(interface: #export (Functor f)
+ (: (All [a b]
+ (-> (-> a b)
+ (-> (f a) (f b))))
+ map))
+
+(type: #export (Fix f)
+ (f (Fix f)))
+
+(type: #export (Or f g)
+ (All [a] (| (f a) (g a))))
+
+(def: #export (sum (^open "f\.") (^open "g\."))
+ (All [F G] (-> (Functor F) (Functor G) (Functor (..Or F G))))
+ (implementation
+ (def: (map f fa|ga)
+ (case fa|ga
+ (#.Left fa)
+ (#.Left (f\map f fa))
+
+ (#.Right ga)
+ (#.Right (g\map f ga))))))
+
+(type: #export (And f g)
+ (All [a] (& (f a) (g a))))
+
+(def: #export (product (^open "f\.") (^open "g\."))
+ (All [F G] (-> (Functor F) (Functor G) (Functor (..And F G))))
+ (implementation
+ (def: (map f [fa ga])
+ [(f\map f fa)
+ (g\map f ga)])))
+
+(type: #export (Then f g)
+ (All [a] (f (g a))))
+
+(def: #export (compose (^open "f\.") (^open "g\."))
+ {#.doc "Functor composition."}
+ (All [F G] (-> (Functor F) (Functor G) (Functor (..Then F G))))
+ (implementation
+ (def: (map f fga)
+ (f\map (g\map f) fga))))
diff --git a/stdlib/source/library/lux/abstract/functor/contravariant.lux b/stdlib/source/library/lux/abstract/functor/contravariant.lux
new file mode 100644
index 000000000..db66f1265
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/functor/contravariant.lux
@@ -0,0 +1,9 @@
+(.module:
+ [library
+ [lux #*]])
+
+(interface: #export (Functor f)
+ (: (All [a b]
+ (-> (-> b a)
+ (-> (f a) (f b))))
+ map))
diff --git a/stdlib/source/library/lux/abstract/hash.lux b/stdlib/source/library/lux/abstract/hash.lux
new file mode 100644
index 000000000..2cc18f3e4
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/hash.lux
@@ -0,0 +1,27 @@
+(.module:
+ [library
+ [lux #*]]
+ [//
+ ["." equivalence (#+ Equivalence)]
+ [functor
+ ["." contravariant]]])
+
+(interface: #export (Hash a)
+ {#.doc (doc "A way to produce hash-codes for a type's instances."
+ "A necessity when working with some data-structures, such as dictionaries or sets.")}
+ (: (Equivalence a)
+ &equivalence)
+ (: (-> a Nat)
+ hash))
+
+(implementation: #export functor
+ (contravariant.Functor Hash)
+
+ (def: (map f super)
+ (implementation
+ (def: &equivalence
+ (\ equivalence.functor map f
+ (\ super &equivalence)))
+
+ (def: hash
+ (|>> f (\ super hash))))))
diff --git a/stdlib/source/library/lux/abstract/interval.lux b/stdlib/source/library/lux/abstract/interval.lux
new file mode 100644
index 000000000..5fbf26109
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/interval.lux
@@ -0,0 +1,194 @@
+## https://en.wikipedia.org/wiki/Interval_(mathematics)
+(.module:
+ [library
+ [lux #*]]
+ [//
+ [equivalence (#+ Equivalence)]
+ ["." order]
+ [enum (#+ Enum)]])
+
+(interface: #export (Interval a)
+ {#.doc "A representation of top and bottom boundaries for an ordered type."}
+ (: (Enum a)
+ &enum)
+
+ (: a
+ bottom)
+
+ (: a
+ top))
+
+(def: #export (between enum bottom top)
+ (All [a] (-> (Enum a) a a (Interval a)))
+ (implementation
+ (def: &enum enum)
+ (def: bottom bottom)
+ (def: top top)))
+
+(def: #export (singleton enum elem)
+ (All [a] (-> (Enum a) a (Interval a)))
+ (implementation
+ (def: &enum enum)
+ (def: bottom elem)
+ (def: top elem)))
+
+(template [<name> <comp>]
+ [(def: #export (<name> interval)
+ (All [a] (-> (Interval a) Bit))
+ (let [(^open ",\.") interval]
+ (<comp> ,\bottom ,\top)))]
+
+ [inner? (order.> ,\&order)]
+ [outer? ,\<]
+ [singleton? ,\=]
+ )
+
+(def: #export (within? interval elem)
+ (All [a] (-> (Interval a) a Bit))
+ (let [(^open ",\.") interval]
+ (cond (inner? interval)
+ (and (order.>= ,\&order ,\bottom elem)
+ (order.<= ,\&order ,\top elem))
+
+ (outer? interval)
+ (or (order.>= ,\&order ,\bottom elem)
+ (order.<= ,\&order ,\top elem))
+
+ ## singleton
+ (and (,\= ,\bottom elem)
+ (,\= ,\top elem)))))
+
+(template [<name> <limit>]
+ [(def: #export (<name> elem interval)
+ (All [a] (-> a (Interval a) Bit))
+ (let [(^open ".") interval]
+ (= <limit> elem)))]
+
+ [starts_with? bottom]
+ [ends_with? top]
+ )
+
+(def: #export (borders? interval elem)
+ (All [a] (-> (Interval a) a Bit))
+ (or (starts_with? elem interval)
+ (ends_with? elem interval)))
+
+(def: #export (union left right)
+ (All [a] (-> (Interval a) (Interval a) (Interval a)))
+ (implementation
+ (def: &enum (get@ #&enum right))
+ (def: bottom (order.min (\ right &order) (\ left bottom) (\ right bottom)))
+ (def: top (order.max (\ right &order) (\ left top) (\ right top)))))
+
+(def: #export (intersection left right)
+ (All [a] (-> (Interval a) (Interval a) (Interval a)))
+ (implementation
+ (def: &enum (get@ #&enum right))
+ (def: bottom (order.max (\ right &order) (\ left bottom) (\ right bottom)))
+ (def: top (order.min (\ right &order) (\ left top) (\ right top)))))
+
+(def: #export (complement interval)
+ (All [a] (-> (Interval a) (Interval a)))
+ (let [(^open ".") interval]
+ (implementation
+ (def: &enum (get@ #&enum interval))
+ (def: bottom (succ top))
+ (def: top (pred bottom)))))
+
+(def: #export (precedes? reference sample)
+ (All [a] (-> (Interval a) (Interval a) Bit))
+ (let [(^open ".") reference
+ limit (\ reference bottom)]
+ (and (< limit (\ sample bottom))
+ (< limit (\ sample top)))))
+
+(def: #export (succeeds? reference sample)
+ (All [a] (-> (Interval a) (Interval a) Bit))
+ (precedes? sample reference))
+
+(template [<name> <comp>]
+ [(def: #export (<name> reference sample)
+ (All [a] (-> a (Interval a) Bit))
+ (let [(^open ",\.") sample]
+ (and (<comp> reference ,\bottom)
+ (<comp> reference ,\top))))]
+
+ [before? ,\<]
+ [after? (order.> ,\&order)]
+ )
+
+(def: #export (meets? reference sample)
+ (All [a] (-> (Interval a) (Interval a) Bit))
+ (let [(^open ",\.") reference
+ limit (\ reference bottom)]
+ (and (,\= limit (\ sample top))
+ (order.<= ,\&order limit (\ sample bottom)))))
+
+(def: #export (touches? reference sample)
+ (All [a] (-> (Interval a) (Interval a) Bit))
+ (or (meets? reference sample)
+ (meets? sample reference)))
+
+(template [<name> <eq_side> <ineq> <ineq_side>]
+ [(def: #export (<name> reference sample)
+ (All [a] (-> (Interval a) (Interval a) Bit))
+ (let [(^open ",\.") reference]
+ (and (,\= (\ reference <eq_side>)
+ (\ sample <eq_side>))
+ (<ineq> ,\&order
+ (\ reference <ineq_side>)
+ (\ sample <ineq_side>)))))]
+
+ [starts? ,\bottom order.<= ,\top]
+ [finishes? ,\top order.>= ,\bottom]
+ )
+
+(implementation: #export equivalence (All [a] (Equivalence (Interval a)))
+ (def: (= reference sample)
+ (let [(^open ",\.") reference]
+ (and (,\= ,\bottom (\ sample bottom))
+ (,\= ,\top (\ sample top))))))
+
+(def: #export (nested? reference sample)
+ (All [a] (-> (Interval a) (Interval a) Bit))
+ (cond (or (singleton? sample)
+ (and (inner? reference) (inner? sample))
+ (and (outer? reference) (outer? sample)))
+ (let [(^open ",\.") reference]
+ (and (order.>= ,\&order (\ reference bottom) (\ sample bottom))
+ (order.<= ,\&order (\ reference top) (\ sample top))))
+
+ (or (singleton? reference)
+ (and (inner? reference) (outer? sample)))
+ #0
+
+ ## (and (outer? reference) (inner? sample))
+ (let [(^open ",\.") reference]
+ (or (and (order.>= ,\&order (\ reference bottom) (\ sample bottom))
+ (order.> ,\&order (\ reference bottom) (\ sample top)))
+ (and (,\< (\ reference top) (\ sample bottom))
+ (order.<= ,\&order (\ reference top) (\ sample top)))))
+ ))
+
+(def: #export (overlaps? reference sample)
+ (All [a] (-> (Interval a) (Interval a) Bit))
+ (let [(^open ",\.") reference]
+ (and (not (\ ..equivalence = reference sample))
+ (cond (singleton? sample)
+ #0
+
+ (singleton? reference)
+ (nested? sample reference)
+
+ (or (and (inner? sample) (outer? reference))
+ (and (outer? sample) (inner? reference)))
+ (or (order.>= ,\&order (\ reference bottom) (\ sample top))
+ (order.<= ,\&order (\ reference top) (\ sample bottom)))
+
+ ## both inner
+ (inner? sample)
+ (inner? (intersection reference sample))
+
+ ## both outer
+ (not (nested? reference sample))
+ ))))
diff --git a/stdlib/source/library/lux/abstract/monad.lux b/stdlib/source/library/lux/abstract/monad.lux
new file mode 100644
index 000000000..a99baf75b
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/monad.lux
@@ -0,0 +1,184 @@
+(.module:
+ [library
+ [lux #*
+ [meta
+ ["." location]]]]
+ [//
+ [functor (#+ Functor)]])
+
+(def: (list\fold f init xs)
+ (All [a b]
+ (-> (-> b a a) a (List b) a))
+ (case xs
+ #.Nil
+ init
+
+ (#.Cons x xs')
+ (list\fold f (f x init) xs')))
+
+(def: (list\size xs)
+ (All [a] (-> (List a) Nat))
+ (loop [counter 0
+ xs xs]
+ (case xs
+ #.Nil
+ counter
+
+ (#.Cons _ xs')
+ (recur (inc counter) xs'))))
+
+(def: (reverse xs)
+ (All [a]
+ (-> (List a) (List a)))
+ (list\fold (function (_ 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))
+
+(interface: #export (Monad m)
+ (: (Functor m)
+ &functor)
+ (: (All [a]
+ (-> a (m a)))
+ wrap)
+ (: (All [a]
+ (-> (m (m a)) (m a)))
+ join))
+
+(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 (: (Maybe [(Maybe Text) Code (List Code) Code])
+ (case tokens
+ (^ (list [_ (#.Record (list [[_ (#.Identifier ["" name])] monad]))] [_ (#.Tuple bindings)] body))
+ (#.Some [(#.Some name) monad bindings body])
+
+ (^ (list monad [_ (#.Tuple bindings)] body))
+ (#.Some [#.None monad bindings body])
+
+ _
+ #.None))
+ (#.Some [?name monad bindings body])
+ (if (|> bindings list\size .int ("lux i64 %" +2) ("lux i64 =" +0))
+ (let [[module short] (name_of ..do)
+ gensym (: (-> Text Code)
+ (|>> ($_ "lux text concat" module " " short " ") [""] #.Identifier [location.dummy]))
+ g!_ (gensym "_")
+ g!map (gensym "map")
+ g!join (gensym "join")
+ body' (list\fold (: (-> [Code Code] Code Code)
+ (function (_ binding body')
+ (let [[var value] binding]
+ (case var
+ [_ (#.Tag ["" "let"])]
+ (` (let (~ value) (~ body')))
+
+ _
+ (` (|> (~ value) ((~ g!map) (function ((~ g!_) (~ var)) (~ body'))) (~ g!join)))
+ ))))
+ body
+ (reverse (as_pairs bindings)))]
+ (#.Right [state (list (case ?name
+ (#.Some name)
+ (let [name [location.dummy (#.Identifier ["" name])]]
+ (` ({(~ name)
+ ({[(~ g!map) (~' wrap) (~ g!join)]
+ (~ body')}
+ (~ name))}
+ (~ monad))))
+
+ #.None
+ (` ({[(~ g!map) (~' wrap) (~ g!join)]
+ (~ body')}
+ (~ monad)))))]))
+ (#.Left "'do' bindings must have an even number of parts."))
+
+ #.None
+ (#.Left "Wrong syntax for 'do'")))
+
+(def: #export (bind monad f)
+ (All [! a b]
+ (-> (Monad !) (-> a (! b))
+ (-> (! a) (! b))))
+ (|>> (\ monad map f)
+ (\ monad join)))
+
+(def: #export (seq monad)
+ {#.doc "Run all the monadic values in the list and produce a list of the base values."}
+ (All [M a]
+ (-> (Monad M) (List (M a))
+ (M (List a))))
+ (let [(^open "!\.") monad]
+ (function (recur xs)
+ (case xs
+ #.Nil
+ (!\wrap #.Nil)
+
+ (#.Cons x xs')
+ (|> x
+ (!\map (function (_ _x)
+ (!\map (|>> (#.Cons _x)) (recur xs'))))
+ !\join)))))
+
+(def: #export (map monad f)
+ {#.doc "Apply a monadic function to all values in a list."}
+ (All [M a b]
+ (-> (Monad M) (-> a (M b)) (List a)
+ (M (List b))))
+ (let [(^open "!\.") monad]
+ (function (recur xs)
+ (case xs
+ #.Nil
+ (!\wrap #.Nil)
+
+ (#.Cons x xs')
+ (|> (f x)
+ (!\map (function (_ _x)
+ (!\map (|>> (#.Cons _x)) (recur xs'))))
+ !\join)))))
+
+(def: #export (filter monad f)
+ {#.doc "Filter the values in a list with a monadic function."}
+ (All [! a b]
+ (-> (Monad !) (-> a (! Bit)) (List a)
+ (! (List a))))
+ (let [(^open "!\.") monad]
+ (function (recur xs)
+ (case xs
+ #.Nil
+ (!\wrap #.Nil)
+
+ (#.Cons head xs')
+ (|> (f head)
+ (!\map (function (_ verdict)
+ (!\map (function (_ tail)
+ (if verdict
+ (#.Cons head tail)
+ tail))
+ (recur xs'))))
+ !\join)))))
+
+(def: #export (fold monad f init xs)
+ {#.doc "Fold a list with a monadic function."}
+ (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)]
+ (fold monad f init' xs'))))
diff --git a/stdlib/source/library/lux/abstract/monad/free.lux b/stdlib/source/library/lux/abstract/monad/free.lux
new file mode 100644
index 000000000..9648fbc8e
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/monad/free.lux
@@ -0,0 +1,68 @@
+(.module:
+ [library
+ [lux #*]]
+ [///
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ [monad (#+ Monad)]])
+
+(type: #export (Free F a)
+ {#.doc "The Free Monad."}
+ (#Pure a)
+ (#Effect (F (Free F a))))
+
+(implementation: #export (functor dsl)
+ (All [F] (-> (Functor F) (Functor (Free F))))
+
+ (def: (map f ea)
+ (case ea
+ (#Pure a)
+ (#Pure (f a))
+
+ (#Effect value)
+ (#Effect (\ dsl map (map f) value)))))
+
+(implementation: #export (apply dsl)
+ (All [F] (-> (Functor F) (Apply (Free F))))
+
+ (def: &functor (..functor dsl))
+
+ (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
+ (function (_ f) (apply f ea))
+ ff))
+ )))
+
+(implementation: #export (monad dsl)
+ (All [F] (-> (Functor F) (Monad (Free F))))
+
+ (def: &functor (..functor dsl))
+
+ (def: (wrap a)
+ (#Pure a))
+
+ (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))
+ )))
diff --git a/stdlib/source/library/lux/abstract/monad/indexed.lux b/stdlib/source/library/lux/abstract/monad/indexed.lux
new file mode 100644
index 000000000..92db5f045
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/monad/indexed.lux
@@ -0,0 +1,84 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ [monad]
+ ["p" parser
+ ["s" code (#+ Parser)]]]
+ [data
+ [collection
+ ["." list ("#\." functor fold)]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]]])
+
+(interface: #export (IxMonad m)
+ (: (All [p a]
+ (-> a (m p p a)))
+ wrap)
+
+ (: (All [ii it io vi vo]
+ (-> (-> vi (m it io vo))
+ (m ii it vi)
+ (m ii io vo)))
+ bind))
+
+(type: Binding [Code Code])
+
+(def: binding
+ (Parser Binding)
+ (p.and s.any s.any))
+
+(type: Context
+ (#Let (List Binding))
+ (#Bind Binding))
+
+(def: context
+ (Parser Context)
+ (p.or (p.after (s.this! (' #let))
+ (s.tuple (p.some binding)))
+ binding))
+
+(def: (pair_list [binding value])
+ (All [a] (-> [a a] (List a)))
+ (list binding value))
+
+(def: named_monad
+ (Parser [(Maybe Text) Code])
+ (p.either (s.record (p.and (\ p.monad map (|>> #.Some)
+ s.local_identifier)
+ s.any))
+ (\ p.monad map (|>> [#.None])
+ s.any)))
+
+(syntax: #export (do {[?name monad] ..named_monad}
+ {context (s.tuple (p.some context))}
+ expression)
+ (macro.with_gensyms [g!_ g!bind]
+ (let [body (list\fold (function (_ context next)
+ (case context
+ (#Let bindings)
+ (` (let [(~+ (|> bindings
+ (list\map pair_list)
+ list.concat))]
+ (~ next)))
+
+ (#Bind [binding value])
+ (` ((~ g!bind)
+ (.function ((~ g!_) (~ binding))
+ (~ next))
+ (~ value)))))
+ expression
+ (list.reverse context))]
+ (wrap (list (case ?name
+ (#.Some name)
+ (let [name (code.local_identifier name)]
+ (` (let [(~ name) (~ monad)
+ {#..wrap (~' wrap)
+ #..bind (~ g!bind)} (~ name)]
+ (~ body))))
+
+ #.None
+ (` (let [{#..wrap (~' wrap)
+ #..bind (~ g!bind)} (~ monad)]
+ (~ body)))))))))
diff --git a/stdlib/source/library/lux/abstract/monoid.lux b/stdlib/source/library/lux/abstract/monoid.lux
new file mode 100644
index 000000000..87f155848
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/monoid.lux
@@ -0,0 +1,21 @@
+(.module:
+ [library
+ [lux #*]])
+
+(interface: #export (Monoid a)
+ {#.doc (doc "A way to compose values."
+ "Includes an identity value which does not alter any other value when combined with.")}
+ (: a
+ identity)
+ (: (-> a a a)
+ compose))
+
+(def: #export (compose left right)
+ (All [l r] (-> (Monoid l) (Monoid r) (Monoid [l r])))
+ (implementation
+ (def: identity
+ [(\ left identity) (\ right identity)])
+
+ (def: (compose [lL rL] [lR rR])
+ [(\ left compose lL lR)
+ (\ right compose rL rR)])))
diff --git a/stdlib/source/library/lux/abstract/order.lux b/stdlib/source/library/lux/abstract/order.lux
new file mode 100644
index 000000000..3eaafaf3a
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/order.lux
@@ -0,0 +1,58 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ ["." function]]]]
+ [//
+ ["." equivalence (#+ Equivalence)]
+ [functor
+ ["." contravariant]]])
+
+(interface: #export (Order a)
+ {#.doc "A signature for types that possess some sense of ordering among their elements."}
+
+ (: (Equivalence a)
+ &equivalence)
+
+ (: (-> a a Bit)
+ <)
+ )
+
+(type: #export (Comparison a)
+ (-> (Order a) a a Bit))
+
+(def: #export (<= order parameter subject)
+ Comparison
+ (or (\ order < parameter subject)
+ (\ order = parameter subject)))
+
+(def: #export (> order parameter subject)
+ Comparison
+ (\ order < subject parameter))
+
+(def: #export (>= order parameter subject)
+ Comparison
+ (or (\ order < subject parameter)
+ (\ order = subject parameter)))
+
+(type: #export (Choice a)
+ (-> (Order a) a a a))
+
+(def: #export (min order x y)
+ Choice
+ (if (\ order < y x) x y))
+
+(def: #export (max order x y)
+ Choice
+ (if (\ order < y x) y x))
+
+(implementation: #export functor
+ (contravariant.Functor Order)
+
+ (def: (map f order)
+ (implementation
+ (def: &equivalence
+ (\ equivalence.functor map f (\ order &equivalence)))
+
+ (def: (< reference sample)
+ (\ order < (f reference) (f sample))))))
diff --git a/stdlib/source/library/lux/abstract/predicate.lux b/stdlib/source/library/lux/abstract/predicate.lux
new file mode 100644
index 000000000..205ccc316
--- /dev/null
+++ b/stdlib/source/library/lux/abstract/predicate.lux
@@ -0,0 +1,61 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ ["." function]]]]
+ [//
+ [monoid (#+ Monoid)]
+ [functor
+ ["." contravariant]]])
+
+(type: #export (Predicate a)
+ (-> a Bit))
+
+(template [<identity_name> <identity_value> <composition_name> <composition>]
+ [(def: #export <identity_name>
+ Predicate
+ (function.constant <identity_value>))
+
+ (def: #export (<composition_name> left right)
+ (All [a] (-> (Predicate a) (Predicate a) (Predicate a)))
+ (function (_ value)
+ (<composition> (left value)
+ (right value))))]
+
+ [none #0 unite or]
+ [all #1 intersect and]
+ )
+
+(template [<name> <identity> <composition>]
+ [(implementation: #export <name>
+ (All [a] (Monoid (Predicate a)))
+
+ (def: identity <identity>)
+ (def: compose <composition>))]
+
+ [union ..none ..unite]
+ [intersection ..all ..intersect]
+ )
+
+(def: #export (complement predicate)
+ (All [a] (-> (Predicate a) (Predicate a)))
+ (|>> predicate not))
+
+(def: #export (difference sub base)
+ (All [a] (-> (Predicate a) (Predicate a) (Predicate a)))
+ (function (_ value)
+ (and (base value)
+ (not (sub value)))))
+
+(def: #export (rec predicate)
+ (All [a]
+ (-> (-> (Predicate a) (Predicate a))
+ (Predicate a)))
+ (function (recur input)
+ (predicate recur input)))
+
+(implementation: #export functor
+ (contravariant.Functor Predicate)
+
+ (def: (map f fb)
+ (|>> f fb)))
diff --git a/stdlib/source/library/lux/control/concatenative.lux b/stdlib/source/library/lux/control/concatenative.lux
new file mode 100644
index 000000000..2143a0c97
--- /dev/null
+++ b/stdlib/source/library/lux/control/concatenative.lux
@@ -0,0 +1,331 @@
+(.module:
+ [library
+ [lux (#- Alias if loop)
+ ["." meta]
+ [abstract
+ ["." monad]]
+ [data
+ ["." maybe ("#\." monad)]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." fold functor)]]]
+ ["." macro (#+ with_gensyms)
+ ["." code]
+ [syntax (#+ syntax:)
+ ["|.|" export]
+ ["|.|" annotations]]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]
+ ["r" rev]
+ ["f" frac]]]]]
+ [//
+ ["<>" parser ("#\." monad)
+ ["<c>" code (#+ Parser)]]])
+
+(type: Alias [Text Code])
+
+(type: Stack
+ {#bottom (Maybe Nat)
+ #top (List Code)})
+
+(def: aliases^
+ (Parser (List Alias))
+ (|> (<>.and <c>.local_identifier <c>.any)
+ <>.some
+ <c>.record
+ (<>.default (list))))
+
+(def: bottom^
+ (Parser Nat)
+ (<c>.form (<>.after (<c>.this! (` #.Parameter)) <c>.nat)))
+
+(def: stack^
+ (Parser Stack)
+ (<>.either (<>.and (<>.maybe bottom^)
+ (<c>.tuple (<>.some <c>.any)))
+ (<>.and (|> bottom^ (<>\map (|>> #.Some)))
+ (<>\wrap (list)))))
+
+(def: (stack_fold tops bottom)
+ (-> (List Code) Code Code)
+ (list\fold (function (_ top bottom)
+ (` [(~ bottom) (~ top)]))
+ bottom
+ tops))
+
+(def: (singleton expander)
+ (-> (Meta (List Code)) (Meta Code))
+ (monad.do meta.monad
+ [expansion expander]
+ (case expansion
+ (#.Cons singleton #.Nil)
+ (wrap singleton)
+
+ _
+ (meta.fail (format "Cannot expand to more than a single AST/Code node:" text.new_line
+ (|> expansion (list\map %.code) (text.join_with " ")))))))
+
+(syntax: #export (=> {aliases aliases^}
+ {inputs stack^}
+ {outputs stack^})
+ (let [de_alias (function (_ aliased)
+ (list\fold (function (_ [from to] pre)
+ (code.replace (code.local_identifier from) to pre))
+ aliased
+ aliases))]
+ (case [(|> inputs (get@ #bottom) (maybe\map (|>> code.nat (~) #.Parameter (`))))
+ (|> outputs (get@ #bottom) (maybe\map (|>> code.nat (~) #.Parameter (`))))]
+ [(#.Some bottomI) (#.Some bottomO)]
+ (monad.do meta.monad
+ [inputC (singleton (macro.expand_all (stack_fold (get@ #top inputs) bottomI)))
+ outputC (singleton (macro.expand_all (stack_fold (get@ #top outputs) bottomO)))]
+ (wrap (list (` (-> (~ (de_alias inputC))
+ (~ (de_alias outputC)))))))
+
+ [?bottomI ?bottomO]
+ (with_gensyms [g!stack]
+ (monad.do meta.monad
+ [inputC (singleton (macro.expand_all (stack_fold (get@ #top inputs) (maybe.default g!stack ?bottomI))))
+ outputC (singleton (macro.expand_all (stack_fold (get@ #top outputs) (maybe.default g!stack ?bottomO))))]
+ (wrap (list (` (All [(~ g!stack)]
+ (-> (~ (de_alias inputC))
+ (~ (de_alias outputC))))))))))))
+
+(def: begin! Any [])
+
+(def: end!
+ (All [a] (-> [Any a] a))
+ (function (_ [_ top])
+ top))
+
+(syntax: #export (||> {commands (<>.some <c>.any)})
+ (wrap (list (` (|> (~! ..begin!) (~+ commands) ((~! ..end!)))))))
+
+(syntax: #export (word:
+ {export |export|.parser}
+ {name <c>.local_identifier}
+ {annotations (<>.default |annotations|.empty |annotations|.parser)}
+ type
+ {commands (<>.some <c>.any)})
+ (wrap (list (` (def: (~+ (|export|.format export)) (~ (code.local_identifier name))
+ (~ (|annotations|.format annotations))
+ (~ type)
+ (|>> (~+ commands)))))))
+
+(syntax: #export (apply {arity (|> <c>.nat (<>.filter (n.> 0)))})
+ (with_gensyms [g! g!func g!stack g!output]
+ (monad.do {! meta.monad}
+ [g!inputs (|> (macro.gensym "input") (list.repeat arity) (monad.seq !))]
+ (wrap (list (` (: (All [(~+ g!inputs) (~ g!output)]
+ (-> (-> (~+ g!inputs) (~ g!output))
+ (=> [(~+ g!inputs)] [(~ g!output)])))
+ (function ((~ g!) (~ g!func))
+ (function ((~ g!) (~ (stack_fold g!inputs g!stack)))
+ [(~ g!stack) ((~ g!func) (~+ g!inputs))])))))))))
+
+(def: #export apply/1 (apply 1))
+(def: #export apply/2 (apply 2))
+(def: #export apply/3 (apply 3))
+(def: #export apply/4 (apply 4))
+(def: #export apply/5 (apply 5))
+(def: #export apply/6 (apply 6))
+(def: #export apply/7 (apply 7))
+(def: #export apply/8 (apply 8))
+
+(def: #export (push x)
+ (All [a] (-> a (=> [] [a])))
+ (function (_ stack)
+ [stack x]))
+
+(def: #export drop
+ (All [t] (=> [t] []))
+ (function (_ [stack top])
+ stack))
+
+(def: #export nip
+ (All [_ a] (=> [_ a] [a]))
+ (function (_ [[stack _] top])
+ [stack top]))
+
+(def: #export dup
+ (All [a] (=> [a] [a a]))
+ (function (_ [stack top])
+ [[stack top] top]))
+
+(def: #export swap
+ (All [a b] (=> [a b] [b a]))
+ (function (_ [[stack l] r])
+ [[stack r] l]))
+
+(def: #export rotL
+ (All [a b c] (=> [a b c] [b c a]))
+ (function (_ [[[stack a] b] c])
+ [[[stack b] c] a]))
+
+(def: #export rotR
+ (All [a b c] (=> [a b c] [c a b]))
+ (function (_ [[[stack a] b] c])
+ [[[stack c] a] b]))
+
+(def: #export &&
+ (All [a b] (=> [a b] [(& a b)]))
+ (function (_ [[stack l] r])
+ [stack [l r]]))
+
+(def: #export ||L
+ (All [a b] (=> [a] [(| a b)]))
+ (function (_ [stack l])
+ [stack (0 #0 l)]))
+
+(def: #export ||R
+ (All [a b] (=> [b] [(| a b)]))
+ (function (_ [stack r])
+ [stack (0 #1 r)]))
+
+(template [<input> <output> <word> <func>]
+ [(def: #export <word>
+ (=> [<input> <input>] [<output>])
+ (function (_ [[stack subject] param])
+ [stack (<func> param subject)]))]
+
+ [Nat Nat n/+ n.+]
+ [Nat Nat n/- n.-]
+ [Nat Nat n/* n.*]
+ [Nat Nat n// n./]
+ [Nat Nat n/% n.%]
+ [Nat Bit n/= n.=]
+ [Nat Bit n/< n.<]
+ [Nat Bit n/<= n.<=]
+ [Nat Bit n/> n.>]
+ [Nat Bit n/>= n.>=]
+
+ [Int Int i/+ i.+]
+ [Int Int i/- i.-]
+ [Int Int i/* i.*]
+ [Int Int i// i./]
+ [Int Int i/% i.%]
+ [Int Bit i/= i.=]
+ [Int Bit i/< i.<]
+ [Int Bit i/<= i.<=]
+ [Int Bit i/> i.>]
+ [Int Bit i/>= i.>=]
+
+ [Rev Rev r/+ r.+]
+ [Rev Rev r/- r.-]
+ [Rev Rev r/* r.*]
+ [Rev Rev r// r./]
+ [Rev Rev r/% r.%]
+ [Rev Bit r/= r.=]
+ [Rev Bit r/< r.<]
+ [Rev Bit r/<= r.<=]
+ [Rev Bit r/> r.>]
+ [Rev Bit r/>= r.>=]
+
+ [Frac Frac f/+ f.+]
+ [Frac Frac f/- f.-]
+ [Frac Frac f/* f.*]
+ [Frac Frac f// f./]
+ [Frac Frac f/% f.%]
+ [Frac Bit f/= f.=]
+ [Frac Bit f/< f.<]
+ [Frac Bit f/<= f.<=]
+ [Frac Bit f/> f.>]
+ [Frac Bit f/>= f.>=]
+ )
+
+(def: #export if
+ (All [___a ___z]
+ (=> {then (=> ___a ___z)
+ else (=> ___a ___z)}
+ ___a [Bit then else] ___z))
+ (function (_ [[[stack test] then] else])
+ (.if test
+ (then stack)
+ (else stack))))
+
+(def: #export call
+ (All [___a ___z]
+ (=> {quote (=> ___a ___z)}
+ ___a [quote] ___z))
+ (function (_ [stack quote])
+ (quote stack)))
+
+(def: #export loop
+ (All [___]
+ (=> {test (=> ___ ___ [Bit])}
+ ___ [test] ___))
+ (function (loop [stack pred])
+ (let [[stack' verdict] (pred stack)]
+ (.if verdict
+ (loop [stack' pred])
+ stack'))))
+
+(def: #export dip
+ (All [___ a]
+ (=> ___ [a (=> ___ ___)]
+ ___ [a]))
+ (function (_ [[stack a] quote])
+ [(quote stack) a]))
+
+(def: #export dip/2
+ (All [___ a b]
+ (=> ___ [a b (=> ___ ___)]
+ ___ [a b]))
+ (function (_ [[[stack a] b] quote])
+ [[(quote stack) a] b]))
+
+(def: #export do
+ (All [___a ___z]
+ (=> {body (=> ___a ___z)
+ pred (=> ___z ___a [Bit])}
+ ___a [pred body]
+ ___z [pred body]))
+ (function (_ [[stack pred] body])
+ [[(body stack) pred] body]))
+
+(def: #export while
+ (All [___a ___z]
+ (=> {body (=> ___z ___a)
+ pred (=> ___a ___z [Bit])}
+ ___a [pred body]
+ ___z))
+ (function (while [[stack pred] body])
+ (let [[stack' verdict] (pred stack)]
+ (.if verdict
+ (while [[(body stack') pred] body])
+ stack'))))
+
+(def: #export compose
+ (All [___a ___ ___z]
+ (=> [(=> ___a ___) (=> ___ ___z)]
+ [(=> ___a ___z)]))
+ (function (_ [[stack f] g])
+ [stack (|>> f g)]))
+
+(def: #export curry
+ (All [___a ___z a]
+ (=> ___a [a (=> ___a [a] ___z)]
+ ___a [(=> ___a ___z)]))
+ (function (_ [[stack arg] quote])
+ [stack (|>> (push arg) quote)]))
+
+(word: #export when
+ (All [___]
+ (=> {body (=> ___ ___)}
+ ___ [Bit body]
+ ___))
+ swap
+ (push (|>> call))
+ (push (|>> drop))
+ if)
+
+(word: #export ?
+ (All [a]
+ (=> [Bit a a] [a]))
+ rotL
+ (push (|>> drop))
+ (push (|>> nip))
+ if)
diff --git a/stdlib/source/library/lux/control/concurrency/actor.lux b/stdlib/source/library/lux/control/concurrency/actor.lux
new file mode 100644
index 000000000..a12e65471
--- /dev/null
+++ b/stdlib/source/library/lux/control/concurrency/actor.lux
@@ -0,0 +1,390 @@
+(.module: {#.doc "The actor model of concurrency."}
+ [library
+ [lux #*
+ [abstract
+ monad]
+ [control
+ [pipe (#+ case>)]
+ ["." function]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO io)]
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." monoid monad fold)]]]
+ ["." macro (#+ with_gensyms)
+ ["." code]
+ [syntax (#+ syntax:)
+ ["|.|" input]
+ ["|.|" export]
+ ["|.|" annotations]]]
+ [math
+ [number
+ ["n" nat]]]
+ ["." meta (#+ monad)
+ ["." annotation]]
+ [type (#+ :share)
+ ["." abstract (#+ abstract: :representation :abstraction)]]]]
+ [//
+ ["." atom (#+ Atom atom)]
+ ["." promise (#+ Promise Resolver) ("#\." monad)]
+ ["." frp (#+ Channel)]])
+
+(exception: #export poisoned)
+(exception: #export dead)
+
+(with_expansions
+ [<Mail> (as_is (-> s (Actor s) (Promise (Try s))))
+ <Obituary> (as_is [Text s (List <Mail>)])
+ <Mailbox> (as_is (Rec Mailbox
+ [(Promise [<Mail> Mailbox])
+ (Resolver [<Mail> Mailbox])]))]
+
+ (def: (pending [read write])
+ (All [a]
+ (-> (Rec Mailbox
+ [(Promise [a Mailbox])
+ (Resolver [a Mailbox])])
+ (IO (List a))))
+ (do {! io.monad}
+ [current (promise.poll read)]
+ (case current
+ (#.Some [head tail])
+ (\ ! map (|>> (#.Cons head))
+ (pending tail))
+
+ #.None
+ (wrap #.Nil))))
+
+ (abstract: #export (Actor s)
+ {#obituary [(Promise <Obituary>)
+ (Resolver <Obituary>)]
+ #mailbox (Atom <Mailbox>)}
+
+ (type: #export (Mail s)
+ <Mail>)
+
+ (type: #export (Obituary s)
+ <Obituary>)
+
+ (type: #export (Behavior o s)
+ {#.doc "An actor's behavior when mail is received and when a fatal error occurs."}
+ {#on_init (-> o s)
+ #on_mail (-> (Mail s) s (Actor s) (Promise (Try s)))})
+
+ (def: #export (spawn! behavior init)
+ {#.doc "Given a behavior and initial state, spawns an actor and returns it."}
+ (All [o s] (-> (Behavior o s) o (IO (Actor s))))
+ (io (let [[on_init on_mail] behavior
+ self (:share [o s]
+ (Behavior o s)
+ behavior
+
+ (Actor s)
+ (:abstraction {#obituary (promise.promise [])
+ #mailbox (atom (promise.promise []))}))
+ process (loop [state (on_init init)
+ [|mailbox| _] (io.run (atom.read (get@ #mailbox (:representation self))))]
+ (do {! promise.monad}
+ [[head tail] |mailbox|
+ ?state' (on_mail head state self)]
+ (case ?state'
+ (#try.Failure error)
+ (let [[_ resolve] (get@ #obituary (:representation self))]
+ (exec (io.run
+ (do io.monad
+ [pending (..pending tail)]
+ (resolve [error state (#.Cons head pending)])))
+ (wrap [])))
+
+ (#try.Success state')
+ (recur state' tail))))]
+ self)))
+
+ (def: #export (alive? actor)
+ (All [s] (-> (Actor s) (IO Bit)))
+ (let [[obituary _] (get@ #obituary (:representation actor))]
+ (|> obituary
+ promise.poll
+ (\ io.functor map
+ (|>> (case> #.None
+ yes
+
+ _
+ no))))))
+
+ (def: #export (obituary actor)
+ (All [s] (-> (Actor s) (IO (Maybe (Obituary s)))))
+ (let [[obituary _] (get@ #obituary (:representation actor))]
+ (promise.poll obituary)))
+
+ (def: #export await
+ (All [s] (-> (Actor s) (Promise (Obituary s))))
+ (|>> :representation
+ (get@ #obituary)
+ product.left))
+
+ (def: #export (mail! mail actor)
+ {#.doc "Send mail to an actor.."}
+ (All [s] (-> (Mail s) (Actor s) (IO (Try Any))))
+ (do {! io.monad}
+ [alive? (..alive? actor)]
+ (if alive?
+ (let [entry [mail (promise.promise [])]]
+ (do !
+ [|mailbox|&resolve (atom.read (get@ #mailbox (:representation actor)))]
+ (loop [[|mailbox| resolve] |mailbox|&resolve]
+ (do !
+ [|mailbox| (promise.poll |mailbox|)]
+ (case |mailbox|
+ #.None
+ (do !
+ [resolved? (resolve entry)]
+ (if resolved?
+ (do !
+ [_ (atom.write (product.right entry) (get@ #mailbox (:representation actor)))]
+ (wrap (exception.return [])))
+ (recur |mailbox|&resolve)))
+
+ (#.Some [_ |mailbox|'])
+ (recur |mailbox|'))))))
+ (wrap (exception.throw ..dead [])))))
+
+ (type: #export (Message s o)
+ (-> s (Actor s) (Promise (Try [s o]))))
+
+ (def: (mail message)
+ (All [s o] (-> (Message s o) [(Promise (Try o)) (Mail s)]))
+ (let [[promise resolve] (:share [s o]
+ (Message s o)
+ message
+
+ [(Promise (Try o))
+ (Resolver (Try o))]
+ (promise.promise []))]
+ [promise
+ (function (_ state self)
+ (do {! promise.monad}
+ [outcome (message state self)]
+ (case outcome
+ (#try.Success [state' return])
+ (exec (io.run (resolve (#try.Success return)))
+ (promise.resolved (#try.Success state')))
+
+ (#try.Failure error)
+ (exec (io.run (resolve (#try.Failure error)))
+ (promise.resolved (#try.Failure error))))))]))
+
+ (def: #export (tell! message actor)
+ {#.doc "Communicate with an actor through message passing."}
+ (All [s o] (-> (Message s o) (Actor s) (Promise (Try o))))
+ (let [[promise mail] (..mail message)]
+ (do promise.monad
+ [outcome (promise.future (..mail! mail actor))]
+ (case outcome
+ (#try.Success)
+ promise
+
+ (#try.Failure error)
+ (wrap (#try.Failure error))))))
+ )
+ )
+
+(def: (default_on_mail mail state self)
+ (All [s] (-> (Mail s) s (Actor s) (Promise (Try s))))
+ (mail state self))
+
+(def: #export default
+ (All [s] (Behavior s s))
+ {#on_init function.identity
+ #on_mail ..default_on_mail})
+
+(def: #export (poison! actor)
+ {#.doc (doc "Kills the actor by sending mail that will kill it upon processing,"
+ "but allows the actor to handle previous mail.")}
+ (All [s] (-> (Actor s) (IO (Try Any))))
+ (..mail! (function (_ state self)
+ (promise.resolved (exception.throw ..poisoned [])))
+ actor))
+
+(def: actor_decl^
+ (Parser [Text (List Text)])
+ (<>.either (<code>.form (<>.and <code>.local_identifier (<>.some <code>.local_identifier)))
+ (<>.and <code>.local_identifier (\ <>.monad wrap (list)))))
+
+(type: On_MailC
+ [[Text Text Text] Code])
+
+(type: BehaviorC
+ [(Maybe On_MailC) (List Code)])
+
+(def: argument
+ (Parser Text)
+ <code>.local_identifier)
+
+(def: behavior^
+ (Parser BehaviorC)
+ (let [on_mail_args ($_ <>.and ..argument ..argument ..argument)]
+ ($_ <>.and
+ (<>.maybe (<code>.form (<>.and (<code>.form (<>.after (<code>.this! (' on_mail)) on_mail_args))
+ <code>.any)))
+ (<>.some <code>.any))))
+
+(def: (on_mail g!_ ?on_mail)
+ (-> Code (Maybe On_MailC) Code)
+ (case ?on_mail
+ #.None
+ (` (~! ..default_on_mail))
+
+ (#.Some [[mailN stateN selfN] bodyC])
+ (` (function ((~ g!_)
+ (~ (code.local_identifier mailN))
+ (~ (code.local_identifier stateN))
+ (~ (code.local_identifier selfN)))
+ (~ bodyC)))))
+
+(with_expansions [<examples> (as_is (actor: #export (Stack a)
+ (List a)
+
+ ((on_mail mail state self)
+ (do (try.with promise.monad)
+ [#let [_ (log! "BEFORE")]
+ output (mail state self)
+ #let [_ (log! "AFTER")]]
+ (wrap output)))
+
+ (message: #export (push {value a} state self (List a))
+ (let [state' (#.Cons value state)]
+ (promise.resolved (#try.Success [state' state'])))))
+
+ (actor: #export Counter
+ Nat
+
+ (message: #export (count! {increment Nat} state self Any)
+ (let [state' (n.+ increment state)]
+ (promise.resolved (#try.Success [state' state']))))
+
+ (message: #export (read! state self Nat)
+ (promise.resolved (#try.Success [state state])))))]
+ (syntax: #export (actor:
+ {export |export|.parser}
+ {[name vars] actor_decl^}
+ {annotations (<>.default |annotations|.empty |annotations|.parser)}
+ state_type
+ {[?on_mail messages] behavior^})
+ {#.doc (doc "Defines an actor, with its behavior and internal state."
+ "Messages for the actor must be defined after the on_mail handler."
+ <examples>)}
+ (with_gensyms [g!_]
+ (do meta.monad
+ [g!type (macro.gensym (format name "_abstract_type"))
+ #let [g!actor (code.local_identifier name)
+ g!vars (list\map code.local_identifier vars)]]
+ (wrap (list (` ((~! abstract:) (~+ (|export|.format export)) ((~ g!type) (~+ g!vars))
+ (~ state_type)
+
+ (def: (~+ (|export|.format export)) (~ g!actor)
+ (All [(~+ g!vars)]
+ (..Behavior (~ state_type) ((~ g!type) (~+ g!vars))))
+ {#..on_init (|>> ((~! abstract.:abstraction) (~ g!type)))
+ #..on_mail (~ (..on_mail g!_ ?on_mail))})
+
+ (~+ messages))))))))
+
+ (syntax: #export (actor {[state_type init] (<code>.record (<>.and <code>.any <code>.any))}
+ {[?on_mail messages] behavior^})
+ (with_gensyms [g!_]
+ (wrap (list (` (: ((~! io.IO) (..Actor (~ state_type)))
+ (..spawn! (: (..Behavior (~ state_type) (~ state_type))
+ {#..on_init (|>>)
+ #..on_mail (~ (..on_mail g!_ ?on_mail))})
+ (: (~ state_type)
+ (~ init)))))))))
+
+ (type: Signature
+ {#vars (List Text)
+ #name Text
+ #inputs (List |input|.Input)
+ #state Text
+ #self Text
+ #output Code})
+
+ (def: signature^
+ (Parser Signature)
+ (<code>.form ($_ <>.and
+ (<>.default (list) (<code>.tuple (<>.some <code>.local_identifier)))
+ <code>.local_identifier
+ (<>.some |input|.parser)
+ <code>.local_identifier
+ <code>.local_identifier
+ <code>.any)))
+
+ (def: reference^
+ (Parser [Name (List Text)])
+ (<>.either (<code>.form (<>.and <code>.identifier (<>.some <code>.local_identifier)))
+ (<>.and <code>.identifier (\ <>.monad wrap (list)))))
+
+ (syntax: #export (message:
+ {export |export|.parser}
+ {signature signature^}
+ {annotations (<>.default |annotations|.empty |annotations|.parser)}
+ body)
+ {#.doc (doc "A message can access the actor's state through the state parameter."
+ "A message can also access the actor itself through the self parameter."
+ "A message's output must be a promise containing a 2-tuple with the updated state and a return value."
+ "A message may succeed or fail (in case of failure, the actor dies)."
+
+ <examples>)}
+ (with_gensyms [g!_ g!return]
+ (do meta.monad
+ [actor_scope abstract.current
+ #let [g!type (code.local_identifier (get@ #abstract.name actor_scope))
+ g!message (code.local_identifier (get@ #name signature))
+ g!actor_vars (get@ #abstract.type_vars actor_scope)
+ g!all_vars (|> signature (get@ #vars) (list\map code.local_identifier) (list\compose g!actor_vars))
+ g!inputsC (|> signature (get@ #inputs) (list\map product.left))
+ g!inputsT (|> signature (get@ #inputs) (list\map product.right))
+ g!state (|> signature (get@ #state) code.local_identifier)
+ g!self (|> signature (get@ #self) code.local_identifier)]]
+ (wrap (list (` (def: (~+ (|export|.format export)) ((~ g!message) (~+ g!inputsC))
+ (~ (|annotations|.format annotations))
+ (All [(~+ g!all_vars)]
+ (-> (~+ g!inputsT)
+ (..Message (~ (get@ #abstract.abstraction actor_scope))
+ (~ (get@ #output signature)))))
+ (function ((~ g!_) (~ g!state) (~ g!self))
+ (let [(~ g!state) (:as (~ (get@ #abstract.representation actor_scope))
+ (~ g!state))]
+ (|> (~ body)
+ (: ((~! promise.Promise) ((~! try.Try) [(~ (get@ #abstract.representation actor_scope))
+ (~ (get@ #output signature))])))
+ (:as ((~! promise.Promise) ((~! try.Try) [(~ (get@ #abstract.abstraction actor_scope))
+ (~ (get@ #output signature))]))))))))
+ ))))))
+
+(type: #export Stop
+ (IO Any))
+
+(def: continue! true)
+(def: stop! false)
+
+(def: #export (observe action channel actor)
+ (All [e s] (-> (-> e Stop (Mail s)) (Channel e) (Actor s) (IO Any)))
+ (let [signal (: (Atom Bit)
+ (atom.atom ..continue!))
+ stop (: Stop
+ (atom.write ..stop! signal))]
+ (frp.subscribe (function (_ event)
+ (do {! io.monad}
+ [continue? (atom.read signal)]
+ (if continue?
+ (do !
+ [outcome (..mail! (action event stop) actor)]
+ (wrap (try.to_maybe outcome)))
+ (wrap #.None))))
+ channel)))
diff --git a/stdlib/source/library/lux/control/concurrency/atom.lux b/stdlib/source/library/lux/control/concurrency/atom.lux
new file mode 100644
index 000000000..057bfd5b2
--- /dev/null
+++ b/stdlib/source/library/lux/control/concurrency/atom.lux
@@ -0,0 +1,103 @@
+(.module:
+ [library
+ [lux #*
+ ["." ffi]
+ ["@" target]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." function]
+ ["." io (#- run) ("#\." functor)]]
+ [data
+ ["." product]
+ [collection
+ ["." array]]]
+ [type
+ abstract]]])
+
+(with_expansions [<jvm> (as_is (ffi.import: (java/util/concurrent/atomic/AtomicReference a)
+ ["#::."
+ (new [a])
+ (get [] a)
+ (compareAndSet [a a] boolean)]))]
+ (for {@.old <jvm>
+ @.jvm <jvm>}
+ (as_is)))
+
+(with_expansions [<new> (for {@.js "js array new"
+ @.python "python array new"
+ @.lua "lua array new"
+ @.ruby "ruby array new"
+ @.php "php array new"
+ @.scheme "scheme array new"}
+ (as_is))
+ <write> (for {@.js "js array write"
+ @.python "python array write"
+ @.lua "lua array write"
+ @.ruby "ruby array write"
+ @.php "php array write"
+ @.scheme "scheme array write"}
+ (as_is))
+
+ <read> (for {@.js "js array read"
+ @.python "python array read"
+ @.lua "lua array read"
+ @.ruby "ruby array read"
+ @.php "php array read"
+ @.scheme "scheme array read"}
+ (as_is))]
+ (abstract: #export (Atom a)
+ (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference a)]
+ (for {@.old <jvm>
+ @.jvm <jvm>}
+ (array.Array a)))
+
+ {#.doc "Atomic references that are safe to mutate concurrently."}
+
+ (def: #export (atom value)
+ (All [a] (-> a (Atom a)))
+ (:abstraction (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::new value)]
+ (for {@.old <jvm>
+ @.jvm <jvm>}
+ (<write> 0 value (<new> 1))))))
+
+ (def: #export (read atom)
+ (All [a] (-> (Atom a) (IO a)))
+ (io (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::get (:representation atom))]
+ (for {@.old <jvm>
+ @.jvm <jvm>}
+ (<read> 0 (:representation atom))))))
+
+ (def: #export (compare_and_swap current new atom)
+ {#.doc (doc "Only mutates an atom if you can present its current value."
+ "That guarantees that atom was not updated since you last read from it.")}
+ (All [a] (-> a a (Atom a) (IO Bit)))
+ (io (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::compareAndSet current new (:representation atom))]
+ (for {@.old <jvm>
+ @.jvm <jvm>}
+ (let [old (<read> 0 (:representation atom))]
+ (if (is? old current)
+ (exec (<write> 0 new (:representation atom))
+ true)
+ false))))))
+ ))
+
+(def: #export (update f atom)
+ {#.doc (doc "Updates an atom by applying a function to its current value."
+ "If it fails to update it (because some other process wrote to it first), it will retry until it succeeds."
+ "The retries will be done with the new values of the atom, as they show up.")}
+ (All [a] (-> (-> a a) (Atom a) (IO [a a])))
+ (loop [_ []]
+ (do io.monad
+ [old (read atom)
+ #let [new (f old)]
+ swapped? (..compare_and_swap old new atom)]
+ (if swapped?
+ (wrap [old new])
+ (recur [])))))
+
+(def: #export (write value atom)
+ (All [a] (-> a (Atom a) (IO a)))
+ (|> atom
+ (..update (function.constant value))
+ (io\map product.left)))
diff --git a/stdlib/source/library/lux/control/concurrency/frp.lux b/stdlib/source/library/lux/control/concurrency/frp.lux
new file mode 100644
index 000000000..416b8c7c4
--- /dev/null
+++ b/stdlib/source/library/lux/control/concurrency/frp.lux
@@ -0,0 +1,296 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [predicate (#+ Predicate)]
+ [equivalence (#+ Equivalence)]
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ ["." monad (#+ Monad do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO io)]]
+ [data
+ ["." maybe ("#\." functor)]]
+ [type (#+ :share)
+ abstract]]]
+ [//
+ ["." atom (#+ Atom)]
+ ["." promise (#+ Promise) ("#\." functor)]])
+
+(type: #export (Channel a)
+ {#.doc "An asynchronous channel to distribute values."}
+ (Promise (Maybe [a (Channel a)])))
+
+(exception: #export channel_is_already_closed)
+
+(interface: #export (Sink a)
+ (: (IO (Try Any))
+ close)
+ (: (-> a (IO (Try Any)))
+ feed))
+
+(def: (sink resolve)
+ (All [a]
+ (-> (promise.Resolver (Maybe [a (Channel a)]))
+ (Sink a)))
+ (let [sink (atom.atom resolve)]
+ (implementation
+ (def: close
+ (loop [_ []]
+ (do {! io.monad}
+ [current (atom.read sink)
+ stopped? (current #.None)]
+ (if stopped?
+ ## I closed the sink.
+ (wrap (exception.return []))
+ ## Someone else interacted with the sink.
+ (do !
+ [latter (atom.read sink)]
+ (if (is? current latter)
+ ## Someone else closed the sink.
+ (wrap (exception.throw ..channel_is_already_closed []))
+ ## Someone else fed the sink while I was closing it.
+ (recur [])))))))
+
+ (def: (feed value)
+ (loop [_ []]
+ (do {! io.monad}
+ [current (atom.read sink)
+ #let [[next resolve_next] (:share [a]
+ (promise.Resolver (Maybe [a (Channel a)]))
+ current
+
+ [(Promise (Maybe [a (Channel a)]))
+ (promise.Resolver (Maybe [a (Channel a)]))]
+ (promise.promise []))]
+ fed? (current (#.Some [value next]))]
+ (if fed?
+ ## I fed the sink.
+ (do !
+ [_ (atom.compare_and_swap current resolve_next sink)]
+ (wrap (exception.return [])))
+ ## Someone else interacted with the sink.
+ (do !
+ [latter (atom.read sink)]
+ (if (is? current latter)
+ ## Someone else closed the sink while I was feeding it.
+ (wrap (exception.throw ..channel_is_already_closed []))
+ ## Someone else fed the sink.
+ (recur []))))))))))
+
+(def: #export (channel _)
+ (All [a] (-> Any [(Channel a) (Sink a)]))
+ (let [[promise resolve] (promise.promise [])]
+ [promise (..sink resolve)]))
+
+(implementation: #export functor
+ (Functor Channel)
+
+ (def: (map f)
+ (promise\map
+ (maybe\map
+ (function (_ [head tail])
+ [(f head) (map f tail)])))))
+
+(implementation: #export apply
+ (Apply Channel)
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (do promise.monad
+ [cons_f ff
+ cons_a fa]
+ (case [cons_f cons_a]
+ [(#.Some [head_f tail_f]) (#.Some [head_a tail_a])]
+ (wrap (#.Some [(head_f head_a) (apply tail_f tail_a)]))
+
+ _
+ (wrap #.None)))))
+
+(def: empty
+ Channel
+ (promise.resolved #.None))
+
+(implementation: #export monad
+ (Monad Channel)
+
+ (def: &functor ..functor)
+
+ (def: (wrap a)
+ (promise.resolved (#.Some [a ..empty])))
+
+ (def: (join mma)
+ (let [[output sink] (channel [])]
+ (exec (: (Promise Any)
+ (loop [mma mma]
+ (do {! promise.monad}
+ [?mma mma]
+ (case ?mma
+ (#.Some [ma mma'])
+ (do !
+ [_ (loop [ma ma]
+ (do !
+ [?ma ma]
+ (case ?ma
+ (#.Some [a ma'])
+ (exec (io.run (\ sink feed a))
+ (recur ma'))
+
+ #.None
+ (wrap []))))]
+ (recur mma'))
+
+ #.None
+ (wrap (: Any (io.run (\ sink close))))))))
+ output))))
+
+(type: #export (Subscriber a)
+ (-> a (IO (Maybe Any))))
+
+(def: #export (subscribe subscriber channel)
+ (All [a] (-> (Subscriber a) (Channel a) (IO Any)))
+ (io (exec (: (Promise Any)
+ (loop [channel channel]
+ (do promise.monad
+ [cons channel]
+ (case cons
+ (#.Some [head tail])
+ (case (io.run (subscriber head))
+ (#.Some _)
+ (recur tail)
+
+ #.None
+ (wrap []))
+
+ #.None
+ (wrap [])))))
+ [])))
+
+(def: #export (filter pass? channel)
+ (All [a] (-> (Predicate a) (Channel a) (Channel a)))
+ (do promise.monad
+ [cons channel]
+ (case cons
+ (#.Some [head tail])
+ (let [tail' (filter pass? tail)]
+ (if (pass? head)
+ (wrap (#.Some [head tail']))
+ tail'))
+
+ #.None
+ (wrap #.None))))
+
+(def: #export (from_promise promise)
+ (All [a] (-> (Promise a) (Channel a)))
+ (promise\map (function (_ value)
+ (#.Some [value ..empty]))
+ promise))
+
+(def: #export (fold f init channel)
+ {#.doc "Asynchronous fold over channels."}
+ (All [a b]
+ (-> (-> b a (Promise a)) a (Channel b)
+ (Promise a)))
+ (do {! promise.monad}
+ [cons channel]
+ (case cons
+ #.None
+ (wrap init)
+
+ (#.Some [head tail])
+ (do !
+ [init' (f head init)]
+ (fold f init' tail)))))
+
+(def: #export (folds f init channel)
+ {#.doc "A channel of folds."}
+ (All [a b]
+ (-> (-> b a (Promise a)) a (Channel b)
+ (Channel a)))
+ (do {! promise.monad}
+ [cons channel]
+ (case cons
+ #.None
+ (wrap (#.Some [init (wrap #.None)]))
+
+ (#.Some [head tail])
+ (do !
+ [init' (f head init)]
+ (wrap (#.Some [init (folds f init' tail)]))))))
+
+(def: #export (poll milli_seconds action)
+ (All [a]
+ (-> Nat (IO a) [(Channel a) (Sink a)]))
+ (let [[output sink] (channel [])]
+ (exec (io.run (loop [_ []]
+ (do io.monad
+ [value action
+ _ (\ sink feed value)]
+ (promise.await recur (promise.wait milli_seconds)))))
+ [output sink])))
+
+(def: #export (periodic milli_seconds)
+ (-> Nat [(Channel Any) (Sink Any)])
+ (..poll milli_seconds (io [])))
+
+(def: #export (iterate f init)
+ (All [s o] (-> (-> s (Promise (Maybe [s o]))) s (Channel o)))
+ (do promise.monad
+ [?next (f init)]
+ (case ?next
+ (#.Some [state output])
+ (wrap (#.Some [output (iterate f state)]))
+
+ #.None
+ (wrap #.None))))
+
+(def: (distinct' equivalence previous channel)
+ (All [a] (-> (Equivalence a) a (Channel a) (Channel a)))
+ (do promise.monad
+ [cons channel]
+ (case cons
+ (#.Some [head tail])
+ (if (\ equivalence = previous head)
+ (distinct' equivalence previous tail)
+ (wrap (#.Some [head (distinct' equivalence head tail)])))
+
+ #.None
+ (wrap #.None))))
+
+(def: #export (distinct equivalence channel)
+ (All [a] (-> (Equivalence a) (Channel a) (Channel a)))
+ (do promise.monad
+ [cons channel]
+ (case cons
+ (#.Some [head tail])
+ (wrap (#.Some [head (distinct' equivalence head tail)]))
+
+ #.None
+ (wrap #.None))))
+
+(def: #export (consume channel)
+ {#.doc "Reads the entirety of a channel's content and returns it as a list."}
+ (All [a] (-> (Channel a) (Promise (List a))))
+ (do {! promise.monad}
+ [cons channel]
+ (case cons
+ (#.Some [head tail])
+ (\ ! map (|>> (#.Cons head))
+ (consume tail))
+
+ #.None
+ (wrap #.Nil))))
+
+(def: #export (sequential milli_seconds values)
+ (All [a] (-> Nat (List a) (Channel a)))
+ (case values
+ #.Nil
+ ..empty
+
+ (#.Cons head tail)
+ (promise.resolved (#.Some [head (do promise.monad
+ [_ (promise.wait milli_seconds)]
+ (sequential milli_seconds tail))]))))
diff --git a/stdlib/source/library/lux/control/concurrency/promise.lux b/stdlib/source/library/lux/control/concurrency/promise.lux
new file mode 100644
index 000000000..ad94bbff8
--- /dev/null
+++ b/stdlib/source/library/lux/control/concurrency/promise.lux
@@ -0,0 +1,200 @@
+(.module:
+ [library
+ [lux (#- and or)
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ ["." monad (#+ Monad do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." function]
+ ["." io (#+ IO io)]]
+ [data
+ ["." product]]
+ [type (#+ :share)
+ abstract]]]
+ [//
+ ["." thread]
+ ["." atom (#+ Atom atom)]])
+
+(abstract: #export (Promise a)
+ (Atom [(Maybe a) (List (-> a (IO Any)))])
+
+ {#.doc "Represents values produced by asynchronous computations (unlike IO, which is synchronous)."}
+
+ (type: #export (Resolver a)
+ (-> a (IO Bit)))
+
+ (def: (resolver promise)
+ {#.doc "Sets an promise's value if it has not been done yet."}
+ (All [a] (-> (Promise a) (Resolver a)))
+ (function (resolve value)
+ (let [promise (:representation promise)]
+ (do {! io.monad}
+ [(^@ old [_value _observers]) (atom.read promise)]
+ (case _value
+ (#.Some _)
+ (wrap #0)
+
+ #.None
+ (do !
+ [#let [new [(#.Some value) #.None]]
+ succeeded? (atom.compare_and_swap old new promise)]
+ (if succeeded?
+ (do !
+ [_ (monad.map ! (function (_ f) (f value))
+ _observers)]
+ (wrap #1))
+ (resolve value))))))))
+
+ (def: #export (resolved value)
+ (All [a] (-> a (Promise a)))
+ (:abstraction (atom [(#.Some value) (list)])))
+
+ (def: #export (promise _)
+ (All [a] (-> Any [(Promise a) (Resolver a)]))
+ (let [promise (:abstraction (atom [#.None (list)]))]
+ [promise (..resolver promise)]))
+
+ (def: #export poll
+ {#.doc "Polls a promise's value."}
+ (All [a] (-> (Promise a) (IO (Maybe a))))
+ (|>> :representation
+ atom.read
+ (\ io.functor map product.left)))
+
+ (def: #export (await f promise)
+ (All [a] (-> (-> a (IO Any)) (Promise a) (IO Any)))
+ (do {! io.monad}
+ [#let [promise (:representation promise)]
+ (^@ old [_value _observers]) (atom.read promise)]
+ (case _value
+ (#.Some value)
+ (f value)
+
+ #.None
+ (let [new [_value (#.Cons f _observers)]]
+ (do !
+ [swapped? (atom.compare_and_swap old new promise)]
+ (if swapped?
+ (wrap [])
+ (await f (:abstraction promise))))))))
+ )
+
+(def: #export resolved?
+ {#.doc "Checks whether a promise's value has already been resolved."}
+ (All [a] (-> (Promise a) (IO Bit)))
+ (|>> ..poll
+ (\ io.functor map
+ (|>> (case> #.None
+ #0
+
+ (#.Some _)
+ #1)))))
+
+(implementation: #export functor
+ (Functor Promise)
+
+ (def: (map f fa)
+ (let [[fb resolve] (..promise [])]
+ (exec (io.run (..await (|>> f resolve) fa))
+ fb))))
+
+(implementation: #export apply
+ (Apply Promise)
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (let [[fb resolve] (..promise [])]
+ (exec (io.run (..await (function (_ f)
+ (..await (|>> f resolve) fa))
+ ff))
+ fb))))
+
+(implementation: #export monad
+ (Monad Promise)
+
+ (def: &functor ..functor)
+
+ (def: wrap ..resolved)
+
+ (def: (join mma)
+ (let [[ma resolve] (promise [])]
+ (exec (io.run (..await (..await resolve) mma))
+ ma))))
+
+(def: #export (and left right)
+ {#.doc "Sequencing combinator."}
+ (All [a b] (-> (Promise a) (Promise b) (Promise [a b])))
+ (let [[read! write!] (:share [a b]
+ [(Promise a) (Promise b)]
+ [left right]
+
+ [(Promise [a b])
+ (Resolver [a b])]
+ (..promise []))
+ _ (io.run (..await (function (_ left)
+ (..await (function (_ right)
+ (write! [left right]))
+ right))
+ left))]
+ read!))
+
+(def: #export (or left right)
+ {#.doc "Heterogeneous alternative combinator."}
+ (All [a b] (-> (Promise a) (Promise b) (Promise (| a b))))
+ (let [[a|b resolve] (..promise [])]
+ (with_expansions
+ [<sides> (template [<promise> <tag>]
+ [(io.run (await (|>> <tag> resolve) <promise>))]
+
+ [left #.Left]
+ [right #.Right]
+ )]
+ (exec <sides>
+ a|b))))
+
+(def: #export (either left right)
+ {#.doc "Homogeneous alternative combinator."}
+ (All [a] (-> (Promise a) (Promise a) (Promise a)))
+ (let [[left||right resolve] (..promise [])]
+ (`` (exec (~~ (template [<promise>]
+ [(io.run (await resolve <promise>))]
+
+ [left]
+ [right]))
+ left||right))))
+
+(def: #export (schedule millis_delay computation)
+ {#.doc (doc "Runs an I/O computation on its own thread (after a specified delay)."
+ "Returns a Promise that will eventually host its result.")}
+ (All [a] (-> Nat (IO a) (Promise a)))
+ (let [[!out resolve] (..promise [])]
+ (exec (|> (do io.monad
+ [value computation]
+ (resolve value))
+ (thread.schedule millis_delay)
+ io.run)
+ !out)))
+
+(def: #export future
+ {#.doc (doc "Runs an I/O computation on its own thread."
+ "Returns a Promise that will eventually host its result.")}
+ (All [a] (-> (IO a) (Promise a)))
+ (..schedule 0))
+
+(def: #export (delay time_millis value)
+ {#.doc "Delivers a value after a certain period has passed."}
+ (All [a] (-> Nat a (Promise a)))
+ (..schedule time_millis (io value)))
+
+(def: #export (wait time_millis)
+ {#.doc "Returns a promise that will be resolved after the specified amount of milliseconds."}
+ (-> Nat (Promise Any))
+ (..delay time_millis []))
+
+(def: #export (time_out time_millis promise)
+ {#.doc "Wait for a promise to be resolved within the specified amount of milliseconds."}
+ (All [a] (-> Nat (Promise a) (Promise (Maybe a))))
+ (..or (wait time_millis) promise))
diff --git a/stdlib/source/library/lux/control/concurrency/semaphore.lux b/stdlib/source/library/lux/control/concurrency/semaphore.lux
new file mode 100644
index 000000000..597e96306
--- /dev/null
+++ b/stdlib/source/library/lux/control/concurrency/semaphore.lux
@@ -0,0 +1,174 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ if>)]
+ ["." io (#+ IO)]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." queue (#+ Queue)]]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]]]
+ [type
+ abstract
+ ["." refinement]]]]
+ [//
+ ["." atom (#+ Atom)]
+ ["." promise (#+ Promise Resolver)]])
+
+(type: State
+ {#max_positions Nat
+ #open_positions Int
+ #waiting_list (Queue (Resolver Any))})
+
+(abstract: #export Semaphore
+ (Atom State)
+
+ {#.doc "A tool for controlling access to resources by multiple concurrent processes."}
+
+ (def: most_positions_possible
+ (.nat (\ i.interval top)))
+
+ (def: #export (semaphore initial_open_positions)
+ (-> Nat Semaphore)
+ (let [max_positions (n.min initial_open_positions
+ ..most_positions_possible)]
+ (:abstraction (atom.atom {#max_positions max_positions
+ #open_positions (.int max_positions)
+ #waiting_list queue.empty}))))
+
+ (def: #export (wait semaphore)
+ (Ex [k] (-> Semaphore (Promise Any)))
+ (let [semaphore (:representation semaphore)
+ [signal sink] (: [(Promise Any) (Resolver Any)]
+ (promise.promise []))]
+ (exec (io.run
+ (with_expansions [<had_open_position?> (as_is (get@ #open_positions) (i.> -1))]
+ (do io.monad
+ [[_ state'] (atom.update (|>> (update@ #open_positions dec)
+ (if> [<had_open_position?>]
+ []
+ [(update@ #waiting_list (queue.push sink))]))
+ semaphore)]
+ (with_expansions [<go_ahead> (sink [])
+ <get_in_line> (wrap false)]
+ (if (|> state' <had_open_position?>)
+ <go_ahead>
+ <get_in_line>)))))
+ signal)))
+
+ (exception: #export (semaphore_is_maxed_out {max_positions Nat})
+ (exception.report
+ ["Max Positions" (%.nat max_positions)]))
+
+ (def: #export (signal semaphore)
+ (Ex [k] (-> Semaphore (Promise (Try Int))))
+ (let [semaphore (:representation semaphore)]
+ (promise.future
+ (do {! io.monad}
+ [[pre post] (atom.update (function (_ state)
+ (if (i.= (.int (get@ #max_positions state))
+ (get@ #open_positions state))
+ state
+ (|> state
+ (update@ #open_positions inc)
+ (update@ #waiting_list queue.pop))))
+ semaphore)]
+ (if (is? pre post)
+ (wrap (exception.throw ..semaphore_is_maxed_out [(get@ #max_positions pre)]))
+ (do !
+ [_ (case (queue.peek (get@ #waiting_list pre))
+ #.None
+ (wrap true)
+
+ (#.Some sink)
+ (sink []))]
+ (wrap (#try.Success (get@ #open_positions post)))))))))
+ )
+
+(abstract: #export Mutex
+ Semaphore
+
+ {#.doc "A mutual-exclusion lock that can only be acquired by one process at a time."}
+
+ (def: #export (mutex _)
+ (-> Any Mutex)
+ (:abstraction (semaphore 1)))
+
+ (def: acquire
+ (-> Mutex (Promise Any))
+ (|>> :representation ..wait))
+
+ (def: release
+ (-> Mutex (Promise Any))
+ (|>> :representation ..signal))
+
+ (def: #export (synchronize mutex procedure)
+ (All [a] (-> Mutex (IO (Promise a)) (Promise a)))
+ (do promise.monad
+ [_ (..acquire mutex)
+ output (io.run procedure)
+ _ (..release mutex)]
+ (wrap output)))
+ )
+
+(def: #export limit
+ (refinement.refinement (n.> 0)))
+
+(type: #export Limit
+ (:~ (refinement.type limit)))
+
+(abstract: #export Barrier
+ {#limit Limit
+ #count (Atom Nat)
+ #start_turnstile Semaphore
+ #end_turnstile Semaphore}
+
+ {#.doc "A barrier that blocks all processes from proceeding until a given number of processes are parked at the barrier."}
+
+ (def: #export (barrier limit)
+ (-> Limit Barrier)
+ (:abstraction {#limit limit
+ #count (atom.atom 0)
+ #start_turnstile (..semaphore 0)
+ #end_turnstile (..semaphore 0)}))
+
+ (def: (un_block times turnstile)
+ (-> Nat Semaphore (Promise Any))
+ (loop [step 0]
+ (if (n.< times step)
+ (do promise.monad
+ [outcome (..signal turnstile)]
+ (recur (inc step)))
+ (\ promise.monad wrap []))))
+
+ (template [<phase> <update> <goal> <turnstile>]
+ [(def: (<phase> (^:representation barrier))
+ (-> Barrier (Promise Any))
+ (do promise.monad
+ [#let [limit (refinement.un_refine (get@ #limit barrier))
+ goal <goal>
+ [_ count] (io.run (atom.update <update> (get@ #count barrier)))
+ reached? (n.= goal count)]]
+ (if reached?
+ (..un_block (dec limit) (get@ <turnstile> barrier))
+ (..wait (get@ <turnstile> barrier)))))]
+
+ [start inc limit #start_turnstile]
+ [end dec 0 #end_turnstile]
+ )
+
+ (def: #export (block barrier)
+ (-> Barrier (Promise Any))
+ (do promise.monad
+ [_ (..start barrier)]
+ (..end barrier)))
+ )
diff --git a/stdlib/source/library/lux/control/concurrency/stm.lux b/stdlib/source/library/lux/control/concurrency/stm.lux
new file mode 100644
index 000000000..081d2f3d9
--- /dev/null
+++ b/stdlib/source/library/lux/control/concurrency/stm.lux
@@ -0,0 +1,274 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ ["." monad (#+ Monad do)]]
+ [control
+ ["." io (#+ IO io)]
+ ["." try]]
+ [data
+ ["." product]
+ ["." maybe]
+ [collection
+ ["." list]]]
+ [type
+ abstract]]]
+ [//
+ ["." atom (#+ Atom atom)]
+ ["." promise (#+ Promise Resolver)]
+ ["." frp (#+ Channel Sink)]])
+
+(type: (Observer a)
+ (-> a (IO Any)))
+
+(abstract: #export (Var a)
+ (Atom [a (List (Sink a))])
+
+ {#.doc "A mutable cell containing a value, and observers that will be alerted of any change to it."}
+
+ (def: #export (var value)
+ {#.doc "Creates a new STM var, with a default value."}
+ (All [a] (-> a (Var a)))
+ (:abstraction (atom.atom [value (list)])))
+
+ (def: read!
+ (All [a] (-> (Var a) a))
+ (|>> :representation atom.read io.run product.left))
+
+ (def: (un_follow sink var)
+ (All [a] (-> (Sink a) (Var a) (IO Any)))
+ (do io.monad
+ [_ (atom.update (function (_ [value observers])
+ [value (list.filter (|>> (is? sink) not) observers)])
+ (:representation var))]
+ (wrap [])))
+
+ (def: (write! new_value var)
+ (All [a] (-> a (Var a) (IO Any)))
+ (do {! io.monad}
+ [#let [var' (:representation var)]
+ (^@ old [old_value observers]) (atom.read var')
+ succeeded? (atom.compare_and_swap old [new_value observers] var')]
+ (if succeeded?
+ (do !
+ [_ (monad.map ! (function (_ sink)
+ (do !
+ [result (\ sink feed new_value)]
+ (case result
+ (#try.Success _)
+ (wrap [])
+
+ (#try.Failure _)
+ (un_follow sink var))))
+ observers)]
+ (wrap []))
+ (write! new_value var))))
+
+ (def: #export (follow target)
+ {#.doc "Creates a channel that will receive all changes to the value of the given var."}
+ (All [a] (-> (Var a) (IO [(Channel a) (Sink a)])))
+ (do io.monad
+ [#let [[channel sink] (frp.channel [])]
+ _ (atom.update (function (_ [value observers])
+ [value (#.Cons sink observers)])
+ (:representation target))]
+ (wrap [channel sink])))
+ )
+
+(type: (Tx_Frame a)
+ {#var (Var a)
+ #original a
+ #current a})
+
+(type: Tx
+ (List (Ex [a] (Tx_Frame a))))
+
+(type: #export (STM a)
+ {#.doc "A computation which updates a transaction and produces a value."}
+ (-> Tx [Tx a]))
+
+(def: (find_var_value var tx)
+ (All [a] (-> (Var a) Tx (Maybe a)))
+ (|> tx
+ (list.find (function (_ [_var _original _current])
+ (is? (:as (Var Any) var)
+ (:as (Var Any) _var))))
+ (\ maybe.monad map (function (_ [_var _original _current])
+ _current))
+ (:assume)
+ ))
+
+(def: #export (read var)
+ (All [a] (-> (Var a) (STM a)))
+ (function (_ tx)
+ (case (find_var_value var tx)
+ (#.Some value)
+ [tx value]
+
+ #.None
+ (let [value (..read! var)]
+ [(#.Cons [var value value] tx)
+ 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 (is? (:as (Var Any) var)
+ (:as (Var Any) _var))
+ (#.Cons {#var (:as (Var Any) _var)
+ #original (:as Any _original)
+ #current (:as Any value)}
+ tx')
+ (#.Cons {#var _var
+ #original _original
+ #current _current}
+ (update_tx_value var value tx')))))
+
+(def: #export (write value var)
+ {#.doc "Writes value to var."}
+ (All [a] (-> a (Var a) (STM Any)))
+ (function (_ tx)
+ (case (find_var_value var tx)
+ (#.Some _)
+ [(update_tx_value var value tx)
+ []]
+
+ #.None
+ [(#.Cons [var (..read! var) value] tx)
+ []])))
+
+(implementation: #export functor
+ (Functor STM)
+
+ (def: (map f fa)
+ (function (_ tx)
+ (let [[tx' a] (fa tx)]
+ [tx' (f a)]))))
+
+(implementation: #export apply
+ (Apply STM)
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (function (_ tx)
+ (let [[tx' f] (ff tx)
+ [tx'' a] (fa tx')]
+ [tx'' (f a)]))))
+
+(implementation: #export monad
+ (Monad STM)
+
+ (def: &functor ..functor)
+
+ (def: (wrap a)
+ (function (_ tx)
+ [tx a]))
+
+ (def: (join mma)
+ (function (_ tx)
+ (let [[tx' ma] (mma tx)]
+ (ma tx')))))
+
+(def: #export (update f var)
+ {#.doc "Will update a Var's value, and return a tuple with the old and the new values."}
+ (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 Bit)
+ (list.every? (function (_ [_var _original _current])
+ (is? _original (..read! _var)))
+ tx))
+
+(def: (commit_var! [_var _original _current])
+ (-> (Ex [a] (Tx_Frame a)) (IO Any))
+ (if (is? _original _current)
+ (io [])
+ (..write! _current _var)))
+
+(def: fresh_tx Tx (list))
+
+(type: (Commit a)
+ [(STM a)
+ (Promise a)
+ (Resolver a)])
+
+(def: pending_commits
+ (Atom (Rec Commits
+ [(Promise [(Ex [a] (Commit a)) Commits])
+ (Resolver [(Ex [a] (Commit a)) Commits])]))
+ (atom (promise.promise [])))
+
+(def: commit_processor_flag
+ (Atom Bit)
+ (atom #0))
+
+(def: (issue_commit commit)
+ (All [a] (-> (Commit a) (IO Any)))
+ (let [entry [commit (promise.promise [])]]
+ (do {! io.monad}
+ [|commits|&resolve (atom.read pending_commits)]
+ (loop [[|commits| resolve] |commits|&resolve]
+ (do !
+ [|commits| (promise.poll |commits|)]
+ (case |commits|
+ #.None
+ (do io.monad
+ [resolved? (resolve entry)]
+ (if resolved?
+ (atom.write (product.right entry) pending_commits)
+ (recur |commits|&resolve)))
+
+ (#.Some [head tail])
+ (recur tail)))))))
+
+(def: (process_commit commit)
+ (All [a] (-> (Commit a) (IO Any)))
+ (let [[stm_proc output resolve] commit
+ [finished_tx value] (stm_proc fresh_tx)]
+ (if (can_commit? finished_tx)
+ (do {! io.monad}
+ [_ (monad.map ! commit_var! finished_tx)]
+ (resolve value))
+ (issue_commit commit))))
+
+(def: init_processor!
+ (IO Any)
+ (do {! io.monad}
+ [flag (atom.read commit_processor_flag)]
+ (if flag
+ (wrap [])
+ (do !
+ [was_first? (atom.compare_and_swap flag #1 commit_processor_flag)]
+ (if was_first?
+ (do !
+ [[promise resolve] (atom.read pending_commits)]
+ (promise.await (function (recur [head [tail _resolve]])
+ (do !
+ [_ (process_commit head)]
+ (promise.await recur tail)))
+ promise))
+ (wrap [])))
+ )))
+
+(def: #export (commit stm_proc)
+ {#.doc (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 resolver] (promise.promise [])]
+ (exec (io.run (do io.monad
+ [_ init_processor!]
+ (issue_commit [stm_proc output resolver])))
+ output)))
diff --git a/stdlib/source/library/lux/control/concurrency/thread.lux b/stdlib/source/library/lux/control/concurrency/thread.lux
new file mode 100644
index 000000000..9c9bf6549
--- /dev/null
+++ b/stdlib/source/library/lux/control/concurrency/thread.lux
@@ -0,0 +1,170 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ ["." ffi]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO io)]]
+ [data
+ ["." text]
+ [collection
+ ["." list]]]
+ [math
+ [number
+ ["n" nat]
+ ["f" frac]]]
+ [time
+ ["." instant]]]]
+ [//
+ ["." atom (#+ Atom)]])
+
+(with_expansions [<jvm> (as_is (ffi.import: java/lang/Object)
+
+ (ffi.import: java/lang/Runtime
+ ["#::."
+ (#static getRuntime [] java/lang/Runtime)
+ (availableProcessors [] int)])
+
+ (ffi.import: java/lang/Runnable)
+
+ (ffi.import: java/util/concurrent/TimeUnit
+ ["#::."
+ (#enum MILLISECONDS)])
+
+ (ffi.import: java/util/concurrent/Executor
+ ["#::."
+ (execute [java/lang/Runnable] #io void)])
+
+ (ffi.import: (java/util/concurrent/ScheduledFuture a))
+
+ (ffi.import: java/util/concurrent/ScheduledThreadPoolExecutor
+ ["#::."
+ (new [int])
+ (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object))]))]
+ (for {@.old (as_is <jvm>)
+ @.jvm (as_is <jvm>)
+
+ @.js
+ (as_is (ffi.import: (setTimeout [ffi.Function ffi.Number] #io Any)))
+
+ @.python
+ (ffi.import: threading/Timer
+ ["#::."
+ (new [ffi.Float ffi.Function])
+ (start [] #io #? Any)])}
+
+ ## Default
+ (type: Thread
+ {#creation Nat
+ #delay Nat
+ #action (IO Any)})
+ ))
+
+(def: #export parallelism
+ Nat
+ (with_expansions [<jvm> (|> (java/lang/Runtime::getRuntime)
+ (java/lang/Runtime::availableProcessors)
+ .nat)]
+ (for {@.old <jvm>
+ @.jvm <jvm>}
+ ## Default
+ 1)))
+
+(with_expansions [<jvm> (as_is (def: runner
+ java/util/concurrent/ScheduledThreadPoolExecutor
+ (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))))]
+ (for {@.old <jvm>
+ @.jvm <jvm>
+ @.js (as_is)
+ @.python (as_is)}
+
+ ## Default
+ (def: runner
+ (Atom (List Thread))
+ (atom.atom (list)))))
+
+(def: (execute! action)
+ (-> (IO Any) Any)
+ (case (try (io.run action))
+ (#try.Failure error)
+ (exec
+ ("lux io log" ($_ "lux text concat"
+ "ERROR DURING THREAD EXECUTION:" text.new_line
+ error))
+ [])
+
+ (#try.Success _)
+ []))
+
+(def: #export (schedule milli_seconds action)
+ (-> Nat (IO Any) (IO Any))
+ (with_expansions [<jvm> (as_is (let [runnable (ffi.object [] [java/lang/Runnable]
+ []
+ (java/lang/Runnable [] (run self) void
+ (..execute! action)))]
+ (case milli_seconds
+ 0 (java/util/concurrent/Executor::execute runnable runner)
+ _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule runnable (.int milli_seconds) java/util/concurrent/TimeUnit::MILLISECONDS
+ runner))))]
+ (for {@.old <jvm>
+ @.jvm <jvm>
+
+ @.js
+ (..setTimeout [(ffi.closure [] (..execute! action))
+ (n.frac milli_seconds)])
+
+ @.python
+ (do io.monad
+ [_ (|> (ffi.lambda [] (..execute! action))
+ [(|> milli_seconds n.frac (f./ +1,000.0))]
+ threading/Timer::new
+ (threading/Timer::start []))]
+ (wrap []))}
+
+ ## Default
+ (do {! io.monad}
+ [now (\ ! map (|>> instant.to_millis .nat) instant.now)
+ _ (atom.update (|>> (#.Cons {#creation now
+ #delay milli_seconds
+ #action action}))
+ ..runner)]
+ (wrap [])))))
+
+(for {@.old (as_is)
+ @.jvm (as_is)
+ @.js (as_is)
+ @.python (as_is)}
+
+ ## Default
+ (as_is (exception: #export cannot_continue_running_threads)
+
+ (def: #export run!
+ (IO Any)
+ (loop [_ []]
+ (do {! io.monad}
+ [threads (atom.read ..runner)]
+ (case threads
+ ## And... we're done!
+ #.Nil
+ (wrap [])
+
+ _
+ (do !
+ [now (\ ! map (|>> instant.to_millis .nat) instant.now)
+ #let [[ready pending] (list.partition (function (_ thread)
+ (|> (get@ #creation thread)
+ (n.+ (get@ #delay thread))
+ (n.<= now)))
+ threads)]
+ swapped? (atom.compare_and_swap threads pending ..runner)]
+ (if swapped?
+ (do !
+ [_ (monad.map ! (|>> (get@ #action) ..execute! io.io) ready)]
+ (recur []))
+ (error! (exception.construct ..cannot_continue_running_threads []))))
+ ))))
+ ))
diff --git a/stdlib/source/library/lux/control/continuation.lux b/stdlib/source/library/lux/control/continuation.lux
new file mode 100644
index 000000000..8b9b5a24f
--- /dev/null
+++ b/stdlib/source/library/lux/control/continuation.lux
@@ -0,0 +1,100 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ [monad (#+ Monad do)]]
+ [control
+ ["." function]
+ [parser
+ ["s" code]]]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]]]])
+
+(type: #export (Cont i o)
+ {#.doc "Continuations."}
+ (-> (-> i o) o))
+
+(def: #export (continue next cont)
+ {#.doc "Continues a continuation thunk."}
+ (All [i o] (-> (-> i o) (Cont i o) o))
+ (cont next))
+
+(def: #export (run cont)
+ {#.doc "Forces a continuation thunk to be evaluated."}
+ (All [a] (-> (Cont a a) a))
+ (cont function.identity))
+
+(def: #export (call/cc f)
+ {#.doc "Call with current continuation."}
+ (All [a b z]
+ (-> (-> (-> a (Cont b z))
+ (Cont a z))
+ (Cont a z)))
+ (function (_ k)
+ (f (function (_ a) (function (_ _) (k a)))
+ k)))
+
+(syntax: #export (pending expr)
+ {#.doc (doc "Turns any expression into a function that is pending a continuation."
+ (pending (some_function some_input)))}
+ (with_gensyms [g!_ g!k]
+ (wrap (list (` (.function ((~ g!_) (~ g!k)) ((~ g!k) (~ expr))))))))
+
+(def: #export (reset scope)
+ (All [i o] (-> (Cont i i) (Cont i o)))
+ (function (_ k)
+ (k (run scope))))
+
+(def: #export (shift f)
+ (All [a]
+ (-> (-> (-> a (Cont a a))
+ (Cont a a))
+ (Cont a a)))
+ (function (_ oc)
+ (f (function (_ a) (function (_ ic) (ic (oc a))))
+ function.identity)))
+
+(implementation: #export functor
+ (All [o] (Functor (All [i] (Cont i o))))
+
+ (def: (map f fv)
+ (function (_ k) (fv (function.compose k f)))))
+
+(implementation: #export apply
+ (All [o] (Apply (All [i] (Cont i o))))
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fv)
+ (function (_ k)
+ (|> (k (f v))
+ (function (_ v)) fv
+ (function (_ f)) ff))))
+
+(implementation: #export monad
+ (All [o] (Monad (All [i] (Cont i o))))
+
+ (def: &functor ..functor)
+
+ (def: (wrap value)
+ (function (_ k) (k value)))
+
+ (def: (join ffa)
+ (function (_ k)
+ (ffa (continue k)))))
+
+(def: #export (portal init)
+ (All [i o z]
+ (-> i
+ (Cont [(-> i (Cont o z))
+ i]
+ z)))
+ (call/cc (function (_ k)
+ (do ..monad
+ [#let [nexus (function (nexus val)
+ (k [nexus val]))]
+ _ (k [nexus init])]
+ (wrap (undefined))))))
diff --git a/stdlib/source/library/lux/control/exception.lux b/stdlib/source/library/lux/control/exception.lux
new file mode 100644
index 000000000..405c858a5
--- /dev/null
+++ b/stdlib/source/library/lux/control/exception.lux
@@ -0,0 +1,184 @@
+(.module: {#.doc "Exception-handling functionality."}
+ [library
+ [lux #*
+ ["." macro]
+ ["." meta]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["p" parser
+ ["s" code (#+ Parser)]]]
+ [data
+ ["." maybe]
+ ["." product]
+ ["." text ("#\." monoid)]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [macro
+ ["." code]
+ [syntax (#+ syntax:)
+ ["|.|" export]
+ ["|.|" input]
+ ["." type #_
+ ["|#_.|" variable]]]]
+ [math
+ [number
+ ["n" nat ("#\." decimal)]]]]]
+ [//
+ ["//" try (#+ Try)]])
+
+(type: #export (Exception a)
+ {#.doc "An exception provides a way to decorate error messages."}
+ {#label Text
+ #constructor (-> a Text)})
+
+(def: #export (match? exception error)
+ (All [e] (-> (Exception e) Text Bit))
+ (text.starts_with? (get@ #label exception) error))
+
+(def: #export (catch exception then try)
+ {#.doc (doc "If a particular exception is detected on a possibly-erroneous value, handle it."
+ "If no exception was detected, or a different one from the one being checked, then pass along the original value.")}
+ (All [e a]
+ (-> (Exception e) (-> Text a) (Try a)
+ (Try a)))
+ (case try
+ (#//.Success output)
+ (#//.Success output)
+
+ (#//.Failure error)
+ (let [reference (get@ #label exception)]
+ (if (text.starts_with? reference error)
+ (#//.Success (|> error
+ (text.clip' (text.size reference))
+ maybe.assume
+ then))
+ (#//.Failure error)))))
+
+(def: #export (otherwise to_do try)
+ {#.doc "If no handler could be found to catch the exception, then run a function as a last-resort measure."}
+ (All [a]
+ (-> (-> Text a) (Try a) a))
+ (case try
+ (#//.Success output)
+ output
+
+ (#//.Failure error)
+ (to_do error)))
+
+(def: #export (return value)
+ {#.doc "A way to lift normal values into the error-handling context."}
+ (All [a] (-> a (Try a)))
+ (#//.Success value))
+
+(def: #export (construct exception message)
+ {#.doc "Constructs an exception."}
+ (All [e] (-> (Exception e) e Text))
+ ((get@ #..constructor exception) message))
+
+(def: #export (throw exception message)
+ {#.doc "Decorate an error message with an Exception and lift it into the error-handling context."}
+ (All [e a] (-> (Exception e) e (Try a)))
+ (#//.Failure (..construct exception message)))
+
+(def: #export (assert exception message test)
+ (All [e] (-> (Exception e) e Bit (Try Any)))
+ (if test
+ (#//.Success [])
+ (..throw exception message)))
+
+(syntax: #export (exception: {export |export|.parser}
+ {t_vars (p.default (list) (s.tuple (p.some |type_variable|.parser)))}
+ {[name inputs] (p.either (p.and s.local_identifier (wrap (list)))
+ (s.form (p.and s.local_identifier (p.some |input|.parser))))}
+ {body (p.maybe s.any)})
+ {#.doc (doc "Define a new exception type."
+ "It mostly just serves as a way to tag error messages for later catching."
+ ""
+ "Simple case:"
+ (exception: #export some_exception)
+ ""
+ "Complex case:"
+ (exception: #export [optional type variables] (some_exception {optional Text} {arguments Int})
+ optional_body))}
+ (macro.with_gensyms [g!descriptor]
+ (do meta.monad
+ [current_module meta.current_module_name
+ #let [descriptor ($_ text\compose "{" current_module "." name "}" text.new_line)
+ g!self (code.local_identifier name)]]
+ (wrap (list (` (def: (~+ (|export|.format export))
+ (~ g!self)
+ (All [(~+ (list\map |type_variable|.format t_vars))]
+ (..Exception [(~+ (list\map (get@ #|input|.type) inputs))]))
+ (let [(~ g!descriptor) (~ (code.text descriptor))]
+ {#..label (~ g!descriptor)
+ #..constructor (function ((~ g!self) [(~+ (list\map (get@ #|input|.binding) inputs))])
+ ((~! text\compose) (~ g!descriptor)
+ (~ (maybe.default (' "") body))))})))))
+ )))
+
+(def: (report' entries)
+ (-> (List [Text Text]) Text)
+ (let [header_separator ": "
+ largest_header_size (list\fold (function (_ [header _] max)
+ (n.max (text.size header) max))
+ 0
+ entries)
+ on_new_line (|> " "
+ (list.repeat (n.+ (text.size header_separator)
+ largest_header_size))
+ (text.join_with "")
+ (text\compose text.new_line))]
+ (|> entries
+ (list\map (function (_ [header message])
+ (let [padding (|> " "
+ (list.repeat (n.- (text.size header)
+ largest_header_size))
+ (text.join_with ""))]
+ (|> message
+ (text.replace_all text.new_line on_new_line)
+ ($_ text\compose padding header header_separator)))))
+ (text.join_with text.new_line))))
+
+(syntax: #export (report {entries (p.many (s.tuple (p.and s.any s.any)))})
+ (wrap (list (` ((~! report') (list (~+ (|> entries
+ (list\map (function (_ [header message])
+ (` [(~ header) (~ message)])))))))))))
+
+(def: #export (enumerate format entries)
+ (All [a]
+ (-> (-> a Text) (List a) Text))
+ (|> entries
+ list.enumeration
+ (list\map (function (_ [index entry])
+ [(n\encode index) (format entry)]))
+ report'))
+
+(def: separator
+ (let [gap ($_ "lux text concat" text.new_line text.new_line)
+ horizontal_line (|> "-" (list.repeat 64) (text.join_with ""))]
+ ($_ "lux text concat"
+ gap
+ horizontal_line
+ gap)))
+
+(def: (decorate prelude error)
+ (-> Text Text Text)
+ ($_ "lux text concat"
+ prelude
+ ..separator
+ error))
+
+(def: #export (with exception message computation)
+ (All [e a] (-> (Exception e) e (Try a) (Try a)))
+ (case computation
+ (#//.Failure error)
+ (#//.Failure (case error
+ ""
+ (..construct exception message)
+
+ _
+ (..decorate (..construct exception message) error)))
+
+ success
+ success))
diff --git a/stdlib/source/library/lux/control/function.lux b/stdlib/source/library/lux/control/function.lux
new file mode 100644
index 000000000..2f880a872
--- /dev/null
+++ b/stdlib/source/library/lux/control/function.lux
@@ -0,0 +1,47 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monoid (#+ Monoid)]]]])
+
+(def: #export identity
+ {#.doc (doc "Identity function."
+ "Does nothing to its argument and just returns it."
+ (is? (identity value)
+ value))}
+ (All [a] (-> a a))
+ (|>>))
+
+(def: #export (compose f g)
+ {#.doc (doc "Function composition."
+ (= ((compose f g) "foo")
+ (f (g "foo"))))}
+ (All [a b c]
+ (-> (-> b c) (-> a b) (-> a c)))
+ (|>> g f))
+
+(def: #export (constant value)
+ {#.doc (doc "Create constant functions."
+ (= ((constant "foo") "bar")
+ "foo"))}
+ (All [o] (-> o (All [i] (-> i o))))
+ (function (_ _) value))
+
+(def: #export (flip f)
+ {#.doc (doc "Flips the order of the arguments of a function."
+ (= ((flip f) "foo" "bar")
+ (f "bar" "foo")))}
+ (All [a b c]
+ (-> (-> a b c) (-> b a c)))
+ (function (_ x y) (f y x)))
+
+(def: #export (apply input function)
+ (All [i o]
+ (-> i (-> i o) o))
+ (function input))
+
+(implementation: #export monoid
+ (All [a] (Monoid (-> a a)))
+
+ (def: identity ..identity)
+ (def: compose ..compose))
diff --git a/stdlib/source/library/lux/control/function/contract.lux b/stdlib/source/library/lux/control/function/contract.lux
new file mode 100644
index 000000000..149053230
--- /dev/null
+++ b/stdlib/source/library/lux/control/function/contract.lux
@@ -0,0 +1,52 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ ["." exception (#+ exception:)]]
+ [data
+ [text
+ ["%" format (#+ format)]]]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number
+ ["i" int]]]]])
+
+(template [<name>]
+ [(exception: (<name> {condition Code})
+ (exception.report
+ ["Condition" (%.code condition)]))]
+
+ [pre_condition_failed]
+ [post_condition_failed]
+ )
+
+(def: (assert! message test)
+ (-> Text Bit [])
+ (if test
+ []
+ (error! message)))
+
+(syntax: #export (pre test expr)
+ {#.doc (doc "Pre-conditions."
+ "Given a test and an expression to run, only runs the expression if the test passes."
+ "Otherwise, an error is raised."
+ (pre (i.= +4 (i.+ +2 +2))
+ (foo +123 +456 +789)))}
+ (wrap (list (` (exec ((~! ..assert!) (~ (code.text (exception.construct ..pre_condition_failed test)))
+ (~ test))
+ (~ expr))))))
+
+(syntax: #export (post test expr)
+ {#.doc (doc "Post-conditions."
+ "Given a predicate and an expression to run, evaluates the expression and then tests the output with the predicate."
+ "If the predicate returns #1, returns the value of the expression."
+ "Otherwise, an error is raised."
+ (post i.even?
+ (i.+ +2 +2)))}
+ (with_gensyms [g!output]
+ (wrap (list (` (let [(~ g!output) (~ expr)]
+ (exec ((~! ..assert!) (~ (code.text (exception.construct ..post_condition_failed test)))
+ ((~ test) (~ g!output)))
+ (~ g!output))))))))
diff --git a/stdlib/source/library/lux/control/function/memo.lux b/stdlib/source/library/lux/control/function/memo.lux
new file mode 100644
index 000000000..5ab6c2b3b
--- /dev/null
+++ b/stdlib/source/library/lux/control/function/memo.lux
@@ -0,0 +1,64 @@
+## Inspired by;
+## "The Different Aspects of Monads and Mixins" by Bruno C. d. S. Oliveira
+
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [hash (#+ Hash)]
+ [monad (#+ do)]]
+ [control
+ ["." state (#+ State)]]
+ [data
+ ["." product]
+ [collection
+ ["." dictionary (#+ Dictionary)]]]]]
+ ["." // #_
+ ["#" mixin (#+ Mixin Recursive)]])
+
+(def: #export memoization
+ (All [i o]
+ (Mixin i (State (Dictionary i o) o)))
+ (function (_ delegate recur)
+ (function (_ input)
+ (do {! state.monad}
+ [memory state.get]
+ (case (dictionary.get input memory)
+ (#.Some output)
+ (wrap output)
+
+ #.None
+ (do !
+ [output (delegate input)
+ _ (state.update (dictionary.put input output))]
+ (wrap output)))))))
+
+(type: #export (Memo i o)
+ (Recursive i (State (Dictionary i o) o)))
+
+(def: #export (open memo)
+ {#.doc (doc "Memoization where the memoized results can be re-used accross invocations.")}
+ (All [i o]
+ (:let [Memory (Dictionary i o)]
+ (-> (Memo i o) (-> [Memory i] [Memory o]))))
+ (let [memo (//.mixin (//.inherit ..memoization (//.from-recursive memo)))]
+ (function (_ [memory input])
+ (|> input memo (state.run memory)))))
+
+(def: #export (closed hash memo)
+ {#.doc (doc "Memoization confined to a single invocation to the function (not counting any subsequent recursive invocations)."
+ "Memoized results will be re-used during recursive invocations, but cannot be accessed after the main invocation has ended.")}
+ (All [i o]
+ (-> (Hash i) (Memo i o) (-> i o)))
+ (let [memo (//.mixin (//.inherit ..memoization (//.from-recursive memo)))
+ empty (dictionary.new hash)]
+ (|>> memo (state.run empty) product.right)))
+
+(def: #export (none hash memo)
+ {#.doc (doc "No memoization at all."
+ "This is useful as a test control when measuring the effect of using memoization.")}
+ (All [i o]
+ (-> (Hash i) (Memo i o) (-> i o)))
+ (let [memo (//.mixin (//.from-recursive memo))
+ empty (dictionary.new hash)]
+ (|>> memo (state.run empty) product.right)))
diff --git a/stdlib/source/library/lux/control/function/mixin.lux b/stdlib/source/library/lux/control/function/mixin.lux
new file mode 100644
index 000000000..f70b2f9c3
--- /dev/null
+++ b/stdlib/source/library/lux/control/function/mixin.lux
@@ -0,0 +1,64 @@
+## Inspired by;
+## "The Different Aspects of Monads and Mixins" by Bruno C. d. S. Oliveira
+
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monoid (#+ Monoid)]
+ [predicate (#+ Predicate)]
+ [monad (#+ Monad do)]]]])
+
+(type: #export (Mixin i o)
+ (-> (-> i o) (-> i o) (-> i o)))
+
+(def: #export (mixin f)
+ (All [i o] (-> (Mixin i o) (-> i o)))
+ (function (mix input)
+ ((f mix mix) input)))
+
+(def: #export nothing
+ Mixin
+ (function (_ delegate recur)
+ delegate))
+
+(def: #export (inherit parent child)
+ (All [i o] (-> (Mixin i o) (Mixin i o) (Mixin i o)))
+ (function (_ delegate recur)
+ (parent (child delegate recur) recur)))
+
+(implementation: #export monoid
+ (All [i o] (Monoid (Mixin i o)))
+
+ (def: identity ..nothing)
+ (def: compose ..inherit))
+
+(def: #export (advice when then)
+ (All [i o] (-> (Predicate i) (Mixin i o) (Mixin i o)))
+ (function (_ delegate recur input)
+ (if (when input)
+ ((then delegate recur) input)
+ (delegate input))))
+
+(def: #export (before monad action)
+ (All [! i o] (-> (Monad !) (-> i (! Any)) (Mixin i (! o))))
+ (function (_ delegate recur input)
+ (do monad
+ [_ (action input)]
+ (delegate input))))
+
+(def: #export (after monad action)
+ (All [! i o] (-> (Monad !) (-> i o (! Any)) (Mixin i (! o))))
+ (function (_ delegate recur input)
+ (do monad
+ [output (delegate input)
+ _ (action input output)]
+ (wrap output))))
+
+(type: #export (Recursive i o)
+ (-> (-> i o) (-> i o)))
+
+(def: #export (from-recursive recursive)
+ (All [i o] (-> (Recursive i o) (Mixin i o)))
+ (function (_ delegate recur)
+ (recursive recur)))
diff --git a/stdlib/source/library/lux/control/function/mutual.lux b/stdlib/source/library/lux/control/function/mutual.lux
new file mode 100644
index 000000000..dcc4791e1
--- /dev/null
+++ b/stdlib/source/library/lux/control/function/mutual.lux
@@ -0,0 +1,158 @@
+(.module:
+ [library
+ [lux (#- Definition let def:)
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["<>" parser ("#\." monad)
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]
+ [dictionary
+ ["." plist (#+ PList)]]]]
+ ["." macro
+ ["." local]
+ ["." code]
+ [syntax (#+ syntax:)
+ ["." export]
+ ["." declaration (#+ Declaration)]]]]]
+ ["." //])
+
+(type: Mutual
+ {#declaration Declaration
+ #type Code
+ #body Code})
+
+(.def: mutual
+ (Parser [Declaration Code Code])
+ ($_ <>.and
+ declaration.parser
+ <code>.any
+ <code>.any
+ ))
+
+(.def: (mutual_definition context g!context [g!name mutual])
+ (-> (List Code) Code [Code Mutual] Code)
+ (` (function ((~ g!name) (~ g!context))
+ (.let [[(~+ context)] (~ g!context)]
+ (function (~ (declaration.format (get@ #declaration mutual)))
+ (~ (get@ #body mutual)))))))
+
+(.def: (macro g!context g!self)
+ (-> Code Code Macro)
+ (<| (:as Macro)
+ (: Macro')
+ (function (_ parameters)
+ (\ meta.monad wrap (list (` (((~ g!self) (~ g!context)) (~+ parameters))))))))
+
+(syntax: #export (let {functions (<code>.tuple (<>.some ..mutual))}
+ body)
+ (case functions
+ #.Nil
+ (wrap (list body))
+
+ (#.Cons mutual #.Nil)
+ (.let [g!name (|> mutual (get@ [#declaration #declaration.name]) code.local_identifier)]
+ (wrap (list (` (.let [(~ g!name) (: (~ (get@ #type mutual))
+ (function (~ (declaration.format (get@ #declaration mutual)))
+ (~ (get@ #body mutual))))]
+ (~ body))))))
+
+ _
+ (macro.with_gensyms [g!context g!output]
+ (do {! meta.monad}
+ [here_name meta.current_module_name
+ hidden_names (monad.map ! (//.constant (macro.gensym "mutual_function#"))
+ functions)
+ #let [definitions (list\map (..mutual_definition hidden_names g!context)
+ (list.zip/2 hidden_names
+ functions))
+ context_types (list\map (function (_ mutual)
+ (` (-> (~ g!context) (~ (get@ #type mutual)))))
+ functions)
+ user_names (list\map (|>> (get@ [#declaration #declaration.name]) code.local_identifier)
+ functions)]
+ g!pop (local.push (list\map (function (_ [g!name mutual])
+ [[here_name (get@ [#declaration #declaration.name] mutual)]
+ (..macro g!context g!name)])
+ (list.zip/2 hidden_names
+ functions)))]
+ (wrap (list (` (.let [(~ g!context) (: (Rec (~ g!context)
+ [(~+ context_types)])
+ [(~+ definitions)])
+ [(~+ user_names)] (.let [[(~+ user_names)] (~ g!context)]
+ [(~+ (list\map (function (_ g!name)
+ (` ((~ g!name) (~ g!context))))
+ user_names))])
+ (~ g!output) (~ body)]
+ (exec (~ g!pop)
+ (~ g!output))))))))))
+
+(type: Definition
+ {#exported? Bit
+ #mutual Mutual})
+
+(.def: definition
+ (Parser Definition)
+ (<code>.tuple (<>.and export.parser
+ ..mutual)))
+
+(syntax: #export (def: {functions (<>.many ..definition)})
+ (case functions
+ #.Nil
+ (wrap (list))
+
+ (#.Cons definition #.Nil)
+ (.let [(^slots [#exported? #mutual]) definition
+ (^slots [#declaration #type #body]) mutual]
+ (wrap (list (` (.def:
+ (~+ (export.format exported?))
+ (~ (declaration.format declaration))
+ (~ type)
+ (~ body))))))
+
+ _
+ (macro.with_gensyms [g!context g!output]
+ (do {! meta.monad}
+ [here_name meta.current_module_name
+ hidden_names (monad.map ! (//.constant (macro.gensym "mutual_function#"))
+ functions)
+ #let [definitions (list\map (..mutual_definition hidden_names g!context)
+ (list.zip/2 hidden_names
+ (list\map (get@ #mutual) functions)))
+ context_types (list\map (function (_ mutual)
+ (` (-> (~ g!context) (~ (get@ [#mutual #type] mutual)))))
+ functions)
+ user_names (list\map (|>> (get@ [#mutual #declaration #declaration.name]) code.local_identifier)
+ functions)]
+ g!pop (local.push (list\map (function (_ [g!name mutual])
+ [[here_name (get@ [#mutual #declaration #declaration.name] mutual)]
+ (..macro g!context g!name)])
+ (list.zip/2 hidden_names
+ functions)))]
+ (wrap (list& (` (.def: (~ g!context)
+ [(~+ (list\map (get@ [#mutual #type]) functions))]
+ (.let [(~ g!context) (: (Rec (~ g!context)
+ [(~+ context_types)])
+ [(~+ definitions)])
+ [(~+ user_names)] (~ g!context)]
+ [(~+ (list\map (function (_ g!name)
+ (` ((~ g!name) (~ g!context))))
+ user_names))])))
+ g!pop
+ (list\map (function (_ mutual)
+ (.let [g!name (|> mutual (get@ [#mutual #declaration #declaration.name]) code.local_identifier)]
+ (` (.def:
+ (~+ (export.format (get@ #exported? mutual)))
+ (~ g!name)
+ (~ (get@ [#mutual #type] mutual))
+ (.let [[(~+ user_names)] (~ g!context)]
+ (~ g!name))))))
+ functions)))))))
diff --git a/stdlib/source/library/lux/control/io.lux b/stdlib/source/library/lux/control/io.lux
new file mode 100644
index 000000000..a4773cd0d
--- /dev/null
+++ b/stdlib/source/library/lux/control/io.lux
@@ -0,0 +1,72 @@
+(.module: {#.doc "A method for abstracting I/O and effectful computations to make it safe while writing pure functional code."}
+ [library
+ [lux #*
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ [monad (#+ Monad do)]]
+ [control
+ [parser
+ ["s" code]]]
+ [type
+ abstract]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." template]]]])
+
+(abstract: #export (IO a)
+ (-> Any a)
+
+ {#.doc "A type that represents synchronous, effectful computations that may interact with the outside world."}
+
+ (def: label
+ (All [a] (-> (-> Any a) (IO a)))
+ (|>> :abstraction))
+
+ (template: (!io computation)
+ (:abstraction (template.with_locals [g!func g!arg]
+ (function (g!func g!arg)
+ computation))))
+
+ (template: (!run io)
+ ## creatio ex nihilo
+ ((:representation io) []))
+
+ (syntax: #export (io computation)
+ {#.doc (doc "Delays the evaluation of an expression, by wrapping it in an IO 'thunk'."
+ "Great for wrapping effectful computations (which will not be performed until the IO is 'run')."
+ (io (exec
+ (log! msg)
+ "Some value...")))}
+ (with_gensyms [g!func g!arg]
+ (wrap (list (` ((~! ..label) (function ((~ g!func) (~ g!arg))
+ (~ computation))))))))
+
+ (def: #export run
+ {#.doc "A way to execute IO computations and perform their side-effects."}
+ (All [a] (-> (IO a) a))
+ (|>> !run))
+
+ (implementation: #export functor
+ (Functor IO)
+
+ (def: (map f)
+ (|>> !run f !io)))
+
+ (implementation: #export apply
+ (Apply IO)
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (!io ((!run ff) (!run fa)))))
+
+ (implementation: #export monad
+ (Monad IO)
+
+ (def: &functor ..functor)
+
+ (def: wrap (|>> !io))
+
+ (def: join (|>> !run !run !io)))
+ )
diff --git a/stdlib/source/library/lux/control/parser.lux b/stdlib/source/library/lux/control/parser.lux
new file mode 100644
index 000000000..fad957e27
--- /dev/null
+++ b/stdlib/source/library/lux/control/parser.lux
@@ -0,0 +1,324 @@
+(.module:
+ [library
+ [lux (#- or and not)
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ [monad (#+ Monad do)]
+ [codec (#+ Codec)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ ["." product]
+ [collection
+ ["." list ("#\." functor monoid)]]]
+ [math
+ [number
+ ["n" nat]]]]])
+
+(type: #export (Parser s a)
+ {#.doc "A generic parser."}
+ (-> s (Try [s a])))
+
+(implementation: #export functor
+ (All [s] (Functor (Parser s)))
+
+ (def: (map f ma)
+ (function (_ input)
+ (case (ma input)
+ (#try.Failure msg)
+ (#try.Failure msg)
+
+ (#try.Success [input' a])
+ (#try.Success [input' (f a)])))))
+
+(implementation: #export apply
+ (All [s] (Apply (Parser s)))
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (function (_ input)
+ (case (ff input)
+ (#try.Success [input' f])
+ (case (fa input')
+ (#try.Success [input'' a])
+ (#try.Success [input'' (f a)])
+
+ (#try.Failure msg)
+ (#try.Failure msg))
+
+ (#try.Failure msg)
+ (#try.Failure msg)))))
+
+(implementation: #export monad
+ (All [s] (Monad (Parser s)))
+
+ (def: &functor ..functor)
+
+ (def: (wrap x)
+ (function (_ input)
+ (#try.Success [input x])))
+
+ (def: (join mma)
+ (function (_ input)
+ (case (mma input)
+ (#try.Failure msg)
+ (#try.Failure msg)
+
+ (#try.Success [input' ma])
+ (ma input')))))
+
+(def: #export (assert message test)
+ {#.doc "Fails with the given message if the test is #0."}
+ (All [s] (-> Text Bit (Parser s Any)))
+ (function (_ input)
+ (if test
+ (#try.Success [input []])
+ (#try.Failure message))))
+
+(def: #export (maybe parser)
+ {#.doc "Optionality combinator."}
+ (All [s a]
+ (-> (Parser s a) (Parser s (Maybe a))))
+ (function (_ input)
+ (case (parser input)
+ (#try.Failure _)
+ (#try.Success [input #.None])
+
+ (#try.Success [input' x])
+ (#try.Success [input' (#.Some x)]))))
+
+(def: #export (run parser input)
+ (All [s a]
+ (-> (Parser s a) s (Try [s a])))
+ (parser input))
+
+(def: #export (and first second)
+ {#.doc "Sequencing combinator."}
+ (All [s a b]
+ (-> (Parser s a) (Parser s b) (Parser s [a b])))
+ (do {! ..monad}
+ [head first]
+ (\ ! map (|>> [head]) second)))
+
+(def: #export (or left right)
+ {#.doc "Heterogeneous alternative combinator."}
+ (All [s a b]
+ (-> (Parser s a) (Parser s b) (Parser s (| a b))))
+ (function (_ tokens)
+ (case (left tokens)
+ (#try.Success [tokens' output])
+ (#try.Success [tokens' (0 #0 output)])
+
+ (#try.Failure _)
+ (case (right tokens)
+ (#try.Success [tokens' output])
+ (#try.Success [tokens' (0 #1 output)])
+
+ (#try.Failure error)
+ (#try.Failure error)))))
+
+(def: #export (either this that)
+ {#.doc "Homogeneous alternative combinator."}
+ (All [s a]
+ (-> (Parser s a) (Parser s a) (Parser s a)))
+ (function (_ tokens)
+ (case (this tokens)
+ (#try.Failure _)
+ (that tokens)
+
+ output
+ output)))
+
+(def: #export (some parser)
+ {#.doc "0-or-more combinator."}
+ (All [s a]
+ (-> (Parser s a) (Parser s (List a))))
+ (function (_ input)
+ (case (parser input)
+ (#try.Failure _)
+ (#try.Success [input (list)])
+
+ (#try.Success [input' head])
+ (..run (\ ..monad map (|>> (list& head))
+ (some parser))
+ input'))))
+
+(def: #export (many parser)
+ {#.doc "1-or-more combinator."}
+ (All [s a]
+ (-> (Parser s a) (Parser s (List a))))
+ (|> (..some parser)
+ (..and parser)
+ (\ ..monad map (|>> #.Cons))))
+
+(def: #export (exactly amount parser)
+ {#.doc "Parse exactly N times."}
+ (All [s a] (-> Nat (Parser s a) (Parser s (List a))))
+ (case amount
+ 0 (\ ..monad wrap (list))
+ _ (do {! ..monad}
+ [x parser]
+ (|> parser
+ (exactly (dec amount))
+ (\ ! map (|>> (#.Cons x)))))))
+
+(def: #export (at_least amount parser)
+ {#.doc "Parse at least N times."}
+ (All [s a] (-> Nat (Parser s a) (Parser s (List a))))
+ (do {! ..monad}
+ [minimum (..exactly amount parser)]
+ (\ ! map (list\compose minimum) (..some parser))))
+
+(def: #export (at_most amount parser)
+ {#.doc "Parse at most N times."}
+ (All [s a] (-> Nat (Parser s a) (Parser s (List a))))
+ (case amount
+ 0 (\ ..monad wrap (list))
+ _ (function (_ input)
+ (case (parser input)
+ (#try.Failure msg)
+ (#try.Success [input (list)])
+
+ (#try.Success [input' x])
+ (..run (\ ..monad map (|>> (#.Cons x))
+ (at_most (dec amount) parser))
+ input')))))
+
+(def: #export (between from to parser)
+ {#.doc "Parse between N and M times."}
+ (All [s a] (-> Nat Nat (Parser s a) (Parser s (List a))))
+ (do {! ..monad}
+ [minimum (..exactly from parser)]
+ (if (n.< to from)
+ (\ ! map (list\compose minimum)
+ (..at_most (n.- from to) parser))
+ (wrap minimum))))
+
+(def: #export (separated_by separator parser)
+ {#.doc "Parsers instances of 'parser' that are separated by instances of 'separator'."}
+ (All [s a b] (-> (Parser s b) (Parser s a) (Parser s (List a))))
+ (do {! ..monad}
+ [?x (..maybe parser)]
+ (case ?x
+ #.None
+ (wrap #.Nil)
+
+ (#.Some x)
+ (|> parser
+ (..and separator)
+ ..some
+ (\ ! map (|>> (list\map product.right) (#.Cons x)))))))
+
+(def: #export (not parser)
+ (All [s a] (-> (Parser s a) (Parser s Any)))
+ (function (_ input)
+ (case (parser input)
+ (#try.Failure msg)
+ (#try.Success [input []])
+
+ _
+ (#try.Failure "Expected to fail; yet succeeded."))))
+
+(def: #export (fail message)
+ (All [s a] (-> Text (Parser s a)))
+ (function (_ input)
+ (#try.Failure message)))
+
+(def: #export (lift operation)
+ (All [s a] (-> (Try a) (Parser s a)))
+ (function (_ input)
+ (case operation
+ (#try.Success output)
+ (#try.Success [input output])
+
+ (#try.Failure error)
+ (#try.Failure error))))
+
+(def: #export (default value parser)
+ {#.doc "If the given parser fails, returns the default value."}
+ (All [s a] (-> a (Parser s a) (Parser s a)))
+ (function (_ input)
+ (case (parser input)
+ (#try.Failure error)
+ (#try.Success [input value])
+
+ (#try.Success [input' output])
+ (#try.Success [input' output]))))
+
+(def: #export remaining
+ (All [s] (Parser s s))
+ (function (_ inputs)
+ (#try.Success [inputs inputs])))
+
+(def: #export (rec parser)
+ {#.doc "Combinator for recursive parser."}
+ (All [s a] (-> (-> (Parser s a) (Parser s a)) (Parser s a)))
+ (function (_ inputs)
+ (..run (parser (rec parser)) inputs)))
+
+(def: #export (after param subject)
+ (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a)))
+ (do ..monad
+ [_ param]
+ subject))
+
+(def: #export (before param subject)
+ (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a)))
+ (do ..monad
+ [output subject
+ _ param]
+ (wrap output)))
+
+(def: #export (filter test parser)
+ (All [s a] (-> (-> a Bit) (Parser s a) (Parser s a)))
+ (do ..monad
+ [output parser
+ _ (..assert "Constraint failed." (test output))]
+ (wrap output)))
+
+(def: #export (parses? parser)
+ (All [s a] (-> (Parser s a) (Parser s Bit)))
+ (function (_ input)
+ (case (parser input)
+ (#try.Failure error)
+ (#try.Success [input false])
+
+ (#try.Success [input' _])
+ (#try.Success [input' true]))))
+
+(def: #export (parses parser)
+ (All [s a] (-> (Parser s a) (Parser s Any)))
+ (function (_ input)
+ (case (parser input)
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success [input' _])
+ (#try.Success [input' []]))))
+
+(def: #export (speculative parser)
+ (All [s a] (-> (Parser s a) (Parser s a)))
+ (function (_ input)
+ (case (parser input)
+ (#try.Success [input' output])
+ (#try.Success [input output])
+
+ output
+ output)))
+
+(def: #export (codec codec parser)
+ (All [s a z] (-> (Codec a z) (Parser s a) (Parser s z)))
+ (function (_ input)
+ (case (parser input)
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success [input' to_decode])
+ (case (\ codec decode to_decode)
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success value)
+ (#try.Success [input' value])))))
diff --git a/stdlib/source/library/lux/control/parser/analysis.lux b/stdlib/source/library/lux/control/parser/analysis.lux
new file mode 100644
index 000000000..cdfb18504
--- /dev/null
+++ b/stdlib/source/library/lux/control/parser/analysis.lux
@@ -0,0 +1,135 @@
+(.module:
+ [library
+ [lux (#- nat int rev)
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." bit]
+ ["." name]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ [number
+ ["." i64]
+ ["." nat]
+ ["." int]
+ ["." rev]
+ ["." frac]]]
+ [tool
+ [compiler
+ [arity (#+ Arity)]
+ [reference (#+)
+ [variable (#+)]]
+ [language
+ [lux
+ ["/" analysis (#+ Variant Tuple Environment Analysis)]]]]]]]
+ ["." //])
+
+(def: (remaining_inputs asts)
+ (-> (List Analysis) Text)
+ (format text.new_line "Remaining input: "
+ (|> asts
+ (list\map /.%analysis)
+ (list.interpose " ")
+ (text.join_with ""))))
+
+(exception: #export (cannot_parse {input (List Analysis)})
+ (exception.report
+ ["Input" (exception.enumerate /.%analysis input)]))
+
+(exception: #export (unconsumed_input {input (List Analysis)})
+ (exception.report
+ ["Input" (exception.enumerate /.%analysis input)]))
+
+(type: #export Parser
+ (//.Parser (List Analysis)))
+
+(def: #export (run parser input)
+ (All [a] (-> (Parser a) (List Analysis) (Try a)))
+ (case (parser input)
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success [#.Nil value])
+ (#try.Success value)
+
+ (#try.Success [unconsumed _])
+ (exception.throw ..unconsumed_input unconsumed)))
+
+(def: #export any
+ (Parser Analysis)
+ (function (_ input)
+ (case input
+ #.Nil
+ (exception.throw ..cannot_parse input)
+
+ (#.Cons [head tail])
+ (#try.Success [tail head]))))
+
+(def: #export end!
+ {#.doc "Ensures there are no more inputs."}
+ (Parser Any)
+ (function (_ tokens)
+ (case tokens
+ #.Nil (#try.Success [tokens []])
+ _ (#try.Failure (format "Expected list of tokens to be empty!"
+ (remaining_inputs tokens))))))
+
+(def: #export end?
+ {#.doc "Checks whether there are no more inputs."}
+ (Parser Bit)
+ (function (_ tokens)
+ (#try.Success [tokens (case tokens
+ #.Nil true
+ _ false)])))
+
+(template [<query> <assertion> <tag> <type> <eq>]
+ [(def: #export <query>
+ (Parser <type>)
+ (function (_ input)
+ (case input
+ (^ (list& (<tag> x) input'))
+ (#try.Success [input' x])
+
+ _
+ (exception.throw ..cannot_parse input))))
+
+ (def: #export (<assertion> expected)
+ (-> <type> (Parser Any))
+ (function (_ input)
+ (case input
+ (^ (list& (<tag> actual) input'))
+ (if (\ <eq> = expected actual)
+ (#try.Success [input' []])
+ (exception.throw ..cannot_parse input))
+
+ _
+ (exception.throw ..cannot_parse input))))]
+
+ [bit bit! /.bit Bit bit.equivalence]
+ [nat nat! /.nat Nat nat.equivalence]
+ [int int! /.int Int int.equivalence]
+ [rev rev! /.rev Rev rev.equivalence]
+ [frac frac! /.frac Frac frac.equivalence]
+ [text text! /.text Text text.equivalence]
+ [local local! /.variable/local Nat nat.equivalence]
+ [foreign foreign! /.variable/foreign Nat nat.equivalence]
+ [constant constant! /.constant Name name.equivalence]
+ )
+
+(def: #export (tuple parser)
+ (All [a] (-> (Parser a) (Parser a)))
+ (function (_ input)
+ (case input
+ (^ (list& (/.tuple head) tail))
+ (do try.monad
+ [output (..run parser head)]
+ (#try.Success [tail output]))
+
+ _
+ (exception.throw ..cannot_parse input))))
diff --git a/stdlib/source/library/lux/control/parser/binary.lux b/stdlib/source/library/lux/control/parser/binary.lux
new file mode 100644
index 000000000..af28caeae
--- /dev/null
+++ b/stdlib/source/library/lux/control/parser/binary.lux
@@ -0,0 +1,275 @@
+(.module:
+ [library
+ [lux (#- and or nat int rev list type)
+ [type (#+ :share)]
+ [abstract
+ [hash (#+ Hash)]
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["/" binary (#+ Binary)]
+ [text
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." list]
+ ["." row (#+ Row)]
+ ["." set (#+ Set)]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["n" nat]
+ ["." frac]]]]]
+ ["." // ("#\." monad)])
+
+(type: #export Offset Nat)
+
+(type: #export Parser
+ (//.Parser [Offset Binary]))
+
+(exception: #export (binary_was_not_fully_read {binary_length Nat} {bytes_read Nat})
+ (exception.report
+ ["Binary length" (%.nat binary_length)]
+ ["Bytes read" (%.nat bytes_read)]))
+
+(def: #export (run parser input)
+ (All [a] (-> (Parser a) Binary (Try a)))
+ (case (parser [0 input])
+ (#try.Failure msg)
+ (#try.Failure msg)
+
+ (#try.Success [[end _] output])
+ (let [length (/.size input)]
+ (if (n.= end length)
+ (#try.Success output)
+ (exception.throw ..binary_was_not_fully_read [length end])))))
+
+(def: #export end?
+ (Parser Bit)
+ (function (_ (^@ input [offset data]))
+ (#try.Success [input (n.= offset (/.size data))])))
+
+(def: #export offset
+ (Parser Offset)
+ (function (_ (^@ input [offset data]))
+ (#try.Success [input offset])))
+
+(def: #export remaining
+ (Parser Nat)
+ (function (_ (^@ input [offset data]))
+ (#try.Success [input (n.- offset (/.size data))])))
+
+(type: #export Size Nat)
+
+(def: #export size/8 Size 1)
+(def: #export size/16 Size (n.* 2 size/8))
+(def: #export size/32 Size (n.* 2 size/16))
+(def: #export size/64 Size (n.* 2 size/32))
+
+(template [<name> <size> <read>]
+ [(def: #export <name>
+ (Parser I64)
+ (function (_ [offset binary])
+ (case (<read> offset binary)
+ (#try.Success data)
+ (#try.Success [(n.+ <size> offset) binary] data)
+
+ (#try.Failure error)
+ (#try.Failure error))))]
+
+ [bits/8 ..size/8 /.read/8]
+ [bits/16 ..size/16 /.read/16]
+ [bits/32 ..size/32 /.read/32]
+ [bits/64 ..size/64 /.read/64]
+ )
+
+(template [<name> <type>]
+ [(def: #export <name> (Parser <type>) ..bits/64)]
+
+ [nat Nat]
+ [int Int]
+ [rev Rev]
+ )
+
+(def: #export frac
+ (Parser Frac)
+ (//\map frac.from_bits ..bits/64))
+
+(exception: #export (invalid_tag {range Nat} {byte Nat})
+ (exception.report
+ ["Tag range" (%.nat range)]
+ ["Tag value" (%.nat byte)]))
+
+(template: (!variant <case>+)
+ (do {! //.monad}
+ [flag (: (Parser Nat)
+ ..bits/8)]
+ (`` (case flag
+ (^template [<number> <tag> <parser>]
+ [<number> (\ ! map (|>> <tag>) <parser>)])
+ ((~~ (template.splice <case>+)))
+ _ (//.lift (exception.throw ..invalid_tag [(~~ (template.count <case>+)) flag]))))))
+
+(def: #export (or left right)
+ (All [l r] (-> (Parser l) (Parser r) (Parser (| l r))))
+ (!variant [[0 #.Left left]
+ [1 #.Right right]]))
+
+(def: #export (rec body)
+ (All [a] (-> (-> (Parser a) (Parser a)) (Parser a)))
+ (function (_ input)
+ (let [parser (body (rec body))]
+ (parser input))))
+
+(def: #export any
+ (Parser Any)
+ (//\wrap []))
+
+(exception: #export (not_a_bit {value Nat})
+ (exception.report
+ ["Expected values" "either 0 or 1"]
+ ["Actual value" (%.nat value)]))
+
+(def: #export bit
+ (Parser Bit)
+ (do //.monad
+ [value (: (Parser Nat)
+ ..bits/8)]
+ (case value
+ 0 (wrap #0)
+ 1 (wrap #1)
+ _ (//.lift (exception.throw ..not_a_bit [value])))))
+
+(def: #export (segment size)
+ (-> Nat (Parser Binary))
+ (function (_ [offset binary])
+ (case size
+ 0 (#try.Success [[offset binary] (/.create 0)])
+ _ (|> binary
+ (/.slice offset size)
+ (\ try.monad map (|>> [[(n.+ size offset) binary]]))))))
+
+(template [<name> <bits>]
+ [(def: #export <name>
+ (Parser Binary)
+ (do //.monad
+ [size (//\map .nat <bits>)]
+ (..segment size)))]
+
+ [binary/8 ..bits/8]
+ [binary/16 ..bits/16]
+ [binary/32 ..bits/32]
+ [binary/64 ..bits/64]
+ )
+
+(template [<name> <binary>]
+ [(def: #export <name>
+ (Parser Text)
+ (do //.monad
+ [utf8 <binary>]
+ (//.lift (\ utf8.codec decode utf8))))]
+
+ [utf8/8 ..binary/8]
+ [utf8/16 ..binary/16]
+ [utf8/32 ..binary/32]
+ [utf8/64 ..binary/64]
+ )
+
+(def: #export text ..utf8/64)
+
+(template [<name> <bits>]
+ [(def: #export (<name> valueP)
+ (All [v] (-> (Parser v) (Parser (Row v))))
+ (do //.monad
+ [count (: (Parser Nat)
+ <bits>)]
+ (loop [index 0
+ output (:share [v]
+ (Parser v)
+ valueP
+
+ (Row v)
+ row.empty)]
+ (if (n.< count index)
+ (do //.monad
+ [value valueP]
+ (recur (.inc index)
+ (row.add value output)))
+ (//\wrap output)))))]
+
+ [row/8 ..bits/8]
+ [row/16 ..bits/16]
+ [row/32 ..bits/32]
+ [row/64 ..bits/64]
+ )
+
+(def: #export maybe
+ (All [a] (-> (Parser a) (Parser (Maybe a))))
+ (..or ..any))
+
+(def: #export (list value)
+ (All [a] (-> (Parser a) (Parser (List a))))
+ (..rec
+ (|>> (//.and value)
+ (..or ..any))))
+
+(exception: #export set_elements_are_not_unique)
+
+(def: #export (set hash value)
+ (All [a] (-> (Hash a) (Parser a) (Parser (Set a))))
+ (do //.monad
+ [raw (..list value)
+ #let [output (set.from_list hash raw)]
+ _ (//.assert (exception.construct ..set_elements_are_not_unique [])
+ (n.= (list.size raw)
+ (set.size output)))]
+ (wrap output)))
+
+(def: #export name
+ (Parser Name)
+ (//.and ..text ..text))
+
+(def: #export type
+ (Parser Type)
+ (..rec
+ (function (_ type)
+ (let [pair (//.and type type)
+ indexed ..nat
+ quantified (//.and (..list type) type)]
+ (!variant [[0 #.Primitive (//.and ..text (..list type))]
+ [1 #.Sum pair]
+ [2 #.Product pair]
+ [3 #.Function pair]
+ [4 #.Parameter indexed]
+ [5 #.Var indexed]
+ [6 #.Ex indexed]
+ [7 #.UnivQ quantified]
+ [8 #.ExQ quantified]
+ [9 #.Apply pair]
+ [10 #.Named (//.and ..name type)]])))))
+
+(def: #export location
+ (Parser Location)
+ ($_ //.and ..text ..nat ..nat))
+
+(def: #export code
+ (Parser Code)
+ (..rec
+ (function (_ recur)
+ (let [sequence (..list recur)]
+ (//.and ..location
+ (!variant [[0 #.Bit ..bit]
+ [1 #.Nat ..nat]
+ [2 #.Int ..int]
+ [3 #.Rev ..rev]
+ [4 #.Frac ..frac]
+ [5 #.Text ..text]
+ [6 #.Identifier ..name]
+ [7 #.Tag ..name]
+ [8 #.Form sequence]
+ [9 #.Tuple sequence]
+ [10 #.Record (..list (//.and recur recur))]]))))))
diff --git a/stdlib/source/library/lux/control/parser/cli.lux b/stdlib/source/library/lux/control/parser/cli.lux
new file mode 100644
index 000000000..34b061afc
--- /dev/null
+++ b/stdlib/source/library/lux/control/parser/cli.lux
@@ -0,0 +1,99 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]]]
+ ["." //])
+
+(type: #export (Parser a)
+ {#.doc "A command-line interface parser."}
+ (//.Parser (List Text) a))
+
+(def: #export (run parser inputs)
+ (All [a] (-> (Parser a) (List Text) (Try a)))
+ (case (//.run parser inputs)
+ (#try.Success [remaining output])
+ (case remaining
+ #.Nil
+ (#try.Success output)
+
+ _
+ (#try.Failure (format "Remaining CLI inputs: " (text.join_with " " remaining))))
+
+ (#try.Failure try)
+ (#try.Failure try)))
+
+(def: #export any
+ {#.doc "Just returns the next input without applying any logic."}
+ (Parser Text)
+ (function (_ inputs)
+ (case inputs
+ (#.Cons arg inputs')
+ (#try.Success [inputs' arg])
+
+ _
+ (#try.Failure "Cannot parse empty arguments."))))
+
+(def: #export (parse parser)
+ {#.doc "Parses the next input with a parsing function."}
+ (All [a] (-> (-> Text (Try a)) (Parser a)))
+ (function (_ inputs)
+ (do try.monad
+ [[remaining raw] (any inputs)
+ output (parser raw)]
+ (wrap [remaining output]))))
+
+(def: #export (this reference)
+ {#.doc "Checks that a token is in the inputs."}
+ (-> Text (Parser Any))
+ (function (_ inputs)
+ (do try.monad
+ [[remaining raw] (any inputs)]
+ (if (text\= reference raw)
+ (wrap [remaining []])
+ (try.fail (format "Missing token: '" reference "'"))))))
+
+(def: #export (somewhere cli)
+ {#.doc "Given a parser, tries to parse it somewhere in the inputs (i.e. not necessarily parsing the immediate inputs)."}
+ (All [a] (-> (Parser a) (Parser a)))
+ (function (_ inputs)
+ (loop [immediate inputs]
+ (case (//.run cli immediate)
+ (#try.Success [remaining output])
+ (#try.Success [remaining output])
+
+ (#try.Failure try)
+ (case immediate
+ #.Nil
+ (#try.Failure try)
+
+ (#.Cons to_omit immediate')
+ (do try.monad
+ [[remaining output] (recur immediate')]
+ (wrap [(#.Cons to_omit remaining)
+ output])))))))
+
+(def: #export end
+ {#.doc "Ensures there are no more inputs."}
+ (Parser Any)
+ (function (_ inputs)
+ (case inputs
+ #.Nil (#try.Success [inputs []])
+ _ (#try.Failure (format "Unknown parameters: " (text.join_with " " inputs))))))
+
+(def: #export (named name value)
+ (All [a] (-> Text (Parser a) (Parser a)))
+ (|> value
+ (//.after (..this name))
+ ..somewhere))
+
+(def: #export (parameter [short long] value)
+ (All [a] (-> [Text Text] (Parser a) (Parser a)))
+ (|> value
+ (//.after (//.either (..this short) (..this long)))
+ ..somewhere))
diff --git a/stdlib/source/library/lux/control/parser/code.lux b/stdlib/source/library/lux/control/parser/code.lux
new file mode 100644
index 000000000..bb37c1faf
--- /dev/null
+++ b/stdlib/source/library/lux/control/parser/code.lux
@@ -0,0 +1,199 @@
+(.module:
+ [library
+ [lux (#- nat int rev)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ ["." bit]
+ ["." text ("#\." monoid)]
+ ["." name]
+ [collection
+ ["." list ("#\." functor)]]]
+ [macro
+ ["." code ("#\." equivalence)]]
+ [math
+ [number
+ ["." nat]
+ ["." int]
+ ["." rev]
+ ["." frac]]]]]
+ ["." //])
+
+(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'))))
+
+(type: #export Parser
+ {#.doc "A Lux syntax parser."}
+ (//.Parser (List Code)))
+
+(def: (remaining_inputs asts)
+ (-> (List Code) Text)
+ ($_ text\compose text.new_line "Remaining input: "
+ (|> asts (list\map code.format) (list.interpose " ") (text.join_with ""))))
+
+(def: #export any
+ {#.doc "Just returns the next input without applying any logic."}
+ (Parser Code)
+ (function (_ tokens)
+ (case tokens
+ #.Nil
+ (#try.Failure "There are no tokens to parse!")
+
+ (#.Cons [t tokens'])
+ (#try.Success [tokens' t]))))
+
+(template [<query> <check> <type> <tag> <eq> <desc>]
+ [(with_expansions [<failure> (as_is (#try.Failure ($_ text\compose "Cannot parse " <desc> (remaining_inputs tokens))))]
+ (def: #export <query>
+ {#.doc (code.text ($_ text\compose "Parses the next " <desc> " input."))}
+ (Parser <type>)
+ (function (_ tokens)
+ (case tokens
+ (#.Cons [[_ (<tag> x)] tokens'])
+ (#try.Success [tokens' x])
+
+ _
+ <failure>)))
+
+ (def: #export (<check> expected)
+ (-> <type> (Parser Any))
+ (function (_ tokens)
+ (case tokens
+ (#.Cons [[_ (<tag> actual)] tokens'])
+ (if (\ <eq> = expected actual)
+ (#try.Success [tokens' []])
+ <failure>)
+
+ _
+ <failure>))))]
+
+ [bit bit! Bit #.Bit bit.equivalence "bit"]
+ [nat nat! Nat #.Nat nat.equivalence "nat"]
+ [int int! Int #.Int int.equivalence "int"]
+ [rev rev! Rev #.Rev rev.equivalence "rev"]
+ [frac frac! Frac #.Frac frac.equivalence "frac"]
+ [text text! Text #.Text text.equivalence "text"]
+ [identifier identifier! Name #.Identifier name.equivalence "identifier"]
+ [tag tag! Name #.Tag name.equivalence "tag"]
+ )
+
+(def: #export (this! ast)
+ {#.doc "Ensures the given Code is the next input."}
+ (-> Code (Parser Any))
+ (function (_ tokens)
+ (case tokens
+ (#.Cons [token tokens'])
+ (if (code\= ast token)
+ (#try.Success [tokens' []])
+ (#try.Failure ($_ text\compose "Expected a " (code.format ast) " but instead got " (code.format token)
+ (remaining_inputs tokens))))
+
+ _
+ (#try.Failure "There are no tokens to parse!"))))
+
+(template [<query> <check> <tag> <eq> <desc>]
+ [(with_expansions [<failure> (as_is (#try.Failure ($_ text\compose "Cannot parse " <desc> (remaining_inputs tokens))))]
+ (def: #export <query>
+ {#.doc (code.text ($_ text\compose "Parse a local " <desc> " (a " <desc> " that has no module prefix)."))}
+ (Parser Text)
+ (function (_ tokens)
+ (case tokens
+ (#.Cons [[_ (<tag> ["" x])] tokens'])
+ (#try.Success [tokens' x])
+
+ _
+ <failure>)))
+
+ (def: #export (<check> expected)
+ (-> Text (Parser Any))
+ (function (_ tokens)
+ (case tokens
+ (#.Cons [[_ (<tag> ["" actual])] tokens'])
+ (if (\ <eq> = expected actual)
+ (#try.Success [tokens' []])
+ <failure>)
+
+ _
+ <failure>))))]
+
+ [local_identifier local_identifier! #.Identifier text.equivalence "local identifier"]
+ [ local_tag local_tag! #.Tag text.equivalence "local tag"]
+ )
+
+(template [<name> <tag> <desc>]
+ [(def: #export (<name> p)
+ {#.doc (code.text ($_ text\compose "Parse inside the contents of a " <desc> " as if they were the input Codes."))}
+ (All [a]
+ (-> (Parser a) (Parser a)))
+ (function (_ tokens)
+ (case tokens
+ (#.Cons [[_ (<tag> members)] tokens'])
+ (case (p members)
+ (#try.Success [#.Nil x]) (#try.Success [tokens' x])
+ _ (#try.Failure ($_ text\compose "Parser was expected to fully consume " <desc> (remaining_inputs tokens))))
+
+ _
+ (#try.Failure ($_ text\compose "Cannot parse " <desc> (remaining_inputs tokens))))))]
+
+ [ form #.Form "form"]
+ [tuple #.Tuple "tuple"]
+ )
+
+(def: #export (record p)
+ {#.doc (code.text ($_ text\compose "Parse inside the contents of a record as if they were the input Codes."))}
+ (All [a]
+ (-> (Parser a) (Parser a)))
+ (function (_ tokens)
+ (case tokens
+ (#.Cons [[_ (#.Record pairs)] tokens'])
+ (case (p (join_pairs pairs))
+ (#try.Success [#.Nil x]) (#try.Success [tokens' x])
+ _ (#try.Failure ($_ text\compose "Parser was expected to fully consume record" (remaining_inputs tokens))))
+
+ _
+ (#try.Failure ($_ text\compose "Cannot parse record" (remaining_inputs tokens))))))
+
+(def: #export end!
+ {#.doc "Ensures there are no more inputs."}
+ (Parser Any)
+ (function (_ tokens)
+ (case tokens
+ #.Nil (#try.Success [tokens []])
+ _ (#try.Failure ($_ text\compose "Expected list of tokens to be empty!" (remaining_inputs tokens))))))
+
+(def: #export end?
+ {#.doc "Checks whether there are no more inputs."}
+ (Parser Bit)
+ (function (_ tokens)
+ (#try.Success [tokens (case tokens
+ #.Nil true
+ _ false)])))
+
+(def: #export (run syntax inputs)
+ (All [a] (-> (Parser a) (List Code) (Try a)))
+ (case (syntax inputs)
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success [unconsumed value])
+ (case unconsumed
+ #.Nil
+ (#try.Success value)
+
+ _
+ (#try.Failure (text\compose "Unconsumed inputs: "
+ (|> (list\map code.format unconsumed)
+ (text.join_with ", ")))))))
+
+(def: #export (local inputs syntax)
+ {#.doc "Run a syntax parser with the given list of inputs, instead of the real ones."}
+ (All [a] (-> (List Code) (Parser a) (Parser a)))
+ (function (_ real)
+ (do try.monad
+ [value (..run syntax inputs)]
+ (wrap [real value]))))
diff --git a/stdlib/source/library/lux/control/parser/environment.lux b/stdlib/source/library/lux/control/parser/environment.lux
new file mode 100644
index 000000000..c0ced37c2
--- /dev/null
+++ b/stdlib/source/library/lux/control/parser/environment.lux
@@ -0,0 +1,44 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary (#+ Dictionary)]]]]]
+ ["." //])
+
+(type: #export Property
+ Text)
+
+(type: #export Environment
+ (Dictionary Property Text))
+
+(exception: #export (unknown {property Property})
+ (exception.report
+ ["Property" (%.text property)]))
+
+(type: #export (Parser a)
+ (//.Parser Environment a))
+
+(def: #export empty
+ Environment
+ (dictionary.new text.hash))
+
+(def: #export (property name)
+ (-> Text (Parser Text))
+ (function (_ environment)
+ (case (dictionary.get name environment)
+ (#.Some value)
+ (exception.return [environment value])
+
+ #.None
+ (exception.throw ..unknown name))))
+
+(def: #export (run parser environment)
+ (All [a] (-> (Parser a) Environment (Try a)))
+ (\ try.monad map product.right (parser environment)))
diff --git a/stdlib/source/library/lux/control/parser/json.lux b/stdlib/source/library/lux/control/parser/json.lux
new file mode 100644
index 000000000..12fb90dd3
--- /dev/null
+++ b/stdlib/source/library/lux/control/parser/json.lux
@@ -0,0 +1,207 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." bit]
+ ["." text ("#\." equivalence monoid)]
+ [collection
+ ["." list ("#\." functor)]
+ ["." row]
+ ["." dictionary (#+ Dictionary)]]
+ [format
+ ["/" json (#+ JSON)]]]
+ [macro
+ ["." code]]
+ [math
+ [number
+ ["." frac]]]]]
+ ["." // ("#\." functor)])
+
+(type: #export (Parser a)
+ {#.doc "JSON parser."}
+ (//.Parser (List JSON) a))
+
+(exception: #export (unconsumed_input {input (List JSON)})
+ (exception.report
+ ["Input" (exception.enumerate /.format input)]))
+
+(exception: #export empty_input)
+
+(def: #export (run parser json)
+ (All [a] (-> (Parser a) JSON (Try a)))
+ (case (//.run parser (list json))
+ (#try.Success [remainder output])
+ (case remainder
+ #.Nil
+ (#try.Success output)
+
+ _
+ (exception.throw ..unconsumed_input remainder))
+
+ (#try.Failure error)
+ (#try.Failure error)))
+
+(def: #export any
+ {#.doc "Just returns the JSON input without applying any logic."}
+ (Parser JSON)
+ (<| (function (_ inputs))
+ (case inputs
+ #.Nil
+ (exception.throw ..empty_input [])
+
+ (#.Cons head tail)
+ (#try.Success [tail head]))))
+
+(exception: #export (unexpected_value {value JSON})
+ (exception.report
+ ["Value" (/.format value)]))
+
+(template [<name> <type> <tag> <desc>]
+ [(def: #export <name>
+ {#.doc (code.text ($_ text\compose "Reads a JSON value as " <desc> "."))}
+ (Parser <type>)
+ (do //.monad
+ [head ..any]
+ (case head
+ (<tag> value)
+ (wrap value)
+
+ _
+ (//.fail (exception.construct ..unexpected_value [head])))))]
+
+ [null /.Null #/.Null "null"]
+ [boolean /.Boolean #/.Boolean "boolean"]
+ [number /.Number #/.Number "number"]
+ [string /.String #/.String "string"]
+ )
+
+(exception: #export [a] (value_mismatch {reference JSON} {sample JSON})
+ (exception.report
+ ["Reference" (/.format reference)]
+ ["Sample" (/.format sample)]))
+
+(template [<test> <check> <type> <equivalence> <tag> <desc>]
+ [(def: #export (<test> test)
+ {#.doc (code.text ($_ text\compose "Asks whether a JSON value is a " <desc> "."))}
+ (-> <type> (Parser Bit))
+ (do //.monad
+ [head ..any]
+ (case head
+ (<tag> value)
+ (wrap (\ <equivalence> = test value))
+
+ _
+ (//.fail (exception.construct ..unexpected_value [head])))))
+
+ (def: #export (<check> test)
+ {#.doc (code.text ($_ text\compose "Ensures a JSON value is a " <desc> "."))}
+ (-> <type> (Parser Any))
+ (do //.monad
+ [head ..any]
+ (case head
+ (<tag> value)
+ (if (\ <equivalence> = test value)
+ (wrap [])
+ (//.fail (exception.construct ..value_mismatch [(<tag> test) (<tag> value)])))
+
+ _
+ (//.fail (exception.construct ..unexpected_value [head])))))]
+
+ [boolean? boolean! /.Boolean bit.equivalence #/.Boolean "boolean"]
+ [number? number! /.Number frac.equivalence #/.Number "number"]
+ [string? string! /.String text.equivalence #/.String "string"]
+ )
+
+(def: #export (nullable parser)
+ (All [a] (-> (Parser a) (Parser (Maybe a))))
+ (//.or ..null
+ parser))
+
+(def: #export (array parser)
+ {#.doc "Parses a JSON array."}
+ (All [a] (-> (Parser a) (Parser a)))
+ (do //.monad
+ [head ..any]
+ (case head
+ (#/.Array values)
+ (case (//.run parser (row.to_list values))
+ (#try.Failure error)
+ (//.fail error)
+
+ (#try.Success [remainder output])
+ (case remainder
+ #.Nil
+ (wrap output)
+
+ _
+ (//.fail (exception.construct ..unconsumed_input remainder))))
+
+ _
+ (//.fail (exception.construct ..unexpected_value [head])))))
+
+(def: #export (object parser)
+ {#.doc "Parses a JSON object. Use this with the 'field' combinator."}
+ (All [a] (-> (Parser a) (Parser a)))
+ (do //.monad
+ [head ..any]
+ (case head
+ (#/.Object kvs)
+ (case (|> kvs
+ dictionary.entries
+ (list\map (function (_ [key value])
+ (list (#/.String key) value)))
+ list.concat
+ (//.run parser))
+ (#try.Failure error)
+ (//.fail error)
+
+ (#try.Success [remainder output])
+ (case remainder
+ #.Nil
+ (wrap output)
+
+ _
+ (//.fail (exception.construct ..unconsumed_input remainder))))
+
+ _
+ (//.fail (exception.construct ..unexpected_value [head])))))
+
+(def: #export (field field_name parser)
+ {#.doc "Parses a field inside a JSON object. Use this inside the 'object' combinator."}
+ (All [a] (-> Text (Parser a) (Parser a)))
+ (function (recur inputs)
+ (case inputs
+ (^ (list& (#/.String key) value inputs'))
+ (if (text\= key field_name)
+ (case (//.run parser (list value))
+ (#try.Success [#.Nil output])
+ (#try.Success [inputs' output])
+
+ (#try.Success [inputs'' _])
+ (exception.throw ..unconsumed_input inputs'')
+
+ (#try.Failure error)
+ (#try.Failure error))
+ (do try.monad
+ [[inputs'' output] (recur inputs')]
+ (wrap [(list& (#/.String key) value inputs'')
+ output])))
+
+ #.Nil
+ (exception.throw ..empty_input [])
+
+ _
+ (exception.throw ..unconsumed_input inputs))))
+
+(def: #export dictionary
+ {#.doc "Parses a dictionary-like JSON object."}
+ (All [a] (-> (Parser a) (Parser (Dictionary Text a))))
+ (|>> (//.and ..string)
+ //.some
+ ..object
+ (//\map (dictionary.from_list text.hash))))
diff --git a/stdlib/source/library/lux/control/parser/synthesis.lux b/stdlib/source/library/lux/control/parser/synthesis.lux
new file mode 100644
index 000000000..9c8f76143
--- /dev/null
+++ b/stdlib/source/library/lux/control/parser/synthesis.lux
@@ -0,0 +1,164 @@
+(.module:
+ [library
+ [lux (#- function loop i64)
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." bit]
+ ["." name]
+ ["." text
+ ["%" format (#+ format)]]]
+ [math
+ [number
+ ["n" nat]
+ ["." i64]
+ ["." frac]]]
+ [tool
+ [compiler
+ [reference (#+)
+ [variable (#+ Register)]]
+ [arity (#+ Arity)]
+ [language
+ [lux
+ [analysis (#+ Variant Tuple Environment)]
+ ["/" synthesis (#+ Synthesis Abstraction)]]]]]]]
+ ["." //])
+
+## TODO: Use "type:" ASAP.
+(def: Input
+ Type
+ (type (List Synthesis)))
+
+(exception: #export (cannot_parse {input ..Input})
+ (exception.report
+ ["Input" (exception.enumerate /.%synthesis input)]))
+
+(exception: #export (unconsumed_input {input ..Input})
+ (exception.report
+ ["Input" (exception.enumerate /.%synthesis input)]))
+
+(exception: #export (expected_empty_input {input ..Input})
+ (exception.report
+ ["Input" (exception.enumerate /.%synthesis input)]))
+
+(exception: #export (wrong_arity {expected Arity} {actual Arity})
+ (exception.report
+ ["Expected" (%.nat expected)]
+ ["Actual" (%.nat actual)]))
+
+(exception: #export empty_input)
+
+(type: #export Parser
+ (//.Parser ..Input))
+
+(def: #export (run parser input)
+ (All [a] (-> (Parser a) ..Input (Try a)))
+ (case (parser input)
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success [#.Nil value])
+ (#try.Success value)
+
+ (#try.Success [unconsumed _])
+ (exception.throw ..unconsumed_input unconsumed)))
+
+(def: #export any
+ (Parser Synthesis)
+ (.function (_ input)
+ (case input
+ #.Nil
+ (exception.throw ..empty_input [])
+
+ (#.Cons [head tail])
+ (#try.Success [tail head]))))
+
+(def: #export end!
+ {#.doc "Ensures there are no more inputs."}
+ (Parser Any)
+ (.function (_ tokens)
+ (case tokens
+ #.Nil (#try.Success [tokens []])
+ _ (exception.throw ..expected_empty_input [tokens]))))
+
+(def: #export end?
+ {#.doc "Checks whether there are no more inputs."}
+ (Parser Bit)
+ (.function (_ tokens)
+ (#try.Success [tokens (case tokens
+ #.Nil true
+ _ false)])))
+
+(template [<query> <assertion> <tag> <type> <eq>]
+ [(def: #export <query>
+ (Parser <type>)
+ (.function (_ input)
+ (case input
+ (^ (list& (<tag> x) input'))
+ (#try.Success [input' x])
+
+ _
+ (exception.throw ..cannot_parse input))))
+
+ (def: #export (<assertion> expected)
+ (-> <type> (Parser Any))
+ (.function (_ input)
+ (case input
+ (^ (list& (<tag> actual) input'))
+ (if (\ <eq> = expected actual)
+ (#try.Success [input' []])
+ (exception.throw ..cannot_parse input))
+
+ _
+ (exception.throw ..cannot_parse input))))]
+
+ [bit bit! /.bit Bit bit.equivalence]
+ [i64 i64! /.i64 (I64 Any) i64.equivalence]
+ [f64 f64! /.f64 Frac frac.equivalence]
+ [text text! /.text Text text.equivalence]
+ [local local! /.variable/local Nat n.equivalence]
+ [foreign foreign! /.variable/foreign Nat n.equivalence]
+ [constant constant! /.constant Name name.equivalence]
+ )
+
+(def: #export (tuple parser)
+ (All [a] (-> (Parser a) (Parser a)))
+ (.function (_ input)
+ (case input
+ (^ (list& (/.tuple head) tail))
+ (do try.monad
+ [output (..run parser head)]
+ (#try.Success [tail output]))
+
+ _
+ (exception.throw ..cannot_parse input))))
+
+(def: #export (function expected parser)
+ (All [a] (-> Arity (Parser a) (Parser [(Environment Synthesis) a])))
+ (.function (_ input)
+ (case input
+ (^ (list& (/.function/abstraction [environment actual body]) tail))
+ (if (n.= expected actual)
+ (do try.monad
+ [output (..run parser (list body))]
+ (#try.Success [tail [environment output]]))
+ (exception.throw ..wrong_arity [expected actual]))
+
+ _
+ (exception.throw ..cannot_parse input))))
+
+(def: #export (loop init_parsers iteration_parser)
+ (All [a b] (-> (Parser a) (Parser b) (Parser [Register a b])))
+ (.function (_ input)
+ (case input
+ (^ (list& (/.loop/scope [start inits iteration]) tail))
+ (do try.monad
+ [inits (..run init_parsers inits)
+ iteration (..run iteration_parser (list iteration))]
+ (#try.Success [tail [start inits iteration]]))
+
+ _
+ (exception.throw ..cannot_parse input))))
diff --git a/stdlib/source/library/lux/control/parser/text.lux b/stdlib/source/library/lux/control/parser/text.lux
new file mode 100644
index 000000000..cfd1ab891
--- /dev/null
+++ b/stdlib/source/library/lux/control/parser/text.lux
@@ -0,0 +1,377 @@
+(.module:
+ [library
+ [lux (#- or and not)
+ [abstract
+ [monad (#+ Monad do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["/" text (#+ Char) ("#\." monoid)]
+ ["." product]
+ ["." maybe]
+ [collection
+ ["." list ("#\." fold)]]]
+ [macro
+ ["." code]]
+ [math
+ [number
+ ["n" nat ("#\." decimal)]]]]]
+ ["." //])
+
+(type: #export Offset Nat)
+
+(def: start_offset Offset 0)
+
+(type: #export Parser
+ (//.Parser [Offset Text]))
+
+(type: #export Slice
+ {#basis Offset
+ #distance Offset})
+
+(def: (remaining offset tape)
+ (-> Offset Text Text)
+ (|> tape (/.split offset) maybe.assume product.right))
+
+(exception: #export (unconsumed_input {offset Offset} {tape Text})
+ (exception.report
+ ["Offset" (n\encode offset)]
+ ["Input size" (n\encode (/.size tape))]
+ ["Remaining input" (remaining offset tape)]))
+
+(exception: #export (expected_to_fail {offset Offset} {tape Text})
+ (exception.report
+ ["Offset" (n\encode offset)]
+ ["Input" (remaining offset tape)]))
+
+(exception: #export cannot_parse)
+(exception: #export cannot_slice)
+
+(def: #export (run parser input)
+ (All [a] (-> (Parser a) Text (Try a)))
+ (case (parser [start_offset input])
+ (#try.Failure msg)
+ (#try.Failure msg)
+
+ (#try.Success [[end_offset _] output])
+ (if (n.= end_offset (/.size input))
+ (#try.Success output)
+ (exception.throw ..unconsumed_input [end_offset input]))))
+
+(def: #export offset
+ (Parser Offset)
+ (function (_ (^@ input [offset tape]))
+ (#try.Success [input offset])))
+
+(def: (with_slices parser)
+ (-> (Parser (List Slice)) (Parser Slice))
+ (do //.monad
+ [offset ..offset
+ slices parser]
+ (wrap (list\fold (function (_ [slice::basis slice::distance]
+ [total::basis total::distance])
+ [total::basis ("lux i64 +" slice::distance total::distance)])
+ {#basis offset
+ #distance 0}
+ slices))))
+
+(def: #export any
+ {#.doc "Just returns the next character without applying any logic."}
+ (Parser Text)
+ (function (_ [offset tape])
+ (case (/.nth offset tape)
+ (#.Some output)
+ (#try.Success [[("lux i64 +" 1 offset) tape] (/.from_code output)])
+
+ _
+ (exception.throw ..cannot_parse []))))
+
+(def: #export any!
+ {#.doc "Just returns the next character without applying any logic."}
+ (Parser Slice)
+ (function (_ [offset tape])
+ (case (/.nth offset tape)
+ (#.Some _)
+ (#try.Success [[("lux i64 +" 1 offset) tape]
+ {#basis offset
+ #distance 1}])
+
+ _
+ (exception.throw ..cannot_slice []))))
+
+(template [<name> <type> <any>]
+ [(def: #export (<name> p)
+ {#.doc "Produce a character if the parser fails."}
+ (All [a] (-> (Parser a) (Parser <type>)))
+ (function (_ input)
+ (case (p input)
+ (#try.Failure msg)
+ (<any> input)
+
+ _
+ (exception.throw ..expected_to_fail input))))]
+
+ [not Text ..any]
+ [not! Slice ..any!]
+ )
+
+(exception: #export (cannot_match {reference Text})
+ (exception.report
+ ["Reference" (/.format reference)]))
+
+(def: #export (this reference)
+ {#.doc "Lex a text if it matches the given sample."}
+ (-> Text (Parser Any))
+ (function (_ [offset tape])
+ (case (/.index_of' reference offset tape)
+ (#.Some where)
+ (if (n.= offset where)
+ (#try.Success [[("lux i64 +" (/.size reference) offset) tape]
+ []])
+ (exception.throw ..cannot_match [reference]))
+
+ _
+ (exception.throw ..cannot_match [reference]))))
+
+(def: #export end!
+ {#.doc "Ensure the parser's input is empty."}
+ (Parser Any)
+ (function (_ (^@ input [offset tape]))
+ (if (n.= offset (/.size tape))
+ (#try.Success [input []])
+ (exception.throw ..unconsumed_input input))))
+
+(def: #export peek
+ {#.doc "Lex the next character (without consuming it from the input)."}
+ (Parser Text)
+ (function (_ (^@ input [offset tape]))
+ (case (/.nth offset tape)
+ (#.Some output)
+ (#try.Success [input (/.from_code output)])
+
+ _
+ (exception.throw ..cannot_parse []))))
+
+(def: #export get_input
+ {#.doc "Get all of the remaining input (without consuming it)."}
+ (Parser Text)
+ (function (_ (^@ input [offset tape]))
+ (#try.Success [input (remaining offset tape)])))
+
+(def: #export (range bottom top)
+ {#.doc "Only lex characters within a range."}
+ (-> Nat Nat (Parser Text))
+ (do //.monad
+ [char any
+ #let [char' (maybe.assume (/.nth 0 char))]
+ _ (//.assert ($_ /\compose "Character is not within range: " (/.from_code bottom) "-" (/.from_code top))
+ (.and (n.>= bottom char')
+ (n.<= top char')))]
+ (wrap char)))
+
+(template [<name> <bottom> <top> <desc>]
+ [(def: #export <name>
+ {#.doc (code.text ($_ /\compose "Only lex " <desc> " characters."))}
+ (Parser Text)
+ (..range (char <bottom>) (char <top>)))]
+
+ [upper "A" "Z" "uppercase"]
+ [lower "a" "z" "lowercase"]
+ [decimal "0" "9" "decimal"]
+ [octal "0" "7" "octal"]
+ )
+
+(def: #export alpha
+ {#.doc "Only lex alphabetic characters."}
+ (Parser Text)
+ (//.either lower upper))
+
+(def: #export alpha_num
+ {#.doc "Only lex alphanumeric characters."}
+ (Parser Text)
+ (//.either alpha decimal))
+
+(def: #export hexadecimal
+ {#.doc "Only lex hexadecimal digits."}
+ (Parser Text)
+ ($_ //.either
+ decimal
+ (range (char "a") (char "f"))
+ (range (char "A") (char "F"))))
+
+(template [<name>]
+ [(exception: #export (<name> {options Text} {character Char})
+ (exception.report
+ ["Options" (/.format options)]
+ ["Character" (/.format (/.from_code character))]))]
+
+ [character_should_be]
+ [character_should_not_be]
+ )
+
+(template [<name> <modifier> <exception> <description_modifier>]
+ [(def: #export (<name> options)
+ {#.doc (code.text ($_ /\compose "Only lex characters that are" <description_modifier> " part of a piece of text."))}
+ (-> Text (Parser Text))
+ (function (_ [offset tape])
+ (case (/.nth offset tape)
+ (#.Some output)
+ (let [output' (/.from_code output)]
+ (if (<modifier> (/.contains? output' options))
+ (#try.Success [[("lux i64 +" 1 offset) tape] output'])
+ (exception.throw <exception> [options output])))
+
+ _
+ (exception.throw ..cannot_parse []))))]
+
+ [one_of |> ..character_should_be ""]
+ [none_of .not ..character_should_not_be " not"]
+ )
+
+(template [<name> <modifier> <exception> <description_modifier>]
+ [(def: #export (<name> options)
+ {#.doc (code.text ($_ /\compose "Only lex characters that are" <description_modifier> " part of a piece of text."))}
+ (-> Text (Parser Slice))
+ (function (_ [offset tape])
+ (case (/.nth offset tape)
+ (#.Some output)
+ (let [output' (/.from_code output)]
+ (if (<modifier> (/.contains? output' options))
+ (#try.Success [[("lux i64 +" 1 offset) tape]
+ {#basis offset
+ #distance 1}])
+ (exception.throw <exception> [options output])))
+
+ _
+ (exception.throw ..cannot_slice []))))]
+
+ [one_of! |> ..character_should_be ""]
+ [none_of! .not ..character_should_not_be " not"]
+ )
+
+(exception: #export (character_does_not_satisfy_predicate {character Char})
+ (exception.report
+ ["Character" (/.format (/.from_code character))]))
+
+(def: #export (satisfies p)
+ {#.doc "Only lex characters that satisfy a predicate."}
+ (-> (-> Char Bit) (Parser Text))
+ (function (_ [offset tape])
+ (case (/.nth offset tape)
+ (#.Some output)
+ (if (p output)
+ (#try.Success [[("lux i64 +" 1 offset) tape] (/.from_code output)])
+ (exception.throw ..character_does_not_satisfy_predicate [output]))
+
+ _
+ (exception.throw ..cannot_parse []))))
+
+(def: #export space
+ {#.doc "Only lex white-space."}
+ (Parser Text)
+ (..satisfies /.space?))
+
+(def: #export (and left right)
+ (-> (Parser Text) (Parser Text) (Parser Text))
+ (do //.monad
+ [=left left
+ =right right]
+ (wrap ($_ /\compose =left =right))))
+
+(def: #export (and! left right)
+ (-> (Parser Slice) (Parser Slice) (Parser Slice))
+ (do //.monad
+ [[left::basis left::distance] left
+ [right::basis right::distance] right]
+ (wrap [left::basis ("lux i64 +" left::distance right::distance)])))
+
+(template [<name> <base> <doc_modifier>]
+ [(def: #export (<name> parser)
+ {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " characters as a single continuous text."))}
+ (-> (Parser Text) (Parser Text))
+ (|> parser <base> (\ //.monad map /.concat)))]
+
+ [some //.some "some"]
+ [many //.many "many"]
+ )
+
+(template [<name> <base> <doc_modifier>]
+ [(def: #export (<name> parser)
+ {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " characters as a single continuous text."))}
+ (-> (Parser Slice) (Parser Slice))
+ (with_slices (<base> parser)))]
+
+ [some! //.some "some"]
+ [many! //.many "many"]
+ )
+
+(template [<name> <base> <doc_modifier>]
+ [(def: #export (<name> amount parser)
+ {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " N characters."))}
+ (-> Nat (Parser Text) (Parser Text))
+ (|> parser (<base> amount) (\ //.monad map /.concat)))]
+
+ [exactly //.exactly "exactly"]
+ [at_most //.at_most "at most"]
+ [at_least //.at_least "at least"]
+ )
+
+(template [<name> <base> <doc_modifier>]
+ [(def: #export (<name> amount parser)
+ {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " N characters."))}
+ (-> Nat (Parser Slice) (Parser Slice))
+ (with_slices (<base> amount parser)))]
+
+ [exactly! //.exactly "exactly"]
+ [at_most! //.at_most "at most"]
+ [at_least! //.at_least "at least"]
+ )
+
+(def: #export (between from to parser)
+ {#.doc "Lex between N and M characters."}
+ (-> Nat Nat (Parser Text) (Parser Text))
+ (|> parser (//.between from to) (\ //.monad map /.concat)))
+
+(def: #export (between! from to parser)
+ {#.doc "Lex between N and M characters."}
+ (-> Nat Nat (Parser Slice) (Parser Slice))
+ (with_slices (//.between from to parser)))
+
+(def: #export (enclosed [start end] parser)
+ (All [a] (-> [Text Text] (Parser a) (Parser a)))
+ (|> parser
+ (//.before (this end))
+ (//.after (this start))))
+
+(def: #export (local local_input parser)
+ {#.doc "Run a parser with the given input, instead of the real one."}
+ (All [a] (-> Text (Parser a) (Parser a)))
+ (function (_ real_input)
+ (case (..run parser local_input)
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success value)
+ (#try.Success [real_input value]))))
+
+(def: #export (slice parser)
+ (-> (Parser Slice) (Parser Text))
+ (do //.monad
+ [[basis distance] parser]
+ (function (_ (^@ input [offset tape]))
+ (case (/.clip basis distance tape)
+ (#.Some output)
+ (#try.Success [input output])
+
+ #.None
+ (exception.throw ..cannot_slice [])))))
+
+(def: #export (embed structured text)
+ (All [s a]
+ (-> (Parser a)
+ (//.Parser s Text)
+ (//.Parser s a)))
+ (do //.monad
+ [raw text]
+ (//.lift (..run structured raw))))
diff --git a/stdlib/source/library/lux/control/parser/tree.lux b/stdlib/source/library/lux/control/parser/tree.lux
new file mode 100644
index 000000000..5834c69e8
--- /dev/null
+++ b/stdlib/source/library/lux/control/parser/tree.lux
@@ -0,0 +1,60 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ [collection
+ [tree (#+ Tree)
+ ["." zipper (#+ Zipper)]]]]]]
+ ["." //])
+
+(type: #export (Parser t a)
+ (//.Parser (Zipper t) a))
+
+(def: #export (run' parser zipper)
+ (All [t a] (-> (Parser t a) (Zipper t) (Try a)))
+ (do try.monad
+ [[zipper output] (//.run parser zipper)]
+ (wrap output)))
+
+(def: #export (run parser tree)
+ (All [t a] (-> (Parser t a) (Tree t) (Try a)))
+ (run' parser (zipper.zip tree)))
+
+(def: #export value
+ (All [t] (Parser t t))
+ (function (_ zipper)
+ (#try.Success [zipper (zipper.value zipper)])))
+
+(exception: #export cannot-move-further)
+
+(template [<name> <direction>]
+ [(def: #export <name>
+ (All [t] (Parser t []))
+ (function (_ zipper)
+ (case (<direction> zipper)
+ #.None
+ (exception.throw ..cannot-move-further [])
+
+ (#.Some next)
+ (#try.Success [next []]))))]
+
+ [down zipper.down]
+ [up zipper.up]
+
+ [right zipper.right]
+ [rightmost zipper.rightmost]
+
+ [left zipper.left]
+ [leftmost zipper.leftmost]
+
+ [next zipper.next]
+ [end zipper.end]
+
+ [previous zipper.previous]
+ [start zipper.start]
+ )
diff --git a/stdlib/source/library/lux/control/parser/type.lux b/stdlib/source/library/lux/control/parser/type.lux
new file mode 100644
index 000000000..1e2c037d5
--- /dev/null
+++ b/stdlib/source/library/lux/control/parser/type.lux
@@ -0,0 +1,349 @@
+(.module:
+ [library
+ [lux (#- function)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." function]]
+ [data
+ ["." text ("#\." monoid)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." dictionary (#+ Dictionary)]]]
+ [macro
+ ["." code]]
+ [math
+ [number
+ ["n" nat ("#\." decimal)]]]
+ ["." type ("#\." equivalence)
+ ["." check]]]]
+ ["." //])
+
+(template [<name>]
+ [(exception: #export (<name> {type Type})
+ (exception.report
+ ["Type" (%.type type)]))]
+
+ [not_existential]
+ [not_recursive]
+ [not_named]
+ [not_parameter]
+ [unknown_parameter]
+ [not_function]
+ [not_application]
+ [not_polymorphic]
+ [not_variant]
+ [not_tuple]
+ )
+
+(template [<name>]
+ [(exception: #export (<name> {expected Type} {actual Type})
+ (exception.report
+ ["Expected" (%.type expected)]
+ ["Actual" (%.type actual)]))]
+
+ [types_do_not_match]
+ [wrong_parameter]
+ )
+
+(exception: #export empty_input)
+
+(exception: #export (unconsumed_input {remaining (List Type)})
+ (exception.report
+ ["Types" (|> remaining
+ (list\map (|>> %.type (format text.new_line "* ")))
+ (text.join_with ""))]))
+
+(type: #export Env
+ (Dictionary Nat [Type Code]))
+
+(type: #export (Parser a)
+ (//.Parser [Env (List Type)] a))
+
+(def: #export fresh
+ Env
+ (dictionary.new n.hash))
+
+(def: (run' env poly types)
+ (All [a] (-> Env (Parser a) (List Type) (Try a)))
+ (case (//.run poly [env types])
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success [[env' remaining] output])
+ (case remaining
+ #.Nil
+ (#try.Success output)
+
+ _
+ (exception.throw ..unconsumed_input remaining))))
+
+(def: #export (run poly type)
+ (All [a] (-> (Parser a) Type (Try a)))
+ (run' ..fresh poly (list type)))
+
+(def: #export env
+ (Parser Env)
+ (.function (_ [env inputs])
+ (#try.Success [[env inputs] env])))
+
+(def: (with_env temp poly)
+ (All [a] (-> Env (Parser a) (Parser a)))
+ (.function (_ [env inputs])
+ (case (//.run poly [temp inputs])
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success [[_ remaining] output])
+ (#try.Success [[env remaining] output]))))
+
+(def: #export peek
+ (Parser Type)
+ (.function (_ [env inputs])
+ (case inputs
+ #.Nil
+ (exception.throw ..empty_input [])
+
+ (#.Cons headT tail)
+ (#try.Success [[env inputs] headT]))))
+
+(def: #export any
+ (Parser Type)
+ (.function (_ [env inputs])
+ (case inputs
+ #.Nil
+ (exception.throw ..empty_input [])
+
+ (#.Cons headT tail)
+ (#try.Success [[env tail] headT]))))
+
+(def: #export (local types poly)
+ (All [a] (-> (List Type) (Parser a) (Parser a)))
+ (.function (_ [env pass_through])
+ (case (run' env poly types)
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success output)
+ (#try.Success [[env pass_through] output]))))
+
+(def: (label idx)
+ (-> Nat Code)
+ (code.local_identifier ($_ text\compose "label" text.tab (n\encode idx))))
+
+(def: #export (with_extension type poly)
+ (All [a] (-> Type (Parser a) (Parser [Code a])))
+ (.function (_ [env inputs])
+ (let [current_id (dictionary.size env)
+ g!var (label current_id)]
+ (case (//.run poly
+ [(dictionary.put current_id [type g!var] env)
+ inputs])
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success [[_ inputs'] output])
+ (#try.Success [[env inputs'] [g!var output]])))))
+
+(template [<name> <flattener> <tag> <exception>]
+ [(def: #export (<name> poly)
+ (All [a] (-> (Parser a) (Parser a)))
+ (do //.monad
+ [headT ..any]
+ (let [members (<flattener> (type.un_name headT))]
+ (if (n.> 1 (list.size members))
+ (local members poly)
+ (//.fail (exception.construct <exception> headT))))))]
+
+ [variant type.flatten_variant #.Sum ..not_variant]
+ [tuple type.flatten_tuple #.Product ..not_tuple]
+ )
+
+(def: polymorphic'
+ (Parser [Nat Type])
+ (do //.monad
+ [headT any
+ #let [[num_arg bodyT] (type.flatten_univ_q (type.un_name headT))]]
+ (if (n.= 0 num_arg)
+ (//.fail (exception.construct ..not_polymorphic headT))
+ (wrap [num_arg bodyT]))))
+
+(def: #export (polymorphic poly)
+ (All [a] (-> (Parser a) (Parser [Code (List Code) a])))
+ (do {! //.monad}
+ [headT any
+ funcI (\ ! map dictionary.size ..env)
+ [num_args non_poly] (local (list headT) ..polymorphic')
+ env ..env
+ #let [funcL (label funcI)
+ [all_varsL env'] (loop [current_arg 0
+ env' env
+ all_varsL (: (List Code) (list))]
+ (if (n.< num_args current_arg)
+ (if (n.= 0 current_arg)
+ (let [varL (label (inc funcI))]
+ (recur (inc current_arg)
+ (|> env'
+ (dictionary.put funcI [headT funcL])
+ (dictionary.put (inc funcI) [(#.Parameter (inc funcI)) varL]))
+ (#.Cons varL all_varsL)))
+ (let [partialI (|> current_arg (n.* 2) (n.+ funcI))
+ partial_varI (inc partialI)
+ partial_varL (label partial_varI)
+ partialC (` ((~ funcL) (~+ (|> (list.indices num_args)
+ (list\map (|>> (n.* 2) inc (n.+ funcI) label))
+ list.reverse))))]
+ (recur (inc current_arg)
+ (|> env'
+ (dictionary.put partialI [.Nothing partialC])
+ (dictionary.put partial_varI [(#.Parameter partial_varI) partial_varL]))
+ (#.Cons partial_varL all_varsL))))
+ [all_varsL env']))]]
+ (<| (with_env env')
+ (local (list non_poly))
+ (do !
+ [output poly]
+ (wrap [funcL all_varsL output])))))
+
+(def: #export (function in_poly out_poly)
+ (All [i o] (-> (Parser i) (Parser o) (Parser [i o])))
+ (do //.monad
+ [headT any
+ #let [[inputsT outputT] (type.flatten_function (type.un_name headT))]]
+ (if (n.> 0 (list.size inputsT))
+ (//.and (local inputsT in_poly)
+ (local (list outputT) out_poly))
+ (//.fail (exception.construct ..not_function headT)))))
+
+(def: #export (apply poly)
+ (All [a] (-> (Parser a) (Parser a)))
+ (do //.monad
+ [headT any
+ #let [[funcT paramsT] (type.flatten_application (type.un_name headT))]]
+ (if (n.= 0 (list.size paramsT))
+ (//.fail (exception.construct ..not_application headT))
+ (..local (#.Cons funcT paramsT) poly))))
+
+(template [<name> <test>]
+ [(def: #export (<name> expected)
+ (-> Type (Parser Any))
+ (do //.monad
+ [actual any]
+ (if (<test> expected actual)
+ (wrap [])
+ (//.fail (exception.construct ..types_do_not_match [expected actual])))))]
+
+ [exactly type\=]
+ [sub check.checks?]
+ [super (function.flip check.checks?)]
+ )
+
+(def: #export (adjusted_idx env idx)
+ (-> Env Nat Nat)
+ (let [env_level (n./ 2 (dictionary.size env))
+ parameter_level (n./ 2 idx)
+ parameter_idx (n.% 2 idx)]
+ (|> env_level dec (n.- parameter_level) (n.* 2) (n.+ parameter_idx))))
+
+(def: #export parameter
+ (Parser Code)
+ (do //.monad
+ [env ..env
+ headT any]
+ (case headT
+ (#.Parameter idx)
+ (case (dictionary.get (adjusted_idx env idx) env)
+ (#.Some [poly_type poly_code])
+ (wrap poly_code)
+
+ #.None
+ (//.fail (exception.construct ..unknown_parameter headT)))
+
+ _
+ (//.fail (exception.construct ..not_parameter headT)))))
+
+(def: #export (parameter! id)
+ (-> Nat (Parser Any))
+ (do //.monad
+ [env ..env
+ headT any]
+ (case headT
+ (#.Parameter idx)
+ (if (n.= id (adjusted_idx env idx))
+ (wrap [])
+ (//.fail (exception.construct ..wrong_parameter [(#.Parameter id) headT])))
+
+ _
+ (//.fail (exception.construct ..not_parameter headT)))))
+
+(def: #export existential
+ (Parser Nat)
+ (do //.monad
+ [headT any]
+ (case headT
+ (#.Ex ex_id)
+ (wrap ex_id)
+
+ _
+ (//.fail (exception.construct ..not_existential headT)))))
+
+(def: #export named
+ (Parser [Name Type])
+ (do //.monad
+ [inputT any]
+ (case inputT
+ (#.Named name anonymousT)
+ (wrap [name anonymousT])
+
+ _
+ (//.fail (exception.construct ..not_named inputT)))))
+
+(`` (template: (|nothing|)
+ (#.Named [(~~ (static .prelude_module)) "Nothing"]
+ (#.UnivQ #.Nil
+ (#.Parameter 1)))))
+
+(def: #export (recursive poly)
+ (All [a] (-> (Parser a) (Parser [Code a])))
+ (do {! //.monad}
+ [headT any]
+ (case (type.un_name headT)
+ (^ (#.Apply (|nothing|) (#.UnivQ _ headT')))
+ (do !
+ [[recT _ output] (|> poly
+ (with_extension .Nothing)
+ (with_extension headT)
+ (local (list headT')))]
+ (wrap [recT output]))
+
+ _
+ (//.fail (exception.construct ..not_recursive headT)))))
+
+(def: #export recursive_self
+ (Parser Code)
+ (do //.monad
+ [env ..env
+ headT any]
+ (case (type.un_name headT)
+ (^multi (^ (#.Apply (|nothing|) (#.Parameter funcT_idx)))
+ (n.= 0 (adjusted_idx env funcT_idx))
+ [(dictionary.get 0 env) (#.Some [self_type self_call])])
+ (wrap self_call)
+
+ _
+ (//.fail (exception.construct ..not_recursive headT)))))
+
+(def: #export recursive_call
+ (Parser Code)
+ (do {! //.monad}
+ [env ..env
+ [funcT argsT] (..apply (//.and any (//.many any)))
+ _ (local (list funcT) (..parameter! 0))
+ allC (let [allT (list& funcT argsT)]
+ (|> allT
+ (monad.map ! (function.constant ..parameter))
+ (local allT)))]
+ (wrap (` ((~+ allC))))))
diff --git a/stdlib/source/library/lux/control/parser/xml.lux b/stdlib/source/library/lux/control/parser/xml.lux
new file mode 100644
index 000000000..3fed4030e
--- /dev/null
+++ b/stdlib/source/library/lux/control/parser/xml.lux
@@ -0,0 +1,142 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try) ("#\." functor)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." name ("#\." equivalence codec)]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list]
+ ["." dictionary]]
+ [format
+ ["/" xml (#+ Attribute Attrs Tag XML)]]]]]
+ ["." //])
+
+(type: #export (Parser a)
+ (//.Parser [Attrs (List XML)] a))
+
+(exception: #export empty_input)
+(exception: #export unexpected_input)
+
+(exception: #export (wrong_tag {expected Tag} {actual Tag})
+ (exception.report
+ ["Expected" (%.text (/.tag expected))]
+ ["Actual" (%.text (/.tag actual))]))
+
+(exception: #export (unknown_attribute {expected Attribute} {available (List Attribute)})
+ (exception.report
+ ["Expected" (%.text (/.attribute expected))]
+ ["Available" (exception.enumerate (|>> /.attribute %.text) available)]))
+
+(exception: #export (unconsumed_inputs {inputs (List XML)})
+ (exception.report
+ ["Inputs" (exception.enumerate (\ /.codec encode) inputs)]))
+
+(def: (run' parser attrs documents)
+ (All [a] (-> (Parser a) Attrs (List XML) (Try a)))
+ (case (//.run parser [attrs documents])
+ (#try.Success [[attrs' remaining] output])
+ (if (list.empty? remaining)
+ (#try.Success output)
+ (exception.throw ..unconsumed_inputs remaining))
+
+ (#try.Failure error)
+ (#try.Failure error)))
+
+(def: #export (run parser documents)
+ (All [a] (-> (Parser a) (List XML) (Try a)))
+ (..run' parser /.attributes documents))
+
+(def: #export text
+ (Parser Text)
+ (function (_ [attrs documents])
+ (case documents
+ #.Nil
+ (exception.throw ..empty_input [])
+
+ (#.Cons head tail)
+ (case head
+ (#/.Text value)
+ (#try.Success [[attrs tail] value])
+
+ (#/.Node _)
+ (exception.throw ..unexpected_input [])))))
+
+(def: #export tag
+ (Parser Tag)
+ (function (_ [attrs documents])
+ (case documents
+ #.Nil
+ (exception.throw ..empty_input [])
+
+ (#.Cons head _)
+ (case head
+ (#/.Text _)
+ (exception.throw ..unexpected_input [])
+
+ (#/.Node tag _ _)
+ (#try.Success [[attrs documents] tag])))))
+
+(def: #export (attribute name)
+ (-> Attribute (Parser Text))
+ (function (_ [attrs documents])
+ (case (dictionary.get name attrs)
+ #.None
+ (exception.throw ..unknown_attribute [name (dictionary.keys attrs)])
+
+ (#.Some value)
+ (#try.Success [[attrs documents] value]))))
+
+(def: #export (node expected parser)
+ (All [a] (-> Tag (Parser a) (Parser a)))
+ (function (_ [attrs documents])
+ (case documents
+ #.Nil
+ (exception.throw ..empty_input [])
+
+ (#.Cons head tail)
+ (case head
+ (#/.Text _)
+ (exception.throw ..unexpected_input [])
+
+ (#/.Node actual attrs' children)
+ (if (name\= expected actual)
+ (|> children
+ (..run' parser attrs')
+ (try\map (|>> [[attrs tail]])))
+ (exception.throw ..wrong_tag [expected actual]))))))
+
+(def: #export ignore
+ (Parser Any)
+ (function (_ [attrs documents])
+ (case documents
+ #.Nil
+ (exception.throw ..empty_input [])
+
+ (#.Cons head tail)
+ (#try.Success [[attrs tail] []]))))
+
+(exception: #export nowhere)
+
+(def: #export (somewhere parser)
+ (All [a] (-> (Parser a) (Parser a)))
+ (function (recur [attrs input])
+ (case (//.run parser [attrs input])
+ (#try.Success [[attrs remaining] output])
+ (#try.Success [[attrs remaining] output])
+
+ (#try.Failure error)
+ (case input
+ #.Nil
+ (exception.throw ..nowhere [])
+
+ (#.Cons head tail)
+ (do try.monad
+ [[[attrs tail'] output] (recur [attrs tail])]
+ (wrap [[attrs (#.Cons head tail')]
+ output]))))))
diff --git a/stdlib/source/library/lux/control/pipe.lux b/stdlib/source/library/lux/control/pipe.lux
new file mode 100644
index 000000000..cac70fe6b
--- /dev/null
+++ b/stdlib/source/library/lux/control/pipe.lux
@@ -0,0 +1,161 @@
+(.module: {#.doc "Composable extensions to the piping macros (|> and <|) that enhance them with various abilities."}
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["e" try]
+ ["p" parser
+ ["s" code (#+ Parser)]]]
+ [data
+ ["." identity]
+ [collection
+ ["." list ("#\." fold monad)]]]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]]]]])
+
+(def: body^
+ (Parser (List Code))
+ (s.tuple (p.some s.any)))
+
+(syntax: #export (new> start
+ {body body^}
+ prev)
+ {#.doc (doc "Ignores the piped argument, and begins a new pipe."
+ (n.= 1
+ (|> 20
+ (n.* 3)
+ (n.+ 4)
+ (new> 0 [inc]))))}
+ (wrap (list (` (|> (~ start) (~+ body))))))
+
+(syntax: #export (let> binding body prev)
+ {#.doc (doc "Gives a name to the piped-argument, within the given expression."
+ (n.= 10
+ (|> 5
+ (let> x (n.+ x x)))))}
+ (wrap (list (` (let [(~ binding) (~ prev)]
+ (~ body))))))
+
+(def: _reverse_
+ (Parser Any)
+ (function (_ tokens)
+ (#e.Success [(list.reverse tokens) []])))
+
+(syntax: #export (cond> {_ _reverse_}
+ prev
+ {else body^}
+ {_ _reverse_}
+ {branches (p.some (p.and body^ body^))})
+ {#.doc (doc "Branching for pipes."
+ "Both the tests and the bodies are piped-code, and must be given inside a tuple."
+ (|> +5
+ (cond> [i.even?] [(i.* +2)]
+ [i.odd?] [(i.* +3)]
+ [(new> -1 [])])))}
+ (with_gensyms [g!temp]
+ (wrap (list (` (let [(~ g!temp) (~ prev)]
+ (cond (~+ (do list.monad
+ [[test then] branches]
+ (list (` (|> (~ g!temp) (~+ test)))
+ (` (|> (~ g!temp) (~+ then))))))
+ (|> (~ g!temp) (~+ else)))))))))
+
+(syntax: #export (if> {test body^} {then body^} {else body^} prev)
+ (wrap (list (` (cond> [(~+ test)] [(~+ then)]
+ [(~+ else)]
+ (~ prev))))))
+
+(syntax: #export (when> {test body^} {then body^} prev)
+ (wrap (list (` (cond> [(~+ test)] [(~+ then)]
+ []
+ (~ prev))))))
+
+(syntax: #export (loop> {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
+ (loop> [(i.< +10)]
+ [inc])))}
+ (with_gensyms [g!temp]
+ (wrap (list (` (loop [(~ g!temp) (~ prev)]
+ (if (|> (~ g!temp) (~+ test))
+ ((~' recur) (|> (~ g!temp) (~+ then)))
+ (~ g!temp))))))))
+
+(syntax: #export (do> monad
+ {steps (p.some body^)}
+ prev)
+ {#.doc (doc "Monadic pipes."
+ "Each steps in the monadic computation is a pipe and must be given inside a tuple."
+ (|> +5
+ (do> identity.monad
+ [(i.* +3)]
+ [(i.+ +4)]
+ [inc])))}
+ (with_gensyms [g!temp]
+ (case (list.reverse steps)
+ (^ (list& last_step prev_steps))
+ (let [step_bindings (do list.monad
+ [step (list.reverse prev_steps)]
+ (list g!temp (` (|> (~ g!temp) (~+ step)))))]
+ (wrap (list (` ((~! do) (~ monad)
+ [(~' #let) [(~ g!temp) (~ prev)]
+ (~+ step_bindings)]
+ (|> (~ g!temp) (~+ last_step)))))))
+
+ _
+ (wrap (list prev)))))
+
+(syntax: #export (exec> {body body^}
+ prev)
+ {#.doc (doc "Non-updating pipes."
+ "Will generate piped computations, but their results will not be used in the larger scope."
+ (|> +5
+ (exec> [.nat %n log!])
+ (i.* +10)))}
+ (with_gensyms [g!temp]
+ (wrap (list (` (let [(~ g!temp) (~ prev)]
+ (exec (|> (~ g!temp) (~+ body))
+ (~ g!temp))))))))
+
+(syntax: #export (tuple> {paths (p.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
+ (tuple> [(i.* +10)]
+ [dec (i./ +2)]
+ [Int/encode]))
+ "Will become: [+50 +2 '+5']")}
+ (with_gensyms [g!temp]
+ (wrap (list (` (let [(~ g!temp) (~ prev)]
+ [(~+ (list\map (function (_ body) (` (|> (~ g!temp) (~+ body))))
+ paths))]))))))
+
+(syntax: #export (case> {branches (p.many (p.and 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"
+ _ "???")))}
+ (wrap (list (` (case (~ prev)
+ (~+ (list\join (list\map (function (_ [pattern body]) (list pattern body))
+ branches))))))))
diff --git a/stdlib/source/library/lux/control/reader.lux b/stdlib/source/library/lux/control/reader.lux
new file mode 100644
index 000000000..95662b8ba
--- /dev/null
+++ b/stdlib/source/library/lux/control/reader.lux
@@ -0,0 +1,72 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." functor (#+ Functor)]
+ [apply (#+ Apply)]
+ ["." monad (#+ Monad do)]]]])
+
+(type: #export (Reader r a)
+ {#.doc "Computations that have access to some environmental value."}
+ (-> r a))
+
+(def: #export ask
+ {#.doc "Get the environment."}
+ (All [r] (Reader r r))
+ (function (_ env) env))
+
+(def: #export (local change proc)
+ {#.doc "Run computation with a locally-modified environment."}
+ (All [r a] (-> (-> r r) (Reader r a) (Reader r a)))
+ (|>> change proc))
+
+(def: #export (run env proc)
+ (All [r a] (-> r (Reader r a) a))
+ (proc env))
+
+(implementation: #export functor
+ (All [r] (Functor (Reader r)))
+
+ (def: (map f fa)
+ (function (_ env)
+ (f (fa env)))))
+
+(implementation: #export apply
+ (All [r] (Apply (Reader r)))
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (function (_ env)
+ ((ff env) (fa env)))))
+
+(implementation: #export monad
+ (All [r] (Monad (Reader r)))
+
+ (def: &functor ..functor)
+
+ (def: (wrap x)
+ (function (_ env) x))
+
+ (def: (join mma)
+ (function (_ env)
+ (mma env env))))
+
+(implementation: #export (with monad)
+ {#.doc "Monad transformer for Reader."}
+ (All [M] (-> (Monad M) (All [e] (Monad (All [a] (Reader e (M a)))))))
+
+ (def: &functor (functor.compose ..functor (get@ #monad.&functor monad)))
+
+ (def: wrap (|>> (\ monad wrap) (\ ..monad wrap)))
+
+ (def: (join eMeMa)
+ (function (_ env)
+ (do monad
+ [eMa (run env eMeMa)]
+ (run env eMa)))))
+
+(def: #export lift
+ {#.doc "Lift monadic values to the Reader wrapper."}
+ (All [M e a] (-> (M a) (Reader e (M a))))
+ (\ ..monad wrap))
diff --git a/stdlib/source/library/lux/control/region.lux b/stdlib/source/library/lux/control/region.lux
new file mode 100644
index 000000000..ff6247418
--- /dev/null
+++ b/stdlib/source/library/lux/control/region.lux
@@ -0,0 +1,158 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ ["." monad (#+ Monad do)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." fold)]]]]]
+ [//
+ ["." exception (#+ Exception exception:)]])
+
+(type: (Cleaner r !)
+ (-> r (! (Try Any))))
+
+(type: #export (Region r ! a)
+ (-> [r (List (Cleaner r !))]
+ (! [(List (Cleaner r !))
+ (Try a)])))
+
+(def: separator
+ Text
+ (format text.new_line
+ "-----------------------------------------" text.new_line
+ "-----------------------------------------" text.new_line
+ "-----------------------------------------" text.new_line
+ text.new_line))
+
+(exception: #export [a] (clean_up_error {error Text}
+ {output (Try a)})
+ (format error
+ (case output
+ (#try.Success _)
+ ""
+
+ (#try.Failure error|output)
+ (format separator
+ error|output))))
+
+(def: (combine_outcomes clean_up output)
+ (All [a] (-> (Try Any) (Try a) (Try a)))
+ (case clean_up
+ (#try.Success _)
+ output
+
+ (#try.Failure error)
+ (exception.throw ..clean_up_error [error output])))
+
+(def: #export (run monad computation)
+ (All [! a]
+ (-> (Monad !) (All [r] (Region r ! a))
+ (! (Try a))))
+ (do {! monad}
+ [[cleaners output] (computation [[] (list)])
+ results (monad.map ! (function (_ cleaner) (cleaner []))
+ cleaners)]
+ (wrap (list\fold combine_outcomes output results))))
+
+(def: #export (acquire monad cleaner value)
+ (All [! a] (-> (Monad !) (-> a (! (Try Any))) a
+ (All [r] (Region r ! a))))
+ (function (_ [region cleaners])
+ (\ monad wrap [(#.Cons (function (_ region) (cleaner value))
+ cleaners)
+ (#try.Success value)])))
+
+(implementation: #export (functor super)
+ (All [!]
+ (-> (Functor !)
+ (All [r] (Functor (Region r !)))))
+
+ (def: (map f)
+ (function (_ fa)
+ (function (_ region+cleaners)
+ (\ super map
+ (function (_ [cleaners' temp])
+ [cleaners' (case temp
+ (#try.Success value)
+ (#try.Success (f value))
+
+ (#try.Failure error)
+ (#try.Failure error))])
+ (fa region+cleaners))))))
+
+(implementation: #export (apply super)
+ (All [!]
+ (-> (Monad !)
+ (All [r] (Apply (Region r !)))))
+
+ (def: &functor
+ (..functor (get@ #monad.&functor super)))
+
+ (def: (apply ff fa)
+ (function (_ [region cleaners])
+ (do super
+ [[cleaners ef] (ff [region cleaners])
+ [cleaners ea] (fa [region cleaners])]
+ (case ef
+ (#try.Success f)
+ (case ea
+ (#try.Success a)
+ (wrap [cleaners (#try.Success (f a))])
+
+ (#try.Failure error)
+ (wrap [cleaners (#try.Failure error)]))
+
+ (#try.Failure error)
+ (wrap [cleaners (#try.Failure error)]))))))
+
+(implementation: #export (monad super)
+ (All [!]
+ (-> (Monad !)
+ (All [r] (Monad (Region r !)))))
+
+ (def: &functor
+ (..functor (get@ #monad.&functor super)))
+
+ (def: (wrap value)
+ (function (_ [region cleaners])
+ (\ super wrap [cleaners (#try.Success value)])))
+
+ (def: (join ffa)
+ (function (_ [region cleaners])
+ (do super
+ [[cleaners efa] (ffa [region cleaners])]
+ (case efa
+ (#try.Success fa)
+ (fa [region cleaners])
+
+ (#try.Failure error)
+ (wrap [cleaners (#try.Failure error)]))))))
+
+(def: #export (fail monad error)
+ (All [! a]
+ (-> (Monad !) Text
+ (All [r] (Region r ! a))))
+ (function (_ [region cleaners])
+ (\ monad wrap [cleaners (#try.Failure error)])))
+
+(def: #export (throw monad exception message)
+ (All [! e a]
+ (-> (Monad !) (Exception e) e
+ (All [r] (Region r ! a))))
+ (fail monad (exception.construct exception message)))
+
+(def: #export (lift monad operation)
+ (All [! a]
+ (-> (Monad !) (! a)
+ (All [r] (Region r ! a))))
+ (function (_ [region cleaners])
+ (do monad
+ [output operation]
+ (wrap [cleaners (#try.Success output)]))))
diff --git a/stdlib/source/library/lux/control/remember.lux b/stdlib/source/library/lux/control/remember.lux
new file mode 100644
index 000000000..86f9cb7a1
--- /dev/null
+++ b/stdlib/source/library/lux/control/remember.lux
@@ -0,0 +1,74 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io]
+ ["." try]
+ ["." exception (#+ exception:)]
+ ["<>" parser ("#\." functor)
+ ["<c>" code (#+ Parser)]]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]]
+ [time
+ ["." instant]
+ ["." date (#+ Date) ("#\." order)]]
+ ["." meta]
+ [macro
+ ["." code]
+ [syntax (#+ syntax:)]]]])
+
+(exception: #export (must_remember {deadline Date} {today Date} {message Text} {focus (Maybe Code)})
+ (exception.report
+ ["Deadline" (%.date deadline)]
+ ["Today" (%.date today)]
+ ["Message" message]
+ ["Code" (case focus
+ (#.Some focus)
+ (%.code focus)
+
+ #.None
+ "")]))
+
+(def: deadline
+ (Parser Date)
+ ($_ <>.either
+ (<>\map (|>> instant.from_millis instant.date)
+ <c>.int)
+ (do <>.monad
+ [raw <c>.text]
+ (case (\ date.codec decode raw)
+ (#try.Success date)
+ (wrap date)
+
+ (#try.Failure message)
+ (<>.fail message)))))
+
+(syntax: #export (remember {deadline ..deadline} {message <c>.text} {focus (<>.maybe <c>.any)})
+ (let [now (io.run instant.now)
+ today (instant.date now)]
+ (if (date\< deadline today)
+ (wrap (case focus
+ (#.Some focus)
+ (list focus)
+
+ #.None
+ (list)))
+ (meta.fail (exception.construct ..must_remember [deadline today message focus])))))
+
+(template [<name> <message>]
+ [(syntax: #export (<name> {deadline ..deadline} {message <c>.text} {focus (<>.maybe <c>.any)})
+ (wrap (list (` (..remember (~ (code.text (%.date deadline)))
+ (~ (code.text (format <message> " " message)))
+ (~+ (case focus
+ (#.Some focus)
+ (list focus)
+
+ #.None
+ (list))))))))]
+
+ [to_do "TODO"]
+ [fix_me "FIXME"]
+ )
diff --git a/stdlib/source/library/lux/control/security/capability.lux b/stdlib/source/library/lux/control/security/capability.lux
new file mode 100644
index 000000000..13ae40d15
--- /dev/null
+++ b/stdlib/source/library/lux/control/security/capability.lux
@@ -0,0 +1,71 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<c>" code]]
+ ["." io (#+ IO)]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [type
+ abstract]
+ ["." meta]
+ ["." macro
+ ["." code]
+ [syntax (#+ syntax:)
+ ["|.|" export]
+ ["|.|" declaration]
+ ["|.|" annotations]]]]])
+
+(abstract: #export (Capability brand input output)
+ (-> input output)
+
+ {#.doc (doc "Represents the capability to perform an operation."
+ "This operation is assumed to have security implications.")}
+
+ (def: forge
+ (All [brand input output]
+ (-> (-> input output)
+ (Capability brand input output)))
+ (|>> :abstraction))
+
+ (def: #export (use capability input)
+ (All [brand input output]
+ (-> (Capability brand input output)
+ input
+ output))
+ ((:representation capability) input))
+
+ (syntax: #export (capability: {export |export|.parser}
+ {declaration |declaration|.parser}
+ {annotations (<>.maybe |annotations|.parser)}
+ {[forge input output] (<c>.form ($_ <>.and <c>.local_identifier <c>.any <c>.any))})
+ (do {! meta.monad}
+ [this_module meta.current_module_name
+ #let [[name vars] declaration]
+ g!brand (\ ! map (|>> %.code code.text)
+ (macro.gensym (format (%.name [this_module name]))))
+ #let [capability (` (..Capability (.primitive (~ g!brand)) (~ input) (~ output)))]]
+ (wrap (list (` (type: (~+ (|export|.format export))
+ (~ (|declaration|.format declaration))
+ (~ capability)))
+ (` (def: (~ (code.local_identifier forge))
+ (All [(~+ (list\map code.local_identifier vars))]
+ (-> (-> (~ input) (~ output))
+ (~ capability)))
+ (~! ..forge)))
+ ))))
+
+ (def: #export (async capability)
+ (All [brand input output]
+ (-> (Capability brand input (IO output))
+ (Capability brand input (Promise output))))
+ (..forge (|>> ((:representation capability)) promise.future)))
+ )
diff --git a/stdlib/source/library/lux/control/security/policy.lux b/stdlib/source/library/lux/control/security/policy.lux
new file mode 100644
index 000000000..3c1eb579e
--- /dev/null
+++ b/stdlib/source/library/lux/control/security/policy.lux
@@ -0,0 +1,93 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ [monad (#+ Monad)]]
+ [type
+ abstract]]])
+
+(abstract: #export (Policy brand value label)
+ value
+
+ (type: #export (Can_Upgrade brand label value)
+ {#.doc (doc "Represents the capacity to 'upgrade' a value.")}
+ (-> value (Policy brand value label)))
+
+ (type: #export (Can_Downgrade brand label value)
+ {#.doc (doc "Represents the capacity to 'downgrade' a value.")}
+ (-> (Policy brand value label) value))
+
+ (type: #export (Privilege brand label)
+ {#.doc (doc "Represents the privilege to both 'upgrade' and 'downgrade' a value.")}
+ {#can_upgrade (Can_Upgrade brand label)
+ #can_downgrade (Can_Downgrade brand label)})
+
+ (def: privilege
+ Privilege
+ {#can_upgrade (|>> :abstraction)
+ #can_downgrade (|>> :representation)})
+
+ (type: #export (Delegation brand from to)
+ {#.doc (doc "Represents the act of delegating policy capacities.")}
+ (All [value]
+ (-> (Policy brand value from)
+ (Policy brand value to))))
+
+ (def: #export (delegation downgrade upgrade)
+ {#.doc (doc "Delegating policy capacities.")}
+ (All [brand from to]
+ (-> (Can_Downgrade brand from) (Can_Upgrade brand to)
+ (Delegation brand from to)))
+ (|>> downgrade upgrade))
+
+ (type: #export (Context brand scope label)
+ {#.doc (doc "A computational context with an associated policy privilege.")}
+ (-> (Privilege brand label)
+ (scope label)))
+
+ (def: #export (with_policy context)
+ (All [brand scope]
+ (Ex [label]
+ (-> (Context brand scope label)
+ (scope label))))
+ (context ..privilege))
+
+ (def: (decorate constructor)
+ (-> Type Type)
+ (type (All [brand label] (constructor (All [value] (Policy brand value label))))))
+
+ (implementation: #export functor
+ (:~ (decorate Functor))
+
+ (def: (map f fa)
+ (|> fa :representation f :abstraction)))
+
+ (implementation: #export apply
+ (:~ (decorate Apply))
+
+ (def: &functor ..functor)
+ (def: (apply ff fa)
+ (:abstraction ((:representation ff) (:representation fa)))))
+
+ (implementation: #export monad
+ (:~ (decorate Monad))
+
+ (def: &functor ..functor)
+ (def: wrap (|>> :abstraction))
+ (def: join (|>> :representation)))
+ )
+
+(template [<brand> <value> <upgrade> <downgrade>]
+ [(abstract: #export <brand>
+ Any
+
+ (type: #export <value> (Policy <brand>))
+ (type: #export <upgrade> (Can_Upgrade <brand>))
+ (type: #export <downgrade> (Can_Downgrade <brand>))
+ )]
+
+ [Privacy Private Can_Conceal Can_Reveal]
+ [Safety Safe Can_Trust Can_Distrust]
+ )
diff --git a/stdlib/source/library/lux/control/state.lux b/stdlib/source/library/lux/control/state.lux
new file mode 100644
index 000000000..ef0e2dbb7
--- /dev/null
+++ b/stdlib/source/library/lux/control/state.lux
@@ -0,0 +1,149 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ [monad (#+ Monad do)]]]])
+
+(type: #export (State s a)
+ {#.doc "Stateful computations."}
+ (-> s [s a]))
+
+(def: #export get
+ {#.doc "Read the current state."}
+ (All [s] (State s s))
+ (function (_ state)
+ [state state]))
+
+(def: #export (put new-state)
+ {#.doc "Set the new state."}
+ (All [s] (-> s (State s Any)))
+ (function (_ state)
+ [new-state []]))
+
+(def: #export (update change)
+ {#.doc "Compute the new state."}
+ (All [s] (-> (-> s s) (State s Any)))
+ (function (_ state)
+ [(change state) []]))
+
+(def: #export (use user)
+ {#.doc "Run function on current state."}
+ (All [s a] (-> (-> s a) (State s a)))
+ (function (_ 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)))
+ (function (_ state)
+ (let [[state' output] (action (change state))]
+ [state output])))
+
+(def: #export (run state action)
+ {#.doc "Run a stateful computation."}
+ (All [s a] (-> s (State s a) [s a]))
+ (action state))
+
+(implementation: #export functor
+ (All [s] (Functor (State s)))
+
+ (def: (map f ma)
+ (function (_ state)
+ (let [[state' a] (ma state)]
+ [state' (f a)]))))
+
+(implementation: #export apply
+ (All [s] (Apply (State s)))
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (function (_ state)
+ (let [[state' f] (ff state)
+ [state'' a] (fa state')]
+ [state'' (f a)]))))
+
+(implementation: #export monad
+ (All [s] (Monad (State s)))
+
+ (def: &functor ..functor)
+
+ (def: (wrap a)
+ (function (_ state)
+ [state a]))
+
+ (def: (join mma)
+ (function (_ state)
+ (let [[state' ma] (mma state)]
+ (ma state')))))
+
+(def: #export (while condition body)
+ (All [s] (-> (State s Bit) (State s Any) (State s Any)))
+ (do {! ..monad}
+ [execute? condition]
+ (if execute?
+ (do !
+ [_ body]
+ (while condition body))
+ (wrap []))))
+
+(def: #export (do-while condition body)
+ (All [s] (-> (State s Bit) (State s Any) (State s Any)))
+ (do ..monad
+ [_ body]
+ (while condition body)))
+
+(implementation: (with//functor functor)
+ (All [M s] (-> (Functor M) (Functor (All [a] (-> s (M [s a]))))))
+
+ (def: (map f sfa)
+ (function (_ state)
+ (\ functor map (function (_ [s a]) [s (f a)])
+ (sfa state)))))
+
+(implementation: (with//apply monad)
+ (All [M s] (-> (Monad M) (Apply (All [a] (-> s (M [s a]))))))
+
+ (def: &functor (with//functor (\ monad &functor)))
+
+ (def: (apply sFf sFa)
+ (function (_ state)
+ (do monad
+ [[state f] (sFf state)
+ [state a] (sFa state)]
+ (wrap [state (f a)])))))
+
+(type: #export (State' M s a)
+ {#.doc "Stateful computations decorated by a monad."}
+ (-> s (M [s a])))
+
+(def: #export (run' state action)
+ {#.doc "Run a stateful computation decorated by a monad."}
+ (All [M s a] (-> s (State' M s a) (M [s a])))
+ (action state))
+
+(implementation: #export (with monad)
+ {#.doc "A monad transformer to create composite stateful computations."}
+ (All [M s] (-> (Monad M) (Monad (State' M s))))
+
+ (def: &functor (with//functor (\ monad &functor)))
+
+ (def: (wrap a)
+ (function (_ state)
+ (\ monad wrap [state a])))
+
+ (def: (join sMsMa)
+ (function (_ state)
+ (do monad
+ [[state' sMa] (sMsMa state)]
+ (sMa state')))))
+
+(def: #export (lift monad ma)
+ {#.doc "Lift monadic values to the State' wrapper."}
+ (All [M s a] (-> (Monad M) (M a) (State' M s a)))
+ (function (_ state)
+ (do monad
+ [a ma]
+ (wrap [state a]))))
diff --git a/stdlib/source/library/lux/control/thread.lux b/stdlib/source/library/lux/control/thread.lux
new file mode 100644
index 000000000..818c38298
--- /dev/null
+++ b/stdlib/source/library/lux/control/thread.lux
@@ -0,0 +1,106 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ [monad (#+ Monad do)]]
+ [control
+ ["." io (#+ IO)]]
+ [data
+ [collection
+ ["." array (#+ Array)]]]
+ [type
+ abstract]]])
+
+(type: #export (Thread ! a)
+ (-> ! a))
+
+(abstract: #export (Box t v)
+ (Array v)
+
+ {#.doc "A mutable box holding a value."}
+
+ (def: #export (box init)
+ (All [a] (-> a (All [!] (Thread ! (Box ! a)))))
+ (function (_ !)
+ (|> (array.new 1)
+ (array.write! 0 init)
+ :abstraction)))
+
+ (def: #export (read box)
+ (All [! a] (-> (Box ! a) (Thread ! a)))
+ (function (_ !)
+ (for {@.old
+ ("jvm aaload" (:representation box) 0)
+
+ @.jvm
+ ("jvm array read object"
+ (|> 0
+ (:as (primitive "java.lang.Long"))
+ "jvm object cast"
+ "jvm conversion long-to-int")
+ (:representation box))
+
+ @.js ("js array read" 0 (:representation box))
+ @.python ("python array read" 0 (:representation box))
+ @.lua ("lua array read" 0 (:representation box))
+ @.ruby ("ruby array read" 0 (:representation box))
+ @.php ("php array read" 0 (:representation box))
+ @.scheme ("scheme array read" 0 (:representation box))})))
+
+ (def: #export (write value box)
+ (All [a] (-> a (All [!] (-> (Box ! a) (Thread ! Any)))))
+ (function (_ !)
+ (|> box :representation (array.write! 0 value) :abstraction)))
+ )
+
+(def: #export (run thread)
+ (All [a]
+ (-> (All [!] (Thread ! a))
+ a))
+ (thread []))
+
+(def: #export io
+ (All [a]
+ (-> (All [!] (Thread ! a))
+ (IO a)))
+ (|>> ..run io.io))
+
+(implementation: #export functor
+ (All [!] (Functor (Thread !)))
+
+ (def: (map f)
+ (function (_ fa)
+ (function (_ !)
+ (f (fa !))))))
+
+(implementation: #export apply
+ (All [!] (Apply (Thread !)))
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (function (_ !)
+ ((ff !) (fa !)))))
+
+(implementation: #export monad
+ (All [!] (Monad (Thread !)))
+
+ (def: &functor ..functor)
+
+ (def: (wrap value)
+ (function (_ !)
+ value))
+
+ (def: (join ffa)
+ (function (_ !)
+ ((ffa !) !))))
+
+(def: #export (update f box)
+ (All [a] (-> (-> a a) (All [!] (-> (Box ! a) (Thread ! a)))))
+ (do ..monad
+ [old (read box)
+ _ (write (f old) box)]
+ (wrap old)))
diff --git a/stdlib/source/library/lux/control/try.lux b/stdlib/source/library/lux/control/try.lux
new file mode 100644
index 000000000..013553b04
--- /dev/null
+++ b/stdlib/source/library/lux/control/try.lux
@@ -0,0 +1,153 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [apply (#+ Apply)]
+ [equivalence (#+ Equivalence)]
+ ["." functor (#+ Functor)]
+ ["." monad (#+ Monad do)]]
+ [meta
+ ["." location]]]])
+
+(type: #export (Try a)
+ (#Failure Text)
+ (#Success a))
+
+(implementation: #export functor
+ (Functor Try)
+
+ (def: (map f ma)
+ (case ma
+ (#Failure msg)
+ (#Failure msg)
+
+ (#Success datum)
+ (#Success (f datum)))))
+
+(implementation: #export apply
+ (Apply Try)
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (case ff
+ (#Success f)
+ (case fa
+ (#Success a)
+ (#Success (f a))
+
+ (#Failure msg)
+ (#Failure msg))
+
+ (#Failure msg)
+ (#Failure msg))
+ ))
+
+(implementation: #export monad
+ (Monad Try)
+
+ (def: &functor ..functor)
+
+ (def: (wrap a)
+ (#Success a))
+
+ (def: (join mma)
+ (case mma
+ (#Failure msg)
+ (#Failure msg)
+
+ (#Success ma)
+ ma)))
+
+(implementation: #export (with monad)
+ ## TODO: Replace (All [a] (M (Try a))) with (functor.Then M Try)
+ (All [M] (-> (Monad M) (Monad (All [a] (M (Try a))))))
+
+ (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor))
+
+ (def: wrap (|>> (\ ..monad wrap) (\ monad wrap)))
+
+ (def: (join MeMea)
+ (do monad
+ [eMea MeMea]
+ (case eMea
+ (#Failure try)
+ (wrap (#Failure try))
+
+ (#Success Mea)
+ Mea))))
+
+(def: #export (lift monad)
+ (All [M a] (-> (Monad M) (-> (M a) (M (Try a)))))
+ (\ monad map (\ ..monad wrap)))
+
+(implementation: #export (equivalence (^open "_\."))
+ (All [a] (-> (Equivalence a) (Equivalence (Try a))))
+
+ (def: (= reference sample)
+ (case [reference sample]
+ [(#Success reference) (#Success sample)]
+ (_\= reference sample)
+
+ [(#Failure reference) (#Failure sample)]
+ ("lux text =" reference sample)
+
+ _
+ false
+ )))
+
+(def: #export (succeed value)
+ (All [a] (-> a (Try a)))
+ (#Success value))
+
+(def: #export (fail message)
+ (-> Text Try)
+ (#Failure message))
+
+(def: #export (assume try)
+ (All [a] (-> (Try a) a))
+ (case try
+ (#Success value)
+ value
+
+ (#Failure message)
+ (error! message)))
+
+(def: #export (to_maybe try)
+ (All [a] (-> (Try a) (Maybe a)))
+ (case try
+ (#Success value)
+ (#.Some value)
+
+ (#Failure message)
+ #.None))
+
+(def: #export (from_maybe maybe)
+ (All [a] (-> (Maybe a) (Try a)))
+ (case maybe
+ (#.Some value)
+ (#Success value)
+
+ #.None
+ (#Failure (`` (("lux in-module" (~~ (static .prelude_module)) .name\encode)
+ (name_of ..from_maybe))))))
+
+(macro: #export (default tokens compiler)
+ {#.doc (doc "Allows you to provide a default value that will be used"
+ "if a (Try x) value turns out to be #Failure."
+ "Note: the expression for the default value will not be computed if the base computation succeeds."
+ (= "bar"
+ (default "foo" (#..Success "bar")))
+ (= "foo"
+ (default "foo" (#..Failure "KABOOM!"))))}
+ (case tokens
+ (^ (list else try))
+ (#Success [compiler (list (` (case (~ try)
+ (#..Success (~' g!temp))
+ (~' g!temp)
+
+ (#..Failure (~ [location.dummy (#.Identifier ["" ""])]))
+ (~ else))))])
+
+ _
+ (#Failure "Wrong syntax for default")))
diff --git a/stdlib/source/library/lux/control/writer.lux b/stdlib/source/library/lux/control/writer.lux
new file mode 100644
index 000000000..2ddf343df
--- /dev/null
+++ b/stdlib/source/library/lux/control/writer.lux
@@ -0,0 +1,78 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ [abstract
+ monoid
+ [apply (#+ Apply)]
+ ["." functor (#+ Functor)]
+ ["." monad (#+ Monad do)]]]])
+
+(type: #export (Writer l a)
+ {#.doc "Represents a value with an associated 'log' value to record arbitrary information."}
+ {#log l
+ #value a})
+
+(def: #export (write l)
+ {#.doc "Set the log to a particular value."}
+ (All [l] (-> l (Writer l Any)))
+ [l []])
+
+(implementation: #export functor
+ (All [l]
+ (Functor (Writer l)))
+
+ (def: (map f fa)
+ (let [[log datum] fa]
+ [log (f datum)])))
+
+(implementation: #export (apply monoid)
+ (All [l]
+ (-> (Monoid l) (Apply (Writer l))))
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (let [[log1 f] ff
+ [log2 a] fa]
+ [(\ monoid compose log1 log2) (f a)])))
+
+(implementation: #export (monad monoid)
+ (All [l]
+ (-> (Monoid l) (Monad (Writer l))))
+
+ (def: &functor ..functor)
+
+ (def: wrap
+ (|>> [(\ monoid identity)]))
+
+ (def: (join mma)
+ (let [[log1 [log2 a]] mma]
+ [(\ monoid compose log1 log2) a])))
+
+(implementation: #export (with monoid monad)
+ (All [l M] (-> (Monoid l) (Monad M) (Monad (All [a] (M (Writer l a))))))
+
+ (def: &functor
+ (functor.compose (get@ #monad.&functor monad)
+ ..functor))
+
+ (def: wrap
+ (let [writer (..monad monoid)]
+ (|>> (\ writer wrap) (\ monad wrap))))
+
+ (def: (join MlMla)
+ (do monad
+ [[l1 Mla] (for {@.old
+ (: (($ 1) (Writer ($ 0) (($ 1) (Writer ($ 0) ($ 2)))))
+ MlMla)}
+ ## On new compiler
+ MlMla)
+ [l2 a] Mla]
+ (wrap [(\ monoid compose l1 l2) a]))))
+
+(def: #export (lift monoid monad)
+ (All [l M a]
+ (-> (Monoid l) (Monad M)
+ (-> (M a) (M (Writer l a)))))
+ (\ monad map (|>> [(\ monoid identity)])))
diff --git a/stdlib/source/library/lux/data/binary.lux b/stdlib/source/library/lux/data/binary.lux
new file mode 100644
index 000000000..11bc86754
--- /dev/null
+++ b/stdlib/source/library/lux/data/binary.lux
@@ -0,0 +1,367 @@
+(.module:
+ [library
+ [lux (#- i64)
+ ["@" target]
+ ["." ffi]
+ [abstract
+ [monad (#+ do)]
+ [equivalence (#+ Equivalence)]
+ [monoid (#+ Monoid)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." maybe]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." array]]]
+ [math
+ [number (#+ hex)
+ ["n" nat]
+ ["f" frac]
+ ["." i64]]]]])
+
+(exception: #export (index_out_of_bounds {size Nat} {index Nat})
+ (exception.report
+ ["Size" (%.nat size)]
+ ["Index" (%.nat index)]))
+
+(exception: #export (slice_out_of_bounds {size Nat} {offset Nat} {length Nat})
+ (exception.report
+ ["Size" (%.nat size)]
+ ["Offset" (%.nat offset)]
+ ["Length" (%.nat length)]))
+
+(with_expansions [<jvm> (as_is (type: #export Binary (ffi.type [byte]))
+
+ (ffi.import: java/lang/Object)
+
+ (ffi.import: java/lang/System
+ ["#::."
+ (#static arraycopy [java/lang/Object int java/lang/Object int int] #try void)])
+
+ (ffi.import: java/util/Arrays
+ ["#::."
+ (#static copyOfRange [[byte] int int] [byte])
+ (#static equals [[byte] [byte]] boolean)])
+
+ (def: byte_mask
+ I64
+ (|> i64.bits_per_byte i64.mask .i64))
+
+ (def: i64
+ (-> (primitive "java.lang.Byte") I64)
+ (|>> ffi.byte_to_long (:as I64) (i64.and ..byte_mask)))
+
+ (def: byte
+ (-> (I64 Any) (primitive "java.lang.Byte"))
+ (for {@.old
+ (|>> .int ffi.long_to_byte)
+
+ @.jvm
+ (|>> .int (:as (primitive "java.lang.Long")) ffi.long_to_byte)})))]
+ (for {@.old (as_is <jvm>)
+ @.jvm (as_is <jvm>)
+
+ @.js
+ (as_is (ffi.import: ArrayBuffer
+ ["#::."
+ (new [ffi.Number])])
+
+ (ffi.import: Uint8Array
+ ["#::."
+ (new [ArrayBuffer])
+ (length ffi.Number)])
+
+ (type: #export Binary
+ Uint8Array))
+
+ @.python
+ (type: #export Binary
+ (primitive "bytearray"))
+
+ @.scheme
+ (as_is (type: #export Binary
+ (primitive "bytevector"))
+
+ (ffi.import: (make-bytevector [Nat] Binary))
+ (ffi.import: (bytevector-u8-ref [Binary Nat] I64))
+ (ffi.import: (bytevector-u8-set! [Binary Nat (I64 Any)] Any))
+ (ffi.import: (bytevector-length [Binary] Nat)))}
+
+ ## Default
+ (type: #export Binary
+ (array.Array (I64 Any)))))
+
+(template: (!size binary)
+ (for {@.old (ffi.array_length binary)
+ @.jvm (ffi.array_length binary)
+
+ @.js
+ (|> binary
+ Uint8Array::length
+ f.nat)
+
+ @.python
+ (|> binary
+ (:as (array.Array (I64 Any)))
+ "python array length")
+
+ @.scheme
+ (..bytevector-length [binary])}
+
+ ## Default
+ (array.size binary)))
+
+(template: (!read idx binary)
+ (for {@.old (..i64 (ffi.array_read idx binary))
+ @.jvm (..i64 (ffi.array_read idx binary))
+
+ @.js
+ (|> binary
+ (: ..Binary)
+ (:as (array.Array .Frac))
+ ("js array read" idx)
+ f.nat
+ .i64)
+
+ @.python
+ (|> binary
+ (:as (array.Array .I64))
+ ("python array read" idx))
+
+ @.scheme
+ (..bytevector-u8-ref [binary idx])}
+
+ ## Default
+ (|> binary
+ (array.read idx)
+ (maybe.default (: (I64 Any) 0))
+ (:as I64))))
+
+(template: (!!write <byte_type> <post> <write> idx value binary)
+ (|> binary
+ (: ..Binary)
+ (:as (array.Array <byte_type>))
+ (<write> idx (|> value .nat (n.% (hex "100")) <post>))
+ (:as ..Binary)))
+
+(template: (!write idx value binary)
+ (for {@.old (ffi.array_write idx (..byte value) binary)
+ @.jvm (ffi.array_write idx (..byte value) binary)
+
+ @.js (!!write .Frac n.frac "js array write" idx value binary)
+ @.python (!!write (I64 Any) (:as (I64 Any)) "python array write" idx value binary)
+ @.scheme (exec (..bytevector-u8-set! [binary idx value])
+ binary)}
+
+ ## Default
+ (array.write! idx (|> value .nat (n.% (hex "100"))) binary)))
+
+(def: #export size
+ (-> Binary Nat)
+ (|>> !size))
+
+(def: #export create
+ (-> Nat Binary)
+ (for {@.old (|>> (ffi.array byte))
+ @.jvm (|>> (ffi.array byte))
+
+ @.js
+ (|>> n.frac ArrayBuffer::new Uint8Array::new)
+
+ @.python
+ (|>> ("python apply" (:as ffi.Function ("python constant" "bytearray")))
+ (:as Binary))
+
+ @.scheme
+ (|>> ..make-bytevector)}
+
+ ## Default
+ array.new))
+
+(def: #export (fold f init binary)
+ (All [a] (-> (-> I64 a a) a Binary a))
+ (let [size (..!size binary)]
+ (loop [idx 0
+ output init]
+ (if (n.< size idx)
+ (recur (inc idx) (f (!read idx binary) output))
+ output))))
+
+(def: #export (read/8 idx binary)
+ (-> Nat Binary (Try I64))
+ (if (n.< (..!size binary) idx)
+ (#try.Success (!read idx binary))
+ (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
+
+(def: #export (read/16 idx binary)
+ (-> Nat Binary (Try I64))
+ (if (n.< (..!size binary) (n.+ 1 idx))
+ (#try.Success ($_ i64.or
+ (i64.left_shift 8 (!read idx binary))
+ (!read (n.+ 1 idx) binary)))
+ (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
+
+(def: #export (read/32 idx binary)
+ (-> Nat Binary (Try I64))
+ (if (n.< (..!size binary) (n.+ 3 idx))
+ (#try.Success ($_ i64.or
+ (i64.left_shift 24 (!read idx binary))
+ (i64.left_shift 16 (!read (n.+ 1 idx) binary))
+ (i64.left_shift 8 (!read (n.+ 2 idx) binary))
+ (!read (n.+ 3 idx) binary)))
+ (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
+
+(def: #export (read/64 idx binary)
+ (-> Nat Binary (Try I64))
+ (if (n.< (..!size binary) (n.+ 7 idx))
+ (#try.Success ($_ i64.or
+ (i64.left_shift 56 (!read idx binary))
+ (i64.left_shift 48 (!read (n.+ 1 idx) binary))
+ (i64.left_shift 40 (!read (n.+ 2 idx) binary))
+ (i64.left_shift 32 (!read (n.+ 3 idx) binary))
+ (i64.left_shift 24 (!read (n.+ 4 idx) binary))
+ (i64.left_shift 16 (!read (n.+ 5 idx) binary))
+ (i64.left_shift 8 (!read (n.+ 6 idx) binary))
+ (!read (n.+ 7 idx) binary)))
+ (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
+
+(def: #export (write/8 idx value binary)
+ (-> Nat (I64 Any) Binary (Try Binary))
+ (if (n.< (..!size binary) idx)
+ (#try.Success (|> binary
+ (!write idx value)))
+ (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
+
+(def: #export (write/16 idx value binary)
+ (-> Nat (I64 Any) Binary (Try Binary))
+ (if (n.< (..!size binary) (n.+ 1 idx))
+ (#try.Success (|> binary
+ (!write idx (i64.right_shift 8 value))
+ (!write (n.+ 1 idx) value)))
+ (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
+
+(def: #export (write/32 idx value binary)
+ (-> Nat (I64 Any) Binary (Try Binary))
+ (if (n.< (..!size binary) (n.+ 3 idx))
+ (#try.Success (|> binary
+ (!write idx (i64.right_shift 24 value))
+ (!write (n.+ 1 idx) (i64.right_shift 16 value))
+ (!write (n.+ 2 idx) (i64.right_shift 8 value))
+ (!write (n.+ 3 idx) value)))
+ (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
+
+(def: #export (write/64 idx value binary)
+ (-> Nat (I64 Any) Binary (Try Binary))
+ (if (n.< (..!size binary) (n.+ 7 idx))
+ (for {@.scheme (let [write_high (|>> (!write idx (i64.right_shift 56 value))
+ (!write (n.+ 1 idx) (i64.right_shift 48 value))
+ (!write (n.+ 2 idx) (i64.right_shift 40 value))
+ (!write (n.+ 3 idx) (i64.right_shift 32 value)))
+ write_low (|>> (!write (n.+ 4 idx) (i64.right_shift 24 value))
+ (!write (n.+ 5 idx) (i64.right_shift 16 value))
+ (!write (n.+ 6 idx) (i64.right_shift 8 value))
+ (!write (n.+ 7 idx) value))]
+ (|> binary write_high write_low #try.Success))}
+ (#try.Success (|> binary
+ (!write idx (i64.right_shift 56 value))
+ (!write (n.+ 1 idx) (i64.right_shift 48 value))
+ (!write (n.+ 2 idx) (i64.right_shift 40 value))
+ (!write (n.+ 3 idx) (i64.right_shift 32 value))
+ (!write (n.+ 4 idx) (i64.right_shift 24 value))
+ (!write (n.+ 5 idx) (i64.right_shift 16 value))
+ (!write (n.+ 6 idx) (i64.right_shift 8 value))
+ (!write (n.+ 7 idx) value))))
+ (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
+
+(implementation: #export equivalence
+ (Equivalence Binary)
+
+ (def: (= reference sample)
+ (with_expansions [<jvm> (java/util/Arrays::equals reference sample)]
+ (for {@.old <jvm>
+ @.jvm <jvm>}
+ (let [limit (!size reference)]
+ (and (n.= limit
+ (!size sample))
+ (loop [idx 0]
+ (if (n.< limit idx)
+ (and (n.= (!read idx reference)
+ (!read idx sample))
+ (recur (inc idx)))
+ true))))))))
+
+(for {@.old (as_is)
+ @.jvm (as_is)}
+
+ ## Default
+ (exception: #export (cannot_copy_bytes {bytes Nat}
+ {source_input Nat}
+ {target_output Nat})
+ (exception.report
+ ["Bytes" (%.nat bytes)]
+ ["Source input space" (%.nat source_input)]
+ ["Target output space" (%.nat target_output)])))
+
+(def: #export (copy bytes source_offset source target_offset target)
+ (-> Nat Nat Binary Nat Binary (Try Binary))
+ (with_expansions [<jvm> (as_is (do try.monad
+ [_ (java/lang/System::arraycopy source (.int source_offset) target (.int target_offset) (.int bytes))]
+ (wrap target)))]
+ (for {@.old <jvm>
+ @.jvm <jvm>}
+
+ ## Default
+ (let [source_input (n.- source_offset (!size source))
+ target_output (n.- target_offset (!size target))]
+ (if (n.<= source_input bytes)
+ (loop [idx 0]
+ (if (n.< bytes idx)
+ (exec (!write (n.+ target_offset idx)
+ (!read (n.+ source_offset idx) source)
+ target)
+ (recur (inc idx)))
+ (#try.Success target)))
+ (exception.throw ..cannot_copy_bytes [bytes source_input target_output]))))))
+
+(def: #export (slice offset length binary)
+ (-> Nat Nat Binary (Try Binary))
+ (let [size (..!size binary)
+ limit (n.+ length offset)]
+ (if (n.<= size limit)
+ (with_expansions [<jvm> (as_is (#try.Success (java/util/Arrays::copyOfRange binary (.int offset) (.int limit))))]
+ (for {@.old <jvm>
+ @.jvm <jvm>}
+
+ ## Default
+ (..copy length offset binary 0 (..create length))))
+ (exception.throw ..slice_out_of_bounds [size offset length]))))
+
+(def: #export (drop offset binary)
+ (-> Nat Binary Binary)
+ (case offset
+ 0 binary
+ _ (let [distance (n.- offset (..!size binary))]
+ (case (..slice offset distance binary)
+ (#try.Success slice)
+ slice
+
+ (#try.Failure _)
+ (..create 0)))))
+
+(implementation: #export monoid
+ (Monoid Binary)
+
+ (def: identity
+ (..create 0))
+
+ (def: (compose left right)
+ (let [sizeL (!size left)
+ sizeR (!size right)
+ output (..create (n.+ sizeL sizeR))]
+ (exec
+ (..copy sizeL 0 left 0 output)
+ (..copy sizeR 0 right sizeL output)
+ output))))
diff --git a/stdlib/source/library/lux/data/bit.lux b/stdlib/source/library/lux/data/bit.lux
new file mode 100644
index 000000000..5a62ecce5
--- /dev/null
+++ b/stdlib/source/library/lux/data/bit.lux
@@ -0,0 +1,59 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monoid (#+ Monoid)]
+ [equivalence (#+ Equivalence)]
+ hash
+ [codec (#+ Codec)]]
+ [control
+ ["." function]]]])
+
+(implementation: #export equivalence
+ (Equivalence Bit)
+
+ (def: (= x y)
+ (if x
+ y
+ (not y))))
+
+(implementation: #export hash
+ (Hash Bit)
+
+ (def: &equivalence ..equivalence)
+
+ (def: (hash value)
+ (case value
+ #0 2
+ #1 3)))
+
+(template [<name> <identity> <op>]
+ [(implementation: #export <name>
+ (Monoid Bit)
+
+ (def: identity <identity>)
+ (def: (compose x y) (<op> x y)))]
+
+ [disjunction #0 or]
+ [conjunction #1 and]
+ )
+
+(implementation: #export codec
+ (Codec Text Bit)
+
+ (def: (encode x)
+ (if x
+ "#1"
+ "#0"))
+
+ (def: (decode input)
+ (case input
+ "#1" (#.Right #1)
+ "#0" (#.Right #0)
+ _ (#.Left "Wrong syntax for Bit."))))
+
+(def: #export complement
+ {#.doc (doc "Generates the complement of a predicate."
+ "That is a predicate that returns the oposite of the original predicate.")}
+ (All [a] (-> (-> a Bit) (-> a Bit)))
+ (function.compose not))
diff --git a/stdlib/source/library/lux/data/collection/array.lux b/stdlib/source/library/lux/data/collection/array.lux
new file mode 100644
index 000000000..66a3abb6e
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/array.lux
@@ -0,0 +1,388 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ [abstract
+ [monoid (#+ Monoid)]
+ [functor (#+ Functor)]
+ [equivalence (#+ Equivalence)]
+ [fold (#+ Fold)]
+ [predicate (#+ Predicate)]]
+ [data
+ ["." product]
+ ["." maybe]
+ [collection
+ ["." list ("#\." fold)]]]
+ [math
+ [number
+ ["n" nat]]]]])
+
+(def: #export type_name
+ "#Array")
+
+(type: #export (Array a)
+ {#.doc "Mutable arrays."}
+ (#.Primitive ..type_name (#.Cons a #.Nil)))
+
+(with_expansions [<index_type> (primitive "java.lang.Long")
+ <elem_type> (primitive "java.lang.Object")
+ <array_type> (type (Array <elem_type>))]
+ (for {@.jvm
+ (template: (!int value)
+ (|> value
+ (:as <index_type>)
+ "jvm object cast"
+ "jvm conversion long-to-int"))}
+ (as_is))
+
+ (def: #export (new size)
+ (All [a] (-> Nat (Array a)))
+ (for {@.old
+ (:assume ("jvm anewarray" "(java.lang.Object )" size))
+
+ @.jvm
+ (|> size
+ !int
+ "jvm array new object"
+ (: <array_type>)
+ :assume)
+
+ @.js ("js array new" size)
+ @.python ("python array new" size)
+ @.lua ("lua array new" size)
+ @.ruby ("ruby array new" size)
+ @.php ("php array new" size)
+ @.scheme ("scheme array new" size)}))
+
+ (def: #export (size array)
+ (All [a] (-> (Array a) Nat))
+ (for {@.old
+ ("jvm arraylength" array)
+
+ @.jvm
+ (|> array
+ (:as <array_type>)
+ "jvm array length object"
+ "jvm conversion int-to-long"
+ "jvm object cast"
+ (: <index_type>)
+ (:as Nat))
+
+ @.js ("js array length" array)
+ @.python ("python array length" array)
+ @.lua ("lua array length" array)
+ @.ruby ("ruby array length" array)
+ @.php ("php array length" array)
+ @.scheme ("scheme array length" array)}))
+
+ (template: (!read <read> <null?>)
+ (let [output (<read> index array)]
+ (if (<null?> output)
+ #.None
+ (#.Some output))))
+
+ (def: #export (read index array)
+ (All [a]
+ (-> Nat (Array a) (Maybe a)))
+ (if (n.< (size array) index)
+ (for {@.old
+ (let [value ("jvm aaload" array index)]
+ (if ("jvm object null?" value)
+ #.None
+ (#.Some value)))
+
+ @.jvm
+ (let [value (|> array
+ (:as <array_type>)
+ ("jvm array read object" (!int index)))]
+ (if ("jvm object null?" value)
+ #.None
+ (#.Some (:assume value))))
+
+ @.js (!read "js array read" "js object undefined?")
+ @.python (!read "python array read" "python object none?")
+ @.lua (!read "lua array read" "lua object nil?")
+ @.ruby (!read "ruby array read" "ruby object nil?")
+ @.php (!read "php array read" "php object null?")
+ @.scheme (!read "scheme array read" "scheme object nil?")})
+ #.None))
+
+ (def: #export (write! index value array)
+ (All [a]
+ (-> Nat a (Array a) (Array a)))
+ (for {@.old
+ ("jvm aastore" array index value)
+
+ @.jvm
+ (|> array
+ (:as <array_type>)
+ ("jvm array write object" (!int index) (:as <elem_type> value))
+ :assume)
+
+ @.js ("js array write" index value array)
+ @.python ("python array write" index value array)
+ @.lua ("lua array write" index value array)
+ @.ruby ("ruby array write" index value array)
+ @.php ("php array write" index value array)
+ @.scheme ("scheme array write" index value array)}))
+
+ (def: #export (delete! index array)
+ (All [a]
+ (-> Nat (Array a) (Array a)))
+ (if (n.< (size array) index)
+ (for {@.old
+ (write! index (:assume ("jvm object null")) array)
+
+ @.jvm
+ (write! index (:assume (: <elem_type> ("jvm object null"))) array)
+
+ @.js ("js array delete" index array)
+ @.python ("python array delete" index array)
+ @.lua ("lua array delete" index array)
+ @.ruby ("ruby array delete" index array)
+ @.php ("php array delete" index array)
+ @.scheme ("scheme array delete" index array)})
+ array))
+ )
+
+(def: #export (contains? index array)
+ (All [a]
+ (-> Nat (Array a) Bit))
+ (case (..read index array)
+ (#.Some _)
+ true
+
+ _
+ false))
+
+(def: #export (update! index transform array)
+ (All [a]
+ (-> Nat (-> a a) (Array a) (Array a)))
+ (case (read index array)
+ #.None
+ array
+
+ (#.Some value)
+ (write! index (transform value) array)))
+
+(def: #export (upsert! index default transform array)
+ (All [a]
+ (-> Nat a (-> a a) (Array a) (Array a)))
+ (write! index
+ (|> array (read index) (maybe.default default) transform)
+ array))
+
+(def: #export (copy! length src_start src_array dest_start dest_array)
+ (All [a]
+ (-> Nat Nat (Array a) Nat (Array a)
+ (Array a)))
+ (if (n.= 0 length)
+ dest_array
+ (list\fold (function (_ offset target)
+ (case (read (n.+ offset src_start) src_array)
+ #.None
+ target
+
+ (#.Some value)
+ (write! (n.+ offset dest_start) value target)))
+ dest_array
+ (list.indices length))))
+
+(def: #export (occupancy array)
+ {#.doc "Finds out how many cells in an array are occupied."}
+ (All [a] (-> (Array a) Nat))
+ (list\fold (function (_ idx count)
+ (case (read idx array)
+ #.None
+ count
+
+ (#.Some _)
+ (inc count)))
+ 0
+ (list.indices (size array))))
+
+(def: #export (vacancy array)
+ {#.doc "Finds out how many cells in an array are vacant."}
+ (All [a] (-> (Array a) Nat))
+ (n.- (..occupancy array) (..size array)))
+
+(def: #export (filter! p xs)
+ (All [a]
+ (-> (Predicate a) (Array a) (Array a)))
+ (list\fold (function (_ idx xs')
+ (case (read idx xs)
+ #.None
+ xs'
+
+ (#.Some x)
+ (if (p x)
+ xs'
+ (delete! idx xs'))))
+ xs
+ (list.indices (size xs))))
+
+(def: #export (find p xs)
+ (All [a]
+ (-> (Predicate a) (Array a) (Maybe a)))
+ (let [arr_size (size xs)]
+ (loop [idx 0]
+ (if (n.< arr_size idx)
+ (case (read 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 Bit) (Array a) (Maybe [Nat a])))
+ (let [arr_size (size xs)]
+ (loop [idx 0]
+ (if (n.< arr_size idx)
+ (case (read 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 (function (_ idx ys)
+ (case (read idx xs)
+ #.None
+ ys
+
+ (#.Some x)
+ (write! 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 (function (_ x [idx arr])
+ [(inc idx) (write! idx x arr)])
+ [0 (new (list.size xs))]
+ xs)))
+
+(def: underflow Nat (dec 0))
+
+(def: #export (to_list array)
+ (All [a] (-> (Array a) (List a)))
+ (loop [idx (dec (size array))
+ output #.Nil]
+ (if (n.= ..underflow idx)
+ output
+ (recur (dec idx)
+ (case (read idx array)
+ (#.Some head)
+ (#.Cons head output)
+
+ #.None
+ output)))))
+
+(def: #export (to_list' default array)
+ (All [a] (-> a (Array a) (List a)))
+ (loop [idx (dec (size array))
+ output #.Nil]
+ (if (n.= ..underflow idx)
+ output
+ (recur (dec idx)
+ (#.Cons (maybe.default default (read idx array))
+ output)))))
+
+(implementation: #export (equivalence (^open ",\."))
+ (All [a] (-> (Equivalence a) (Equivalence (Array a))))
+
+ (def: (= xs ys)
+ (let [sxs (size xs)
+ sxy (size ys)]
+ (and (n.= sxy sxs)
+ (list\fold (function (_ idx prev)
+ (and prev
+ (case [(read idx xs) (read idx ys)]
+ [#.None #.None]
+ true
+
+ [(#.Some x) (#.Some y)]
+ (,\= x y)
+
+ _
+ false)))
+ true
+ (list.indices sxs))))))
+
+(implementation: #export monoid
+ (All [a] (Monoid (Array a)))
+
+ (def: identity (new 0))
+
+ (def: (compose xs ys)
+ (let [sxs (size xs)
+ sxy (size ys)]
+ (|> (new (n.+ sxy sxs))
+ (copy! sxs 0 xs 0)
+ (copy! sxy 0 ys sxs)))))
+
+(implementation: #export functor
+ (Functor Array)
+
+ (def: (map f ma)
+ (let [arr_size (size ma)]
+ (if (n.= 0 arr_size)
+ (new arr_size)
+ (list\fold (function (_ idx mb)
+ (case (read idx ma)
+ #.None
+ mb
+
+ (#.Some x)
+ (write! idx (f x) mb)))
+ (new arr_size)
+ (list.indices arr_size))
+ ))))
+
+(implementation: #export fold
+ (Fold Array)
+
+ (def: (fold f init xs)
+ (let [arr_size (size xs)]
+ (loop [so_far init
+ idx 0]
+ (if (n.< arr_size idx)
+ (case (read idx xs)
+ #.None
+ (recur so_far (inc idx))
+
+ (#.Some value)
+ (recur (f value so_far) (inc idx)))
+ so_far)))))
+
+(template [<name> <init> <op>]
+ [(def: #export (<name> predicate array)
+ (All [a]
+ (-> (Predicate a) (Predicate (Array a))))
+ (let [size (..size array)]
+ (loop [idx 0]
+ (if (n.< size idx)
+ (case (..read idx array)
+ (#.Some value)
+ (<op> (predicate value)
+ (recur (inc idx)))
+
+ #.None
+ (recur (inc idx)))
+ <init>))))]
+
+ [every? true and]
+ [any? false or]
+ )
diff --git a/stdlib/source/library/lux/data/collection/bits.lux b/stdlib/source/library/lux/data/collection/bits.lux
new file mode 100644
index 000000000..63e90f7c8
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/bits.lux
@@ -0,0 +1,177 @@
+(.module:
+ [library
+ [lux (#- not and or)
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [control
+ pipe]
+ [data
+ ["." maybe]
+ [collection
+ ["." array (#+ Array) ("#\." fold)]]]
+ [math
+ [number
+ ["n" nat]
+ ["." i64]]]]])
+
+(type: #export Chunk
+ I64)
+
+(def: #export chunk-size
+ i64.width)
+
+(type: #export Bits
+ (Array Chunk))
+
+(def: empty-chunk
+ Chunk
+ (.i64 0))
+
+(def: #export empty
+ Bits
+ (array.new 0))
+
+(def: #export (size bits)
+ (-> Bits Nat)
+ (array\fold (function (_ chunk total)
+ (|> chunk i64.count (n.+ total)))
+ 0
+ bits))
+
+(def: #export (capacity bits)
+ (-> Bits Nat)
+ (|> bits array.size (n.* chunk-size)))
+
+(def: #export empty?
+ (-> Bits Bit)
+ (|>> size (n.= 0)))
+
+(def: #export (get index bits)
+ (-> Nat Bits Bit)
+ (let [[chunk-index bit-index] (n./% chunk-size index)]
+ (.and (n.< (array.size bits) chunk-index)
+ (|> (array.read chunk-index bits)
+ (maybe.default empty-chunk)
+ (i64.set? bit-index)))))
+
+(def: (chunk idx bits)
+ (-> Nat Bits Chunk)
+ (if (n.< (array.size bits) idx)
+ (|> bits (array.read idx) (maybe.default empty-chunk))
+ empty-chunk))
+
+(template [<name> <op>]
+ [(def: #export (<name> index input)
+ (-> Nat Bits Bits)
+ (let [[chunk-index bit-index] (n./% chunk-size index)]
+ (loop [size|output (n.max (inc chunk-index)
+ (array.size input))
+ output ..empty]
+ (let [idx|output (dec size|output)]
+ (if (n.> 0 size|output)
+ (case (|> (..chunk idx|output input)
+ (cond> [(new> (n.= chunk-index idx|output) [])]
+ [(<op> bit-index)]
+
+ ## else
+ [])
+ .nat)
+ 0
+ ## TODO: Remove 'no-op' once new-luxc is the official compiler.
+ (let [no-op (recur (dec size|output) output)]
+ no-op)
+
+ chunk
+ (|> (if (is? ..empty output)
+ (: Bits (array.new size|output))
+ output)
+ (array.write! idx|output (.i64 chunk))
+ (recur (dec size|output))))
+ output)))))]
+
+ [set i64.set]
+ [clear i64.clear]
+ [flip i64.flip]
+ )
+
+(def: #export (intersects? reference sample)
+ (-> Bits Bits Bit)
+ (let [chunks (n.min (array.size reference)
+ (array.size sample))]
+ (loop [idx 0]
+ (if (n.< chunks idx)
+ (.or (|> (..chunk idx sample)
+ (i64.and (..chunk idx reference))
+ ("lux i64 =" empty-chunk)
+ .not)
+ (recur (inc idx)))
+ #0))))
+
+(def: #export (not input)
+ (-> Bits Bits)
+ (case (array.size input)
+ 0
+ ..empty
+
+ size|output
+ (loop [size|output size|output
+ output ..empty]
+ (let [idx (dec size|output)]
+ (case (|> input (..chunk idx) i64.not .nat)
+ 0
+ (recur (dec size|output) output)
+
+ chunk
+ (if (n.> 0 size|output)
+ (|> (if (is? ..empty output)
+ (: Bits (array.new size|output))
+ output)
+ (array.write! idx (.i64 chunk))
+ (recur (dec size|output)))
+ output))))))
+
+(template [<name> <op>]
+ [(def: #export (<name> param subject)
+ (-> Bits Bits Bits)
+ (case (n.max (array.size param)
+ (array.size subject))
+ 0
+ ..empty
+
+ size|output
+ (loop [size|output size|output
+ output ..empty]
+ (let [idx (dec size|output)]
+ (if (n.> 0 size|output)
+ (case (|> (..chunk idx subject)
+ (<op> (..chunk idx param))
+ .nat)
+ 0
+ (recur (dec size|output) output)
+
+ chunk
+ (|> (if (is? ..empty output)
+ (: Bits (array.new size|output))
+ output)
+ (array.write! idx (.i64 chunk))
+ (recur (dec size|output))))
+ output)))))]
+
+ [and i64.and]
+ [or i64.or]
+ [xor i64.xor]
+ )
+
+(implementation: #export equivalence
+ (Equivalence Bits)
+
+ (def: (= reference sample)
+ (let [size (n.max (array.size reference)
+ (array.size sample))]
+ (loop [idx 0]
+ (if (n.< size idx)
+ (.and ("lux i64 ="
+ (..chunk idx reference)
+ (..chunk idx sample))
+ (recur (inc idx)))
+ #1)))))
diff --git a/stdlib/source/library/lux/data/collection/dictionary.lux b/stdlib/source/library/lux/data/collection/dictionary.lux
new file mode 100644
index 000000000..3ae286db8
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/dictionary.lux
@@ -0,0 +1,732 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [hash (#+ Hash)]
+ [equivalence (#+ Equivalence)]
+ [functor (#+ Functor)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." maybe]
+ ["." product]
+ [collection
+ ["." list ("#\." fold functor monoid)]
+ ["." array (#+ Array) ("#\." functor fold)]]]
+ [math
+ ["." number
+ ["n" nat]
+ ["." i64]]]]])
+
+## 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.
+
+## 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 its 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
+## Dictionaries.
+(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
+ (i64.left_shift (n.- 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
+ (i64.left_shift (n.- 1 branching_exponent) 1))
+
+## The size of hierarchy-nodes, which is 2^(branching-exponent).
+(def: hierarchy_nodes_size
+ Nat
+ (i64.left_shift 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.new (inc old_size))
+ (array.copy! idx 0 old_array 0)
+ (array.write! idx value)
+ (array.copy! (n.- 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.write! 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.delete! 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! (n.- idx new_size) (inc idx) array idx))))
+
+## Increases the level-shift by the branching-exponent, to explore
+## levels further down the tree.
+(def: level_up
+ (-> Level Level)
+ (n.+ 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)
+ (i64.and ..hierarchy_mask
+ (i64.right_shift level hash)))
+
+## A mechanism to go from indices to bit-positions.
+(def: (->bit_position index)
+ (-> Index BitPosition)
+ (i64.left_shift 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 Bit)
+ (|> bitmap
+ (i64.and bit)
+ (n.= clean_bitmap)
+ not))
+
+## Figures out whether a bitmap only contains a single bit-position.
+(def: only_bit_position?
+ (-> BitPosition BitMap Bit)
+ n.=)
+
+(def: (set_bit_position bit bitmap)
+ (-> BitPosition BitMap BitMap)
+ (i64.or bit bitmap))
+
+(def: unset_bit_position
+ (-> BitPosition BitMap BitMap)
+ i64.xor)
+
+## Figures out the size of a bitmap-indexed array by counting all the
+## 1s within the bitmap.
+(def: bitmap_size
+ (-> BitMap Nat)
+ i64.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 its bit-position.
+(def: (base_index bit_position bitmap)
+ (-> BitPosition BitMap Index)
+ (bitmap_size (i64.and (bit_position_mask bit_position)
+ bitmap)))
+
+## Produces the index of a KV-pair within a #Collisions node.
+(def: (collision_index Hash<k> key colls)
+ (All [k v] (-> (Hash k) k (Collisions k v) (Maybe Index)))
+ (\ maybe.monad map product.left
+ (array.find+ (function (_ idx [key' val'])
+ (\ Hash<k> = 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)]))
+ (product.right (list\fold (function (_ idx [insertion_idx node])
+ (let [[bitmap base] node]
+ (case (array.read idx h_array)
+ #.None [insertion_idx node]
+ (#.Some sub_node) (if (n.= except_idx idx)
+ [insertion_idx node]
+ [(inc insertion_idx)
+ [(set_bit_position (->bit_position idx) bitmap)
+ (array.write! insertion_idx (#.Left sub_node) base)]])
+ )))
+ [0 [clean_bitmap
+ (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 its balance.
+(def: hierarchy_indices (List Index) (list.indices hierarchy_nodes_size))
+
+(def: (promote_base put' Hash<k> 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 (function (_ hierarchy_idx (^@ default [base_idx h_array]))
+ (if (bit_position_is_set? (->bit_position hierarchy_idx)
+ bitmap)
+ [(inc base_idx)
+ (case (array.read base_idx base)
+ (#.Some (#.Left sub_node))
+ (array.write! hierarchy_idx sub_node h_array)
+
+ (#.Some (#.Right [key' val']))
+ (array.write! hierarchy_idx
+ (put' (level_up level) (\ Hash<k> hash key') key' val' Hash<k> empty)
+ h_array)
+
+ #.None
+ (undefined))]
+ default))
+ [0
+ (array.new hierarchy_nodes_size)]
+ hierarchy_indices)))
+
+## 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) Bit))
+ (`` (case node
+ (#Base (~~ (static ..clean_bitmap)) _)
+ #1
+
+ _
+ #0)))
+
+(def: (put' level hash key val Hash<k> node)
+ (All [k v] (-> Level Hash_Code k v (Hash k) (Node k v) (Node k v)))
+ (case node
+ ## For #Hierarchy nodes, check whether one can add the element to
+ ## a sub-node. If impossible, introduce a new singleton sub-node.
+ (#Hierarchy _size hierarchy)
+ (let [idx (level_index level hash)
+ [_size' sub_node] (case (array.read idx hierarchy)
+ (#.Some sub_node)
+ [_size sub_node]
+
+ _
+ [(inc _size) empty])]
+ (#Hierarchy _size'
+ (update! idx (put' (level_up level) hash key val Hash<k> sub_node)
+ hierarchy)))
+
+ ## For #Base nodes, 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.read idx base)
+ ## If it's being used by a node, add the KV to it.
+ (#.Some (#.Left sub_node))
+ (let [sub_node' (put' (level_up level) hash key val Hash<k> sub_node)]
+ (#Base bitmap (update! idx (#.Left sub_node') base)))
+
+ ## Otherwise, if it's being used by a KV, compare the keys.
+ (#.Some (#.Right key' val'))
+ (if (\ Hash<k> = key key')
+ ## If the same key is found, replace the value.
+ (#Base bitmap (update! idx (#.Right key val) base))
+ ## Otherwise, compare the hashes of the keys.
+ (#Base bitmap (update! idx
+ (#.Left (let [hash' (\ Hash<k> hash key')]
+ (if (n.= hash hash')
+ ## If the hashes are
+ ## the same, a new
+ ## #Collisions node
+ ## is added.
+ (#Collisions hash (|> (array.new 2)
+ (array.write! 0 [key' val'])
+ (array.write! 1 [key val])))
+ ## Otherwise, one can
+ ## just keep using
+ ## #Base nodes, so
+ ## add both KV-pairs
+ ## to the empty one.
+ (let [next_level (level_up level)]
+ (|> empty
+ (put' next_level hash' key' val' Hash<k>)
+ (put' next_level hash key val Hash<k>))))))
+ base)))
+
+ #.None
+ (undefined)))
+ ## However, if the BitPosition has not been used yet, check
+ ## whether this #Base node is ready for a promotion.
+ (let [base_count (bitmap_size bitmap)]
+ (if (n.>= ..promotion_threshold base_count)
+ ## If so, 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<k> level bitmap base)
+ (array.write! (level_index level hash)
+ (put' (level_up level) hash key val Hash<k> empty))))
+ ## Otherwise, 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, compare the hashes.
+ (#Collisions _hash _colls)
+ (if (n.= hash _hash)
+ ## If they're equal, that means the new KV contributes to the
+ ## collisions.
+ (case (collision_index Hash<k> key _colls)
+ ## If the key was already present in the collisions-list, its
+ ## 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, create a new #Base node that
+ ## contains the old #Collisions node, plus the new KV-pair.
+ (|> (#Base (bit_position level _hash)
+ (|> (array.new 1)
+ (array.write! 0 (#.Left node))))
+ (put' level hash key val Hash<k>)))
+ ))
+
+(def: (remove' level hash key Hash<k> 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.read 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<k> sub_node)]
+ ## Then check if a removal was actually done.
+ (if (is? 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 (n.<= 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.read idx base)
+ ## 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<k> sub_node)]
+ ## Verify that it was removed.
+ (if (is? 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 did not 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<k> = 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)
+
+ #.None
+ (undefined)))
+ ## 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<k> 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 (n.= 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<k> 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.read (level_index level hash) hierarchy)
+ #.None #.None
+ (#.Some sub_node) (get' (level_up level) hash key Hash<k> 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.read (base_index bit bitmap) base)
+ (#.Some (#.Left sub_node))
+ (get' (level_up level) hash key Hash<k> sub_node)
+
+ (#.Some (#.Right [key' val']))
+ (if (\ Hash<k> = key key')
+ (#.Some val')
+ #.None)
+
+ #.None
+ (undefined))
+ #.None))
+
+ ## For #Collisions nodes, do a linear scan of all the known KV-pairs.
+ (#Collisions _hash _colls)
+ (\ maybe.monad map product.right
+ (array.find (|>> product.left (\ Hash<k> = key))
+ _colls))
+ ))
+
+(def: (size' node)
+ (All [k v] (-> (Node k v) Nat))
+ (case node
+ (#Hierarchy _size hierarchy)
+ (array\fold n.+ 0 (array\map size' hierarchy))
+
+ (#Base _ base)
+ (array\fold n.+ 0 (array\map (function (_ 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 (function (_ sub_node tail) (list\compose (entries' sub_node) tail))
+ #.Nil
+ hierarchy)
+
+ (#Base bitmap base)
+ (array\fold (function (_ branch tail)
+ (case branch
+ (#.Left sub_node)
+ (list\compose (entries' sub_node) tail)
+
+ (#.Right [key' val'])
+ (#.Cons [key' val'] tail)))
+ #.Nil
+ base)
+
+ (#Collisions hash colls)
+ (array\fold (function (_ [key' val'] tail) (#.Cons [key' val'] tail))
+ #.Nil
+ colls)))
+
+(type: #export (Dictionary k v)
+ {#.doc "A dictionary implemented as a Hash-Array Mapped Trie (HAMT)."}
+ {#hash (Hash k)
+ #root (Node k v)})
+
+(def: #export key_hash
+ (All [k v] (-> (Dictionary k v) (Hash k)))
+ (get@ #..hash))
+
+(def: #export (new Hash<k>)
+ (All [k v] (-> (Hash k) (Dictionary k v)))
+ {#hash Hash<k>
+ #root empty})
+
+(def: #export (put key val dict)
+ (All [k v] (-> k v (Dictionary k v) (Dictionary k v)))
+ (let [[Hash<k> node] dict]
+ [Hash<k> (put' root_level (\ Hash<k> hash key) key val Hash<k> node)]))
+
+(def: #export (remove key dict)
+ (All [k v] (-> k (Dictionary k v) (Dictionary k v)))
+ (let [[Hash<k> node] dict]
+ [Hash<k> (remove' root_level (\ Hash<k> hash key) key Hash<k> node)]))
+
+(def: #export (get key dict)
+ (All [k v] (-> k (Dictionary k v) (Maybe v)))
+ (let [[Hash<k> node] dict]
+ (get' root_level (\ Hash<k> hash key) key Hash<k> node)))
+
+(def: #export (key? dict key)
+ (All [k v] (-> (Dictionary k v) k Bit))
+ (case (get key dict)
+ #.None #0
+ (#.Some _) #1))
+
+(exception: #export key_already_exists)
+
+(def: #export (try_put key val dict)
+ {#.doc "Only puts the KV-pair if the key is not already present."}
+ (All [k v] (-> k v (Dictionary k v) (Try (Dictionary k v))))
+ (case (get key dict)
+ #.None (#try.Success (put key val dict))
+ (#.Some _) (exception.throw ..key_already_exists [])))
+
+(def: #export (update key f dict)
+ {#.doc "Transforms the value located at key (if available), using the given function."}
+ (All [k v] (-> k (-> v v) (Dictionary k v) (Dictionary k v)))
+ (case (get key dict)
+ #.None
+ dict
+
+ (#.Some val)
+ (put key (f val) dict)))
+
+(def: #export (upsert key default f dict)
+ {#.doc (doc "Updates the value at the key; if it exists."
+ "Otherwise, puts a value by applying the function to a default.")}
+ (All [k v] (-> k v (-> v v) (Dictionary k v) (Dictionary k v)))
+ (..put key
+ (f (maybe.default default
+ (..get key dict)))
+ dict))
+
+(def: #export size
+ (All [k v] (-> (Dictionary k v) Nat))
+ (|>> product.right ..size'))
+
+(def: #export empty?
+ (All [k v] (-> (Dictionary k v) Bit))
+ (|>> size (n.= 0)))
+
+(def: #export (entries dict)
+ (All [k v] (-> (Dictionary k v) (List [k v])))
+ (entries' (product.right dict)))
+
+(def: #export (from_list Hash<k> kvs)
+ (All [k v] (-> (Hash k) (List [k v]) (Dictionary k v)))
+ (list\fold (function (_ [k v] dict)
+ (put k v dict))
+ (new Hash<k>)
+ kvs))
+
+(template [<name> <elem_type> <side>]
+ [(def: #export (<name> dict)
+ (All [k v] (-> (Dictionary k v) (List <elem_type>)))
+ (|> dict entries (list\map <side>)))]
+
+ [keys k product.left]
+ [values v product.right]
+ )
+
+(def: #export (merge dict2 dict1)
+ {#.doc (doc "Merges 2 dictionaries."
+ "If any collisions with keys occur, the values of dict2 will overwrite those of dict1.")}
+ (All [k v] (-> (Dictionary k v) (Dictionary k v) (Dictionary k v)))
+ (list\fold (function (_ [key val] dict) (put key val dict))
+ dict1
+ (entries dict2)))
+
+(def: #export (merge_with f dict2 dict1)
+ {#.doc (doc "Merges 2 dictionaries."
+ "If any collisions with keys occur, a new value will be computed by applying 'f' to the values of dict2 and dict1.")}
+ (All [k v] (-> (-> v v v) (Dictionary k v) (Dictionary k v) (Dictionary k v)))
+ (list\fold (function (_ [key val2] dict)
+ (case (get key dict)
+ #.None
+ (put key val2 dict)
+
+ (#.Some val1)
+ (put key (f val2 val1) dict)))
+ dict1
+ (entries dict2)))
+
+(def: #export (re_bind from_key to_key dict)
+ (All [k v] (-> k k (Dictionary k v) (Dictionary k v)))
+ (case (get from_key dict)
+ #.None
+ dict
+
+ (#.Some val)
+ (|> dict
+ (remove from_key)
+ (put to_key val))))
+
+(def: #export (select keys dict)
+ {#.doc "Creates a sub-set of the given dict, with only the specified keys."}
+ (All [k v] (-> (List k) (Dictionary k v) (Dictionary k v)))
+ (let [[Hash<k> _] dict]
+ (list\fold (function (_ key new_dict)
+ (case (get key dict)
+ #.None new_dict
+ (#.Some val) (put key val new_dict)))
+ (new Hash<k>)
+ keys)))
+
+(implementation: #export (equivalence (^open ",\."))
+ (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v))))
+
+ (def: (= reference subject)
+ (and (n.= (..size reference)
+ (..size subject))
+ (list.every? (function (_ [k rv])
+ (case (..get k subject)
+ (#.Some sv)
+ (,\= rv sv)
+
+ _
+ #0))
+ (..entries reference)))))
+
+(implementation: functor'
+ (All [k] (Functor (Node k)))
+
+ (def: (map f fa)
+ (case fa
+ (#Hierarchy size hierarchy)
+ (#Hierarchy size (array\map (map f) hierarchy))
+
+ (#Base bitmap base)
+ (#Base bitmap (array\map (function (_ either)
+ (case either
+ (#.Left fa')
+ (#.Left (map f fa'))
+
+ (#.Right [k v])
+ (#.Right [k (f v)])))
+ base))
+
+ (#Collisions hash collisions)
+ (#Collisions hash (array\map (function (_ [k v])
+ [k (f v)])
+ collisions)))))
+
+(implementation: #export functor
+ (All [k] (Functor (Dictionary k)))
+
+ (def: (map f fa)
+ (update@ #root (\ ..functor' map f) fa)))
diff --git a/stdlib/source/library/lux/data/collection/dictionary/ordered.lux b/stdlib/source/library/lux/data/collection/dictionary/ordered.lux
new file mode 100644
index 000000000..5c8b82ebd
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/dictionary/ordered.lux
@@ -0,0 +1,584 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ equivalence
+ [monad (#+ Monad do)]
+ ["." order (#+ Order)]]
+ [data
+ ["p" product]
+ ["." maybe]
+ [collection
+ ["." list ("#\." monoid fold)]]]
+ [macro
+ ["." code]]
+ [math
+ [number
+ ["n" nat]]]]])
+
+(def: error_message
+ "Invariant violation")
+
+(type: Color
+ #Red
+ #Black)
+
+(type: (Node k v)
+ {#color Color
+ #key k
+ #value v
+ #left (Maybe (Node k v))
+ #right (Maybe (Node k v))})
+
+(template [<create> <color>]
+ [(def: (<create> key value left right)
+ (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v)))
+ {#color <color>
+ #key key
+ #value value
+ #left left
+ #right right})]
+
+ [red #Red]
+ [black #Black]
+ )
+
+(type: #export (Dictionary k v)
+ {#&order (Order k)
+ #root (Maybe (Node k v))})
+
+(def: #export (new order)
+ (All [k v] (-> (Order k) (Dictionary k v)))
+ {#&order order
+ #root #.None})
+
+## TODO: Doing inneficient access of Order functions due to compiler bug.
+## TODO: Must improve it as soon as bug is fixed.
+(def: #export (get key dict)
+ (All [k v] (-> k (Dictionary k v) (Maybe v)))
+ (let [## (^open "_\.") (get@ #&order dict)
+ ]
+ (loop [node (get@ #root dict)]
+ (case node
+ #.None
+ #.None
+
+ (#.Some node)
+ (let [node_key (get@ #key node)]
+ (cond (\ dict = node_key key)
+ ## (_\= node_key key)
+ (#.Some (get@ #value node))
+
+ (\ dict < node_key key)
+ ## (_\< node_key key)
+ (recur (get@ #left node))
+
+ ## (_\> (get@ #key node) key)
+ (recur (get@ #right node))))
+ ))))
+
+## TODO: Doing inneficient access of Order functions due to compiler bug.
+## TODO: Must improve it as soon as bug is fixed.
+(def: #export (key? dict key)
+ (All [k v] (-> (Dictionary k v) k Bit))
+ (let [## (^open "_\.") (get@ #&order dict)
+ ]
+ (loop [node (get@ #root dict)]
+ (case node
+ #.None
+ #0
+
+ (#.Some node)
+ (let [node_key (get@ #key node)]
+ (or (\ dict = node_key key)
+ ## (_\= node_key key)
+ (if (\ dict < node_key key)
+ ## (_\< node_key key)
+ (recur (get@ #left node))
+ (recur (get@ #right node)))))))))
+
+(template [<name> <side>]
+ [(def: #export (<name> dict)
+ (All [k v] (-> (Dictionary k v) (Maybe v)))
+ (case (get@ #root dict)
+ #.None
+ #.None
+
+ (#.Some node)
+ (loop [node node]
+ (case (get@ <side> node)
+ #.None
+ (#.Some (get@ #value node))
+
+ (#.Some side)
+ (recur side)))))]
+
+ [min #left]
+ [max #right]
+ )
+
+(def: #export (size dict)
+ (All [k v] (-> (Dictionary k v) Nat))
+ (loop [node (get@ #root dict)]
+ (case node
+ #.None
+ 0
+
+ (#.Some node)
+ (inc (n.+ (recur (get@ #left node))
+ (recur (get@ #right node)))))))
+
+(def: #export empty?
+ (All [k v] (-> (Dictionary k v) Bit))
+ (|>> ..size (n.= 0)))
+
+(template [<name> <other_color> <self_color> <no_change>]
+ [(def: (<name> self)
+ (All [k v] (-> (Node k v) (Node k v)))
+ (case (get@ #color self)
+ <other_color>
+ (set@ #color <self_color> self)
+
+ <self_color>
+ <no_change>
+ ))]
+
+ [blacken #Red #Black self]
+ [redden #Black #Red (error! error_message)]
+ )
+
+(def: (balance_left_add parent self)
+ (All [k v] (-> (Node k v) (Node k v) (Node k v)))
+ (with_expansions
+ [<default_behavior> (as_is (black (get@ #key parent)
+ (get@ #value parent)
+ (#.Some self)
+ (get@ #right parent)))]
+ (case (get@ #color self)
+ #Red
+ (case (get@ #left self)
+ (^multi (#.Some left)
+ [(get@ #color left) #Red])
+ (red (get@ #key self)
+ (get@ #value self)
+ (#.Some (blacken left))
+ (#.Some (black (get@ #key parent)
+ (get@ #value parent)
+ (get@ #right self)
+ (get@ #right parent))))
+
+ _
+ (case (get@ #right self)
+ (^multi (#.Some right)
+ [(get@ #color right) #Red])
+ (red (get@ #key right)
+ (get@ #value right)
+ (#.Some (black (get@ #key self)
+ (get@ #value self)
+ (get@ #left self)
+ (get@ #left right)))
+ (#.Some (black (get@ #key parent)
+ (get@ #value parent)
+ (get@ #right right)
+ (get@ #right parent))))
+
+ _
+ <default_behavior>))
+
+ #Black
+ <default_behavior>
+ )))
+
+(def: (balance_right_add parent self)
+ (All [k v] (-> (Node k v) (Node k v) (Node k v)))
+ (with_expansions
+ [<default_behavior> (as_is (black (get@ #key parent)
+ (get@ #value parent)
+ (get@ #left parent)
+ (#.Some self)))]
+ (case (get@ #color self)
+ #Red
+ (case (get@ #right self)
+ (^multi (#.Some right)
+ [(get@ #color right) #Red])
+ (red (get@ #key self)
+ (get@ #value self)
+ (#.Some (black (get@ #key parent)
+ (get@ #value parent)
+ (get@ #left parent)
+ (get@ #left self)))
+ (#.Some (blacken right)))
+
+ _
+ (case (get@ #left self)
+ (^multi (#.Some left)
+ [(get@ #color left) #Red])
+ (red (get@ #key left)
+ (get@ #value left)
+ (#.Some (black (get@ #key parent)
+ (get@ #value parent)
+ (get@ #left parent)
+ (get@ #left left)))
+ (#.Some (black (get@ #key self)
+ (get@ #value self)
+ (get@ #right left)
+ (get@ #right self))))
+
+ _
+ <default_behavior>))
+
+ #Black
+ <default_behavior>
+ )))
+
+(def: (add_left addition center)
+ (All [k v] (-> (Node k v) (Node k v) (Node k v)))
+ (case (get@ #color center)
+ #Red
+ (red (get@ #key center) (get@ #value center) (#.Some addition) (get@ #right center))
+
+ #Black
+ (balance_left_add center addition)
+ ))
+
+(def: (add_right addition center)
+ (All [k v] (-> (Node k v) (Node k v) (Node k v)))
+ (case (get@ #color center)
+ #Red
+ (red (get@ #key center) (get@ #value center) (get@ #left center) (#.Some addition))
+
+ #Black
+ (balance_right_add center addition)
+ ))
+
+(def: #export (put key value dict)
+ (All [k v] (-> k v (Dictionary k v) (Dictionary k v)))
+ (let [(^open "_\.") (get@ #&order dict)
+ root' (loop [?root (get@ #root dict)]
+ (case ?root
+ #.None
+ (#.Some (red key value #.None #.None))
+
+ (#.Some root)
+ (let [reference (get@ #key root)]
+ (`` (cond (~~ (template [<comp> <tag> <add>]
+ [(<comp> reference key)
+ (let [side_root (get@ <tag> root)
+ outcome (recur side_root)]
+ (if (is? side_root outcome)
+ ?root
+ (#.Some (<add> (maybe.assume outcome)
+ root))))]
+
+ [_\< #left add_left]
+ [(order.> (get@ #&order dict)) #right add_right]
+ ))
+
+ ## (_\= reference key)
+ (#.Some (set@ #value value root))
+ )))
+ ))]
+ (set@ #root root' dict)))
+
+(def: (left_balance key value ?left ?right)
+ (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v)))
+ (case ?left
+ (^multi (#.Some left)
+ [(get@ #color left) #Red]
+ [(get@ #left left) (#.Some left>>left)]
+ [(get@ #color left>>left) #Red])
+ (red (get@ #key left)
+ (get@ #value left)
+ (#.Some (blacken left>>left))
+ (#.Some (black key value (get@ #right left) ?right)))
+
+ (^multi (#.Some left)
+ [(get@ #color left) #Red]
+ [(get@ #right left) (#.Some left>>right)]
+ [(get@ #color left>>right) #Red])
+ (red (get@ #key left>>right)
+ (get@ #value left>>right)
+ (#.Some (black (get@ #key left)
+ (get@ #value left)
+ (get@ #left left)
+ (get@ #left left>>right)))
+ (#.Some (black key value
+ (get@ #right left>>right)
+ ?right)))
+
+ _
+ (black key value ?left ?right)))
+
+(def: (right_balance key value ?left ?right)
+ (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v)))
+ (case ?right
+ (^multi (#.Some right)
+ [(get@ #color right) #Red]
+ [(get@ #right right) (#.Some right>>right)]
+ [(get@ #color right>>right) #Red])
+ (red (get@ #key right)
+ (get@ #value right)
+ (#.Some (black key value ?left (get@ #left right)))
+ (#.Some (blacken right>>right)))
+
+ (^multi (#.Some right)
+ [(get@ #color right) #Red]
+ [(get@ #left right) (#.Some right>>left)]
+ [(get@ #color right>>left) #Red])
+ (red (get@ #key right>>left)
+ (get@ #value right>>left)
+ (#.Some (black key value ?left (get@ #left right>>left)))
+ (#.Some (black (get@ #key right)
+ (get@ #value right)
+ (get@ #right right>>left)
+ (get@ #right right))))
+
+ _
+ (black key value ?left ?right)))
+
+(def: (balance_left_remove key value ?left ?right)
+ (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v)))
+ (case ?left
+ (^multi (#.Some left)
+ [(get@ #color left) #Red])
+ (red key value (#.Some (blacken left)) ?right)
+
+ _
+ (case ?right
+ (^multi (#.Some right)
+ [(get@ #color right) #Black])
+ (right_balance key value ?left (#.Some (redden right)))
+
+ (^multi (#.Some right)
+ [(get@ #color right) #Red]
+ [(get@ #left right) (#.Some right>>left)]
+ [(get@ #color right>>left) #Black])
+ (red (get@ #key right>>left)
+ (get@ #value right>>left)
+ (#.Some (black key value ?left (get@ #left right>>left)))
+ (#.Some (right_balance (get@ #key right)
+ (get@ #value right)
+ (get@ #right right>>left)
+ (\ maybe.functor map redden (get@ #right right)))))
+
+ _
+ (error! error_message))
+ ))
+
+(def: (balance_right_remove key value ?left ?right)
+ (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v)))
+ (case ?right
+ (^multi (#.Some right)
+ [(get@ #color right) #Red])
+ (red key value ?left (#.Some (blacken right)))
+
+ _
+ (case ?left
+ (^multi (#.Some left)
+ [(get@ #color left) #Black])
+ (left_balance key value (#.Some (redden left)) ?right)
+
+ (^multi (#.Some left)
+ [(get@ #color left) #Red]
+ [(get@ #right left) (#.Some left>>right)]
+ [(get@ #color left>>right) #Black])
+ (red (get@ #key left>>right)
+ (get@ #value left>>right)
+ (#.Some (left_balance (get@ #key left)
+ (get@ #value left)
+ (\ maybe.functor map redden (get@ #left left))
+ (get@ #left left>>right)))
+ (#.Some (black key value (get@ #right left>>right) ?right)))
+
+ _
+ (error! error_message)
+ )))
+
+(def: (prepend ?left ?right)
+ (All [k v] (-> (Maybe (Node k v)) (Maybe (Node k v)) (Maybe (Node k v))))
+ (case [?left ?right]
+ [#.None _]
+ ?right
+
+ [_ #.None]
+ ?left
+
+ [(#.Some left) (#.Some right)]
+ (case [(get@ #color left) (get@ #color right)]
+ [#Red #Red]
+ (do maybe.monad
+ [fused (prepend (get@ #right left) (get@ #right right))]
+ (case (get@ #color fused)
+ #Red
+ (wrap (red (get@ #key fused)
+ (get@ #value fused)
+ (#.Some (red (get@ #key left)
+ (get@ #value left)
+ (get@ #left left)
+ (get@ #left fused)))
+ (#.Some (red (get@ #key right)
+ (get@ #value right)
+ (get@ #right fused)
+ (get@ #right right)))))
+
+ #Black
+ (wrap (red (get@ #key left)
+ (get@ #value left)
+ (get@ #left left)
+ (#.Some (red (get@ #key right)
+ (get@ #value right)
+ (#.Some fused)
+ (get@ #right right)))))))
+
+ [#Red #Black]
+ (#.Some (red (get@ #key left)
+ (get@ #value left)
+ (get@ #left left)
+ (prepend (get@ #right left)
+ ?right)))
+
+ [#Black #Red]
+ (#.Some (red (get@ #key right)
+ (get@ #value right)
+ (prepend ?left
+ (get@ #left right))
+ (get@ #right right)))
+
+ [#Black #Black]
+ (do maybe.monad
+ [fused (prepend (get@ #right left) (get@ #left right))]
+ (case (get@ #color fused)
+ #Red
+ (wrap (red (get@ #key fused)
+ (get@ #value fused)
+ (#.Some (black (get@ #key left)
+ (get@ #value left)
+ (get@ #left left)
+ (get@ #left fused)))
+ (#.Some (black (get@ #key right)
+ (get@ #value right)
+ (get@ #right fused)
+ (get@ #right right)))))
+
+ #Black
+ (wrap (balance_left_remove (get@ #key left)
+ (get@ #value left)
+ (get@ #left left)
+ (#.Some (black (get@ #key right)
+ (get@ #value right)
+ (#.Some fused)
+ (get@ #right right)))))
+ ))
+ )
+
+ _
+ (undefined)))
+
+(def: #export (remove key dict)
+ (All [k v] (-> k (Dictionary k v) (Dictionary k v)))
+ (let [(^open "_\.") (get@ #&order dict)
+ [?root found?] (loop [?root (get@ #root dict)]
+ (case ?root
+ #.None
+ [#.None #0]
+
+ (#.Some root)
+ (let [root_key (get@ #key root)
+ root_val (get@ #value root)]
+ (if (_\= root_key key)
+ [(prepend (get@ #left root)
+ (get@ #right root))
+ #1]
+ (let [go_left? (_\< root_key key)]
+ (case (recur (if go_left?
+ (get@ #left root)
+ (get@ #right root)))
+ [#.None #0]
+ [#.None #0]
+
+ [side_outcome _]
+ (if go_left?
+ (case (get@ #left root)
+ (^multi (#.Some left)
+ [(get@ #color left) #Black])
+ [(#.Some (balance_left_remove root_key root_val side_outcome (get@ #right root)))
+ #0]
+
+ _
+ [(#.Some (red root_key root_val side_outcome (get@ #right root)))
+ #0])
+ (case (get@ #right root)
+ (^multi (#.Some right)
+ [(get@ #color right) #Black])
+ [(#.Some (balance_right_remove root_key root_val (get@ #left root) side_outcome))
+ #0]
+
+ _
+ [(#.Some (red root_key root_val (get@ #left root) side_outcome))
+ #0])
+ )))
+ ))
+ ))]
+ (case ?root
+ #.None
+ (if found?
+ (set@ #root ?root dict)
+ dict)
+
+ (#.Some root)
+ (set@ #root (#.Some (blacken root)) dict)
+ )))
+
+(def: #export (update key transform dict)
+ (All [k v] (-> k (-> v v) (Dictionary k v) (Dictionary k v)))
+ (case (..get key dict)
+ (#.Some old)
+ (..put key (transform old) dict)
+
+ #.None
+ dict))
+
+(def: #export (from_list Order<l> list)
+ (All [k v] (-> (Order k) (List [k v]) (Dictionary k v)))
+ (list\fold (function (_ [key value] dict)
+ (put key value dict))
+ (new Order<l>)
+ list))
+
+(template [<name> <type> <output>]
+ [(def: #export (<name> dict)
+ (All [k v] (-> (Dictionary k v) (List <type>)))
+ (loop [node (get@ #root dict)]
+ (case node
+ #.None
+ (list)
+
+ (#.Some node')
+ ($_ list\compose
+ (recur (get@ #left node'))
+ (list <output>)
+ (recur (get@ #right node'))))))]
+
+ [entries [k v] [(get@ #key node') (get@ #value node')]]
+ [keys k (get@ #key node')]
+ [values v (get@ #value node')]
+ )
+
+(implementation: #export (equivalence (^open ",\."))
+ (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v))))
+
+ (def: (= reference sample)
+ (let [(^open "/\.") (get@ #&order reference)]
+ (loop [entriesR (entries reference)
+ entriesS (entries sample)]
+ (case [entriesR entriesS]
+ [#.Nil #.Nil]
+ #1
+
+ [(#.Cons [keyR valueR] entriesR') (#.Cons [keyS valueS] entriesS')]
+ (and (/\= keyR keyS)
+ (,\= valueR valueS)
+ (recur entriesR' entriesS'))
+
+ _
+ #0)))))
diff --git a/stdlib/source/library/lux/data/collection/dictionary/plist.lux b/stdlib/source/library/lux/data/collection/dictionary/plist.lux
new file mode 100644
index 000000000..f3f51c779
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/dictionary/plist.lux
@@ -0,0 +1,98 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." product]
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ [number
+ ["n" nat]]]]])
+
+(type: #export (PList a)
+ (List [Text a]))
+
+(def: #export empty
+ PList
+ #.Nil)
+
+(def: #export size
+ (All [a] (-> (PList a) Nat))
+ list.size)
+
+(def: #export empty?
+ (All [a] (-> (PList a) Bit))
+ (|>> ..size (n.= 0)))
+
+(def: #export (get key properties)
+ (All [a] (-> Text (PList a) (Maybe a)))
+ (case properties
+ #.Nil
+ #.None
+
+ (#.Cons [k' v'] properties')
+ (if (text\= key k')
+ (#.Some v')
+ (get key properties'))))
+
+(template [<name> <type> <access>]
+ [(def: #export <name>
+ (All [a] (-> (PList a) (List <type>)))
+ (list\map <access>))]
+
+ [keys Text product.left]
+ [values a product.right]
+ )
+
+(def: #export (contains? key properties)
+ (All [a] (-> Text (PList a) Bit))
+ (case (..get key properties)
+ (#.Some _)
+ true
+
+ #.None
+ false))
+
+(def: #export (put key val properties)
+ (All [a] (-> Text a (PList a) (PList a)))
+ (case properties
+ #.Nil
+ (list [key val])
+
+ (#.Cons [k' v'] properties')
+ (if (text\= key k')
+ (#.Cons [key val]
+ properties')
+ (#.Cons [k' v']
+ (put key val properties')))))
+
+(def: #export (update key f properties)
+ (All [a] (-> Text (-> a a) (PList a) (PList a)))
+ (case properties
+ #.Nil
+ #.Nil
+
+ (#.Cons [k' v'] properties')
+ (if (text\= key k')
+ (#.Cons [k' (f v')] properties')
+ (#.Cons [k' v'] (update key f properties')))))
+
+(def: #export (remove key properties)
+ (All [a] (-> Text (PList a) (PList a)))
+ (case properties
+ #.Nil
+ properties
+
+ (#.Cons [k' v'] properties')
+ (if (text\= key k')
+ properties'
+ (#.Cons [k' v']
+ (remove key properties')))))
+
+(def: #export equivalence
+ (All [a] (-> (Equivalence a) (Equivalence (PList a))))
+ (|>> (product.equivalence text.equivalence)
+ list.equivalence))
diff --git a/stdlib/source/library/lux/data/collection/list.lux b/stdlib/source/library/lux/data/collection/list.lux
new file mode 100644
index 000000000..166b4c87b
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/list.lux
@@ -0,0 +1,616 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ [abstract
+ [monoid (#+ Monoid)]
+ [apply (#+ Apply)]
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]
+ [fold (#+ Fold)]
+ [predicate (#+ Predicate)]
+ ["." functor (#+ Functor)]
+ ["." monad (#+ do Monad)]
+ ["." enum]]
+ [data
+ ["." bit]
+ ["." product]]
+ [math
+ [number
+ ["n" nat]]]]])
+
+## (type: (List a)
+## #Nil
+## (#Cons a (List a)))
+
+(implementation: #export fold
+ (Fold List)
+
+ (def: (fold f init xs)
+ (case xs
+ #.Nil
+ init
+
+ (#.Cons x xs')
+ (fold f (f x init) xs'))))
+
+(def: #export (folds f init inputs)
+ (All [a b] (-> (-> a b b) b (List a) (List b)))
+ (case inputs
+ #.Nil
+ (list init)
+
+ (#.Cons [head tail])
+ (#.Cons [init (folds f (f head init) tail)])))
+
+(def: #export (reverse xs)
+ (All [a]
+ (-> (List a) (List a)))
+ (fold (function (_ head tail) (#.Cons head tail))
+ #.Nil
+ xs))
+
+(def: #export (filter keep? xs)
+ (All [a]
+ (-> (Predicate a) (List a) (List a)))
+ (case xs
+ #.Nil
+ #.Nil
+
+ (#.Cons x xs')
+ (if (keep? x)
+ (#.Cons x (filter keep? xs'))
+ (filter keep? xs'))))
+
+(def: #export (partition satisfies? list)
+ {#.doc "Divide the list into all elements that satisfy a predicate, and all elements that do not."}
+ (All [a] (-> (Predicate a) (List a) [(List a) (List a)]))
+ (case list
+ #.Nil
+ [#.Nil #.Nil]
+
+ (#.Cons head tail)
+ (let [[in out] (partition satisfies? tail)]
+ (if (satisfies? head)
+ [(#.Cons head in) out]
+ [in (#.Cons head out)]))))
+
+(def: #export (as_pairs xs)
+ {#.doc (doc "Cut the list into pairs of 2."
+ "Caveat emptor: If the list has an uneven number of elements, the last one will be skipped.")}
+ (All [a] (-> (List a) (List [a a])))
+ (case xs
+ (^ (list& x1 x2 xs'))
+ (#.Cons [x1 x2] (as_pairs xs'))
+
+ _
+ #.Nil))
+
+(template [<name> <then> <else>]
+ [(def: #export (<name> n xs)
+ (All [a]
+ (-> Nat (List a) (List a)))
+ (if (n.> 0 n)
+ (case xs
+ #.Nil
+ #.Nil
+
+ (#.Cons x xs')
+ <then>)
+ <else>))]
+
+ [take (#.Cons x (take (dec n) xs')) #.Nil]
+ [drop (drop (dec n) xs') xs]
+ )
+
+(template [<name> <then> <else>]
+ [(def: #export (<name> predicate xs)
+ (All [a]
+ (-> (Predicate a) (List a) (List a)))
+ (case xs
+ #.Nil
+ #.Nil
+
+ (#.Cons x xs')
+ (if (predicate x)
+ <then>
+ <else>)))]
+
+ [take_while (#.Cons x (take_while predicate xs')) #.Nil]
+ [drop_while (drop_while predicate xs') xs]
+ )
+
+(def: #export (split n xs)
+ (All [a]
+ (-> Nat (List a) [(List a) (List a)]))
+ (if (n.> 0 n)
+ (case xs
+ #.Nil
+ [#.Nil #.Nil]
+
+ (#.Cons x xs')
+ (let [[tail rest] (split (dec n) xs')]
+ [(#.Cons x tail) rest]))
+ [#.Nil xs]))
+
+(def: (split_with' predicate ys xs)
+ (All [a]
+ (-> (Predicate a) (List a) (List a) [(List a) (List a)]))
+ (case xs
+ #.Nil
+ [ys xs]
+
+ (#.Cons x xs')
+ (if (predicate x)
+ (split_with' predicate (#.Cons x ys) xs')
+ [ys xs])))
+
+(def: #export (split_with predicate xs)
+ {#.doc "Segment the list by using a predicate to tell when to cut."}
+ (All [a]
+ (-> (Predicate a) (List a) [(List a) (List a)]))
+ (let [[ys' xs'] (split_with' predicate #.Nil xs)]
+ [(reverse ys') xs']))
+
+(def: #export (chunk n xs)
+ {#.doc "Segment the list in chunks of size N."}
+ (All [a] (-> Nat (List a) (List (List a))))
+ (case xs
+ #.Nil
+ (list)
+
+ _
+ (let [[pre post] (split n xs)]
+ (#.Cons pre (chunk n post)))))
+
+(def: #export (repeat n x)
+ {#.doc "A list of the value x, repeated n times."}
+ (All [a]
+ (-> Nat a (List a)))
+ (if (n.> 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')
+ (#.Cons x (iterate' f x'))
+
+ #.None
+ (list)))
+
+(def: #export (iterate f x)
+ {#.doc "Generates a list element by element until the function returns #.None."}
+ (All [a]
+ (-> (-> a (Maybe a)) a (List a)))
+ (case (f x)
+ (#.Some x')
+ (#.Cons x (iterate' f x'))
+
+ #.None
+ (list x)))
+
+(def: #export (one check xs)
+ (All [a b]
+ (-> (-> a (Maybe b)) (List a) (Maybe b)))
+ (case xs
+ #.Nil
+ #.None
+
+ (#.Cons x xs')
+ (case (check x)
+ (#.Some output)
+ (#.Some output)
+
+ #.None
+ (one check xs'))))
+
+(def: #export (all check xs)
+ (All [a b]
+ (-> (-> a (Maybe b)) (List a) (List b)))
+ (for {## TODO: Stop relying on this ASAP.
+ @.js
+ (fold (function (_ head tail)
+ (case (check head)
+ (#.Some head)
+ (#.Cons head tail)
+
+ #.None
+ tail))
+ #.Nil
+ (reverse xs))}
+ (case xs
+ #.Nil
+ #.Nil
+
+ (#.Cons x xs')
+ (case (check x)
+ (#.Some output)
+ (#.Cons output (all check xs'))
+
+ #.None
+ (all check xs')))))
+
+(def: #export (find predicate xs)
+ {#.doc "Returns the first value in the list for which the predicate is #1."}
+ (All [a]
+ (-> (Predicate a) (List a) (Maybe a)))
+ (..one (function (_ value)
+ (if (predicate value)
+ (#.Some value)
+ #.None))
+ xs))
+
+(def: #export (interpose sep xs)
+ {#.doc "Puts a value between every two elements in the list."}
+ (All [a]
+ (-> a (List a) (List a)))
+ (case xs
+ #.Nil
+ xs
+
+ (#.Cons x #.Nil)
+ xs
+
+ (#.Cons x xs')
+ (list& x sep (interpose sep xs'))))
+
+(def: #export (size list)
+ (All [a] (-> (List a) Nat))
+ (fold (function (_ _ acc) (n.+ 1 acc)) 0 list))
+
+(template [<name> <init> <op>]
+ [(def: #export (<name> predicate xs)
+ (All [a]
+ (-> (Predicate a) (List a) Bit))
+ (loop [xs xs]
+ (case xs
+ #.Nil
+ <init>
+
+ (#.Cons x xs')
+ (case (predicate x)
+ <init>
+ (recur xs')
+
+ output
+ output))))]
+
+ [every? #1 and]
+ [any? #0 or]
+ )
+
+(def: #export (nth i xs)
+ {#.doc "Fetches the element at the specified index."}
+ (All [a]
+ (-> Nat (List a) (Maybe a)))
+ (case xs
+ #.Nil
+ #.None
+
+ (#.Cons x xs')
+ (if (n.= 0 i)
+ (#.Some x)
+ (nth (dec i) xs'))))
+
+(implementation: #export (equivalence Equivalence<a>)
+ (All [a] (-> (Equivalence a) (Equivalence (List a))))
+
+ (def: (= xs ys)
+ (case [xs ys]
+ [#.Nil #.Nil]
+ #1
+
+ [(#.Cons x xs') (#.Cons y ys')]
+ (and (\ Equivalence<a> = x y)
+ (= xs' ys'))
+
+ [_ _]
+ #0
+ )))
+
+(implementation: #export (hash super)
+ (All [a] (-> (Hash a) (Hash (List a))))
+
+ (def: &equivalence
+ (..equivalence (\ super &equivalence)))
+
+ (def: hash
+ (\ ..fold fold
+ (function (_ member hash)
+ (n.+ (\ super hash member) hash))
+ 0)))
+
+(implementation: #export monoid
+ (All [a] (Monoid (List a)))
+
+ (def: identity #.Nil)
+ (def: (compose xs ys)
+ (case xs
+ #.Nil
+ ys
+
+ (#.Cons x xs')
+ (#.Cons x (compose xs' ys)))))
+
+(open: "." ..monoid)
+
+(implementation: #export functor
+ (Functor List)
+
+ (def: (map f ma)
+ (case ma
+ #.Nil
+ #.Nil
+
+ (#.Cons a ma')
+ (#.Cons (f a) (map f ma')))))
+
+(open: "." ..functor)
+
+(implementation: #export apply
+ (Apply List)
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (case ff
+ #.Nil
+ #.Nil
+
+ (#.Cons f ff')
+ (compose (map f fa) (apply ff' fa)))))
+
+(implementation: #export monad
+ (Monad List)
+
+ (def: &functor ..functor)
+
+ (def: (wrap a)
+ (#.Cons a #.Nil))
+
+ (def: join (|>> reverse (fold compose identity))))
+
+(def: #export (sort < xs)
+ (All [a] (-> (-> a a Bit) (List a) (List a)))
+ (case xs
+ #.Nil
+ (list)
+
+ (#.Cons x xs')
+ (let [[pre post] (fold (function (_ x' [pre post])
+ (if (< x x')
+ [(#.Cons x' pre) post]
+ [pre (#.Cons x' post)]))
+ [(list) (list)]
+ xs')]
+ ($_ compose (sort < pre) (list x) (sort < post)))))
+
+(def: #export (empty? xs)
+ (All [a] (Predicate (List a)))
+ (case xs
+ #.Nil
+ true
+
+ _
+ false))
+
+(def: #export (member? eq xs x)
+ (All [a] (-> (Equivalence a) (List a) a Bit))
+ (case xs
+ #.Nil
+ #0
+
+ (#.Cons x' xs')
+ (or (\ eq = x x')
+ (member? eq xs' x))))
+
+(template [<name> <output> <side> <doc>]
+ [(def: #export (<name> xs)
+ {#.doc <doc>}
+ (All [a] (-> (List a) (Maybe <output>)))
+ (case xs
+ #.Nil
+ #.None
+
+ (#.Cons x xs')
+ (#.Some <side>)))]
+
+ [head a x "Returns the first element of a list."]
+ [tail (List a) xs' "For a list of size N, returns the N-1 elements after the first one."]
+ )
+
+(def: #export (indices size)
+ {#.doc "Produces all the valid indices for a given size."}
+ (All [a] (-> Nat (List Nat)))
+ (if (n.= 0 size)
+ (list)
+ (|> size dec (enum.range n.enum 0))))
+
+(def: (identifier$ name)
+ (-> Text Code)
+ [["" 0 0] (#.Identifier "" name)])
+
+(def: (nat@encode value)
+ (-> Nat Text)
+ (loop [input value
+ output ""]
+ (let [digit (case (n.% 10 input)
+ 0 "0"
+ 1 "1"
+ 2 "2"
+ 3 "3"
+ 4 "4"
+ 5 "5"
+ 6 "6"
+ 7 "7"
+ 8 "8"
+ 9 "9"
+ _ (undefined))
+ output' ("lux text concat" digit output)
+ input' (n./ 10 input)]
+ (if (n.= 0 input')
+ output'
+ (recur input' output')))))
+
+(macro: #export (zip tokens state)
+ {#.doc (doc "Create list zippers with the specified number of input lists."
+ (def: #export zip/2 (zip 2))
+ (def: #export zip/3 (zip 3))
+ ((zip 3) xs ys zs))}
+ (case tokens
+ (^ (list [_ (#.Nat num_lists)]))
+ (if (n.> 0 num_lists)
+ (let [(^open ".") ..functor
+ indices (..indices num_lists)
+ type_vars (: (List Code) (map (|>> nat@encode identifier$) indices))
+ zip_type (` (All [(~+ type_vars)]
+ (-> (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var)))))
+ type_vars))
+ (List [(~+ type_vars)]))))
+ vars+lists (|> indices
+ (map inc)
+ (map (function (_ idx)
+ (let [base (nat@encode idx)]
+ [(identifier$ base)
+ (identifier$ ("lux text concat" base "'"))]))))
+ pattern (` [(~+ (map (function (_ [v vs]) (` (#.Cons (~ v) (~ vs))))
+ vars+lists))])
+ g!step (identifier$ "0step0")
+ g!blank (identifier$ "0,0")
+ list_vars (map product.right vars+lists)
+ code (` (: (~ zip_type)
+ (function ((~ 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 "Cannot zip 0 lists."))
+
+ _
+ (#.Left "Wrong syntax for zip")))
+
+(def: #export zip/2 (zip 2))
+(def: #export zip/3 (zip 3))
+
+(macro: #export (zip_with tokens state)
+ {#.doc (doc "Create list zippers with the specified number of input lists."
+ (def: #export zip_with/2 (zip_with 2))
+ (def: #export zip_with/3 (zip_with 3))
+ ((zip_with 2) + xs ys))}
+ (case tokens
+ (^ (list [_ (#.Nat num_lists)]))
+ (if (n.> 0 num_lists)
+ (let [(^open ".") ..functor
+ indices (..indices num_lists)
+ g!return_type (identifier$ "0return_type0")
+ g!func (identifier$ "0func0")
+ type_vars (: (List Code) (map (|>> nat@encode identifier$) indices))
+ zip_type (` (All [(~+ type_vars) (~ g!return_type)]
+ (-> (-> (~+ type_vars) (~ g!return_type))
+ (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var)))))
+ type_vars))
+ (List (~ g!return_type)))))
+ vars+lists (|> indices
+ (map inc)
+ (map (function (_ idx)
+ (let [base (nat@encode idx)]
+ [(identifier$ base)
+ (identifier$ ("lux text concat" base "'"))]))))
+ pattern (` [(~+ (map (function (_ [v vs]) (` (#.Cons (~ v) (~ vs))))
+ vars+lists))])
+ g!step (identifier$ "0step0")
+ g!blank (identifier$ "0,0")
+ list_vars (map product.right vars+lists)
+ code (` (: (~ zip_type)
+ (function ((~ 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 "Cannot zip_with 0 lists."))
+
+ _
+ (#.Left "Wrong syntax for zip_with")))
+
+(def: #export zip_with/2 (zip_with 2))
+(def: #export zip_with/3 (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)
+ {#.doc (doc "For a list of size N, returns the first N-1 elements."
+ "Empty lists will result in a #.None value being returned instead.")}
+ (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))
+
+(implementation: #export (with monad)
+ (All [M] (-> (Monad M) (Monad (All [a] (M (List a))))))
+
+ (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor))
+
+ (def: wrap (|>> (\ ..monad wrap) (\ monad wrap)))
+
+ (def: (join MlMla)
+ (do {! monad}
+ [lMla MlMla
+ ## TODO: Remove this version ASAP and use one below.
+ lla (for {@.old
+ (: (($ 0) (List (List ($ 1))))
+ (monad.seq ! lMla))}
+ (monad.seq ! lMla))]
+ (wrap (concat lla)))))
+
+(def: #export (lift monad)
+ (All [M a] (-> (Monad M) (-> (M a) (M (List a)))))
+ (\ monad map (\ ..monad wrap)))
+
+(def: #export (enumeration xs)
+ {#.doc "Pairs every element in the list with its index, starting at 0."}
+ (All [a] (-> (List a) (List [Nat a])))
+ (loop [idx 0
+ xs xs]
+ (case xs
+ #.Nil
+ #.Nil
+
+ (#.Cons x xs')
+ (#.Cons [idx x] (recur (inc idx) xs')))))
diff --git a/stdlib/source/library/lux/data/collection/queue.lux b/stdlib/source/library/lux/data/collection/queue.lux
new file mode 100644
index 000000000..cb4d9106f
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/queue.lux
@@ -0,0 +1,93 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [functor (#+ Functor)]]
+ [data
+ [collection
+ ["." list ("#\." monoid functor)]]]
+ [math
+ [number
+ ["n" nat]]]]])
+
+(type: #export (Queue a)
+ {#front (List a)
+ #rear (List a)})
+
+(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\compose 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]
+ (n.+ (list.size front)
+ (list.size rear))))
+
+(def: #export empty?
+ (All [a] (-> (Queue a) Bit))
+ (|>> (get@ #front) list.empty?))
+
+(def: #export (member? equivalence queue member)
+ (All [a] (-> (Equivalence a) (Queue a) a Bit))
+ (let [(^slots [#front #rear]) queue]
+ (or (list.member? equivalence front member)
+ (list.member? equivalence rear member))))
+
+(def: #export (pop queue)
+ (All [a] (-> (Queue a) (Queue a)))
+ (case (get@ #front queue)
+ ## Empty...
+ (^ (list))
+ queue
+
+ ## Front has dried up...
+ (^ (list _))
+ (|> queue
+ (set@ #front (list.reverse (get@ #rear queue)))
+ (set@ #rear (list)))
+
+ ## Consume front!
+ (^ (list& _ front'))
+ (|> queue
+ (set@ #front front'))))
+
+(def: #export (push val queue)
+ (All [a] (-> a (Queue a) (Queue a)))
+ (case (get@ #front queue)
+ #.Nil
+ (set@ #front (list val) queue)
+
+ _
+ (update@ #rear (|>> (#.Cons val)) queue)))
+
+(implementation: #export (equivalence super)
+ (All [a] (-> (Equivalence a) (Equivalence (Queue a))))
+
+ (def: (= reference subject)
+ (\ (list.equivalence super) =
+ (..to_list reference)
+ (..to_list subject))))
+
+(implementation: #export functor
+ (Functor Queue)
+
+ (def: (map f fa)
+ {#front (|> fa (get@ #front) (list\map f))
+ #rear (|> fa (get@ #rear) (list\map f))}))
diff --git a/stdlib/source/library/lux/data/collection/queue/priority.lux b/stdlib/source/library/lux/data/collection/queue/priority.lux
new file mode 100644
index 000000000..d044a5023
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/queue/priority.lux
@@ -0,0 +1,121 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do Monad)]]
+ [data
+ ["." maybe]
+ [collection
+ ["." tree #_
+ ["#" finger (#+ Tree)]]]]
+ [math
+ [number
+ ["n" nat ("#\." interval)]]]
+ [type (#+ :by_example)
+ [abstract (#+ abstract: :abstraction :representation)]]]])
+
+(type: #export Priority
+ Nat)
+
+(def: #export max Priority n\top)
+(def: #export min Priority n\bottom)
+
+(def: builder
+ (tree.builder n.maximum))
+
+(def: :@:
+ (:by_example [@]
+ (tree.Builder @ Priority)
+ ..builder
+
+ @))
+
+(abstract: #export (Queue a)
+ (Maybe (Tree :@: Priority a))
+
+ (def: #export empty
+ Queue
+ (:abstraction #.None))
+
+ (def: #export (peek queue)
+ (All [a] (-> (Queue a) (Maybe a)))
+ (do maybe.monad
+ [tree (:representation queue)]
+ (tree.search (n.= (tree.tag tree))
+ tree)))
+
+ (def: #export (size queue)
+ (All [a] (-> (Queue a) Nat))
+ (case (:representation queue)
+ #.None
+ 0
+
+ (#.Some tree)
+ (loop [node tree]
+ (case (tree.root node)
+ (0 #0 _)
+ 1
+
+ (0 #1 [left right])
+ (n.+ (recur left) (recur right))))))
+
+ (def: #export (member? equivalence queue member)
+ (All [a] (-> (Equivalence a) (Queue a) a Bit))
+ (case (:representation queue)
+ #.None
+ false
+
+ (#.Some tree)
+ (loop [node tree]
+ (case (tree.root node)
+ (0 #0 reference)
+ (\ equivalence = reference member)
+
+ (0 #1 [left right])
+ (or (recur left)
+ (recur right))))))
+
+ (def: #export (pop queue)
+ (All [a] (-> (Queue a) (Queue a)))
+ (:abstraction
+ (do maybe.monad
+ [tree (:representation queue)
+ #let [highest_priority (tree.tag tree)]]
+ (loop [node tree]
+ (case (tree.root node)
+ (0 #0 reference)
+ (if (n.= highest_priority (tree.tag node))
+ #.None
+ (#.Some node))
+
+ (0 #1 left right)
+ (if (n.= highest_priority (tree.tag left))
+ (case (recur left)
+ #.None
+ (#.Some right)
+
+ (#.Some =left)
+ (#.Some (\ ..builder branch =left right)))
+ (case (recur right)
+ #.None
+ (#.Some left)
+
+ (#.Some =right)
+ (#.Some (\ ..builder branch left =right)))))))))
+
+ (def: #export (push priority value queue)
+ (All [a] (-> Priority a (Queue a) (Queue a)))
+ (let [addition (\ ..builder leaf priority value)]
+ (:abstraction
+ (case (:representation queue)
+ #.None
+ (#.Some addition)
+
+ (#.Some tree)
+ (#.Some (\ ..builder branch tree addition))))))
+ )
+
+(def: #export empty?
+ (All [a] (-> (Queue a) Bit))
+ (|>> ..size (n.= 0)))
diff --git a/stdlib/source/library/lux/data/collection/row.lux b/stdlib/source/library/lux/data/collection/row.lux
new file mode 100644
index 000000000..0bb304c35
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/row.lux
@@ -0,0 +1,490 @@
+## https://hypirion.com/musings/understanding-persistent-vector-pt-1
+## https://hypirion.com/musings/understanding-persistent-vector-pt-2
+## https://hypirion.com/musings/understanding-persistent-vector-pt-3
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ [monad (#+ Monad do)]
+ [equivalence (#+ Equivalence)]
+ [monoid (#+ Monoid)]
+ [fold (#+ Fold)]
+ [predicate (#+ Predicate)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["p" parser
+ ["s" code (#+ Parser)]]]
+ [data
+ ["." maybe]
+ ["." product]
+ [collection
+ ["." list ("#\." fold functor monoid)]
+ ["." array (#+ Array) ("#\." functor fold)]]]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number
+ ["." i64]
+ ["n" nat]]]]])
+
+(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)
+
+(template [<name> <op>]
+ [(def: <name>
+ (-> Level Level)
+ (<op> branching_exponent))]
+
+ [level_up n.+]
+ [level_down n.-]
+ )
+
+(def: full_node_size
+ Nat
+ (i64.left_shift branching_exponent 1))
+
+(def: branch_idx_mask
+ Nat
+ (dec full_node_size))
+
+(def: branch_idx
+ (-> Index Index)
+ (i64.and branch_idx_mask))
+
+(def: (new_hierarchy _)
+ (All [a] (-> Any (Hierarchy a)))
+ (array.new full_node_size))
+
+(def: (tail_off row_size)
+ (-> Nat Nat)
+ (if (n.< full_node_size row_size)
+ 0
+ (|> (dec row_size)
+ (i64.right_shift branching_exponent)
+ (i64.left_shift branching_exponent))))
+
+(def: (new_path level tail)
+ (All [a] (-> Level (Base a) (Node a)))
+ (if (n.= 0 level)
+ (#Base tail)
+ (|> (new_hierarchy [])
+ (array.write! 0 (new_path (level_down level) tail))
+ #Hierarchy)))
+
+(def: (new_tail singleton)
+ (All [a] (-> a (Base a)))
+ (|> (array.new 1)
+ (array.write! 0 singleton)))
+
+(def: (push_tail size level tail parent)
+ (All [a] (-> Nat Level (Base a) (Hierarchy a) (Hierarchy a)))
+ (let [sub_idx (branch_idx (i64.right_shift level (dec size)))
+ ## If we're currently on a bottom node
+ sub_node (if (n.= branching_exponent level)
+ ## Just add the tail to it
+ (#Base tail)
+ ## Otherwise, check whether there's a vacant spot
+ (case (array.read 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.write! sub_idx sub_node))))
+
+(def: (expand_tail val tail)
+ (All [a] (-> a (Base a) (Base a)))
+ (let [tail_size (array.size tail)]
+ (|> (array.new (inc tail_size))
+ (array.copy! tail_size 0 tail 0)
+ (array.write! tail_size val))))
+
+(def: (put' level idx val hierarchy)
+ (All [a] (-> Level Index a (Hierarchy a) (Hierarchy a)))
+ (let [sub_idx (branch_idx (i64.right_shift level idx))]
+ (case (array.read sub_idx hierarchy)
+ (#.Some (#Hierarchy sub_node))
+ (|> (array.clone hierarchy)
+ (array.write! sub_idx (#Hierarchy (put' (level_down level) idx val sub_node))))
+
+ (^multi (#.Some (#Base base))
+ (n.= 0 (level_down level)))
+ (|> (array.clone hierarchy)
+ (array.write! sub_idx (|> (array.clone base)
+ (array.write! (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 (i64.right_shift level (n.- 2 size)))]
+ (cond (n.= 0 sub_idx)
+ #.None
+
+ (n.> branching_exponent level)
+ (do maybe.monad
+ [base|hierarchy (array.read sub_idx hierarchy)
+ sub (case base|hierarchy
+ (#Hierarchy sub)
+ (pop_tail size (level_down level) sub)
+
+ (#Base _)
+ (undefined))]
+ (|> (array.clone hierarchy)
+ (array.write! sub_idx (#Hierarchy sub))
+ #.Some))
+
+ ## Else...
+ (|> (array.clone hierarchy)
+ (array.delete! 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 (function (_ sub acc) (list\compose (to_list' sub) acc))
+ #.Nil))))
+
+(type: #export (Row a)
+ {#level Level
+ #size Nat
+ #root (Hierarchy a)
+ #tail (Base a)})
+
+(def: #export empty
+ Row
+ {#level (level_up root_level)
+ #size 0
+ #root (array.new full_node_size)
+ #tail (array.new 0)})
+
+(def: #export (size row)
+ (All [a] (-> (Row a) Nat))
+ (get@ #size row))
+
+(def: #export (add val row)
+ (All [a] (-> a (Row a) (Row a)))
+ ## Check if there is room in the tail.
+ (let [row_size (get@ #size row)]
+ (if (|> row_size (n.- (tail_off row_size)) (n.< full_node_size))
+ ## If so, append to it.
+ (|> row
+ (update@ #size inc)
+ (update@ #tail (expand_tail val)))
+ ## Otherwise, push tail into the tree
+ ## --------------------------------------------------------
+ ## Will the root experience an overflow with this addition?
+ (|> (if (n.> (i64.left_shift (get@ #level row) 1)
+ (i64.right_shift branching_exponent row_size))
+ ## If so, a brand-new root must be established, that is
+ ## 1-level taller.
+ (|> row
+ (set@ #root (|> (for {@.old
+ (: (Hierarchy ($ 0))
+ (new_hierarchy []))}
+ (new_hierarchy []))
+ (array.write! 0 (#Hierarchy (get@ #root row)))
+ (array.write! 1 (new_path (get@ #level row) (get@ #tail row)))))
+ (update@ #level level_up))
+ ## Otherwise, just push the current tail onto the root.
+ (|> row
+ (update@ #root (push_tail row_size (get@ #level row) (get@ #tail row)))))
+ ## Finally, update the size of the row and grow a new
+ ## tail with the new element as it's sole member.
+ (update@ #size inc)
+ (set@ #tail (new_tail val)))
+ )))
+
+(exception: incorrect_row_structure)
+
+(exception: #export [a] (index_out_of_bounds {row (Row a)} {index Nat})
+ (exception.report ["Size" (\ n.decimal encode (get@ #size row))]
+ ["Index" (\ n.decimal encode index)]))
+
+(exception: base_was_not_found)
+
+(def: #export (within_bounds? row idx)
+ (All [a] (-> (Row a) Nat Bit))
+ (n.< (get@ #size row) idx))
+
+(def: (base_for idx row)
+ (All [a] (-> Index (Row a) (Try (Base a))))
+ (if (within_bounds? row idx)
+ (if (n.>= (tail_off (get@ #size row)) idx)
+ (#try.Success (get@ #tail row))
+ (loop [level (get@ #level row)
+ hierarchy (get@ #root row)]
+ (case [(n.> branching_exponent level)
+ (array.read (branch_idx (i64.right_shift level idx)) hierarchy)]
+ [#1 (#.Some (#Hierarchy sub))]
+ (recur (level_down level) sub)
+
+ [#0 (#.Some (#Base base))]
+ (#try.Success base)
+
+ [_ #.None]
+ (exception.throw ..base_was_not_found [])
+
+ _
+ (exception.throw ..incorrect_row_structure []))))
+ (exception.throw ..index_out_of_bounds [row idx])))
+
+(def: #export (nth idx row)
+ (All [a] (-> Nat (Row a) (Try a)))
+ (do try.monad
+ [base (base_for idx row)]
+ (case (array.read (branch_idx idx) base)
+ (#.Some value)
+ (#try.Success value)
+
+ #.None
+ (exception.throw ..incorrect_row_structure []))))
+
+(def: #export (put idx val row)
+ (All [a] (-> Nat a (Row a) (Try (Row a))))
+ (let [row_size (get@ #size row)]
+ (if (within_bounds? row idx)
+ (#try.Success (if (n.>= (tail_off row_size) idx)
+ (update@ #tail (for {@.old
+ (: (-> (Base ($ 0)) (Base ($ 0)))
+ (|>> array.clone (array.write! (branch_idx idx) val)))}
+ (|>> array.clone (array.write! (branch_idx idx) val)))
+ row)
+ (update@ #root (put' (get@ #level row) idx val)
+ row)))
+ (exception.throw ..index_out_of_bounds [row idx]))))
+
+(def: #export (update idx f row)
+ (All [a] (-> Nat (-> a a) (Row a) (Try (Row a))))
+ (do try.monad
+ [val (..nth idx row)]
+ (..put idx (f val) row)))
+
+(def: #export (pop row)
+ (All [a] (-> (Row a) (Row a)))
+ (case (get@ #size row)
+ 0
+ empty
+
+ 1
+ empty
+
+ row_size
+ (if (|> row_size (n.- (tail_off row_size)) (n.> 1))
+ (let [old_tail (get@ #tail row)
+ new_tail_size (dec (array.size old_tail))]
+ (|> row
+ (update@ #size dec)
+ (set@ #tail (|> (array.new new_tail_size)
+ (array.copy! new_tail_size 0 old_tail 0)))))
+ (maybe.assume
+ (do maybe.monad
+ [new_tail (base_for (n.- 2 row_size) row)
+ #let [[level' root'] (let [init_level (get@ #level row)]
+ (loop [level init_level
+ root (maybe.default (new_hierarchy [])
+ (pop_tail row_size init_level (get@ #root row)))]
+ (if (n.> branching_exponent level)
+ (case [(array.read 1 root) (array.read 0 root)]
+ [#.None (#.Some (#Hierarchy sub_node))]
+ (recur (level_down level) sub_node)
+
+ ## [#.None (#.Some (#Base _))]
+ ## (undefined)
+
+ _
+ [level root])
+ [level root])))]]
+ (wrap (|> row
+ (update@ #size dec)
+ (set@ #level level')
+ (set@ #root root')
+ (set@ #tail new_tail))))))
+ ))
+
+(def: #export (to_list row)
+ (All [a] (-> (Row a) (List a)))
+ (list\compose (to_list' (#Hierarchy (get@ #root row)))
+ (to_list' (#Base (get@ #tail row)))))
+
+(def: #export from_list
+ (All [a] (-> (List a) (Row a)))
+ (list\fold ..add ..empty))
+
+(def: #export (member? a/Equivalence row val)
+ (All [a] (-> (Equivalence a) (Row a) a Bit))
+ (list.member? a/Equivalence (to_list row) val))
+
+(def: #export empty?
+ (All [a] (-> (Row a) Bit))
+ (|>> (get@ #size) (n.= 0)))
+
+(syntax: #export (row {elems (p.some s.any)})
+ {#.doc (doc "Row literals."
+ (row +10 +20 +30 +40))}
+ (wrap (list (` (..from_list (list (~+ elems)))))))
+
+(implementation: (node_equivalence Equivalence<a>)
+ (All [a] (-> (Equivalence a) (Equivalence (Node a))))
+
+ (def: (= v1 v2)
+ (case [v1 v2]
+ [(#Base b1) (#Base b2)]
+ (\ (array.equivalence Equivalence<a>) = b1 b2)
+
+ [(#Hierarchy h1) (#Hierarchy h2)]
+ (\ (array.equivalence (node_equivalence Equivalence<a>)) = h1 h2)
+
+ _
+ #0)))
+
+(implementation: #export (equivalence Equivalence<a>)
+ (All [a] (-> (Equivalence a) (Equivalence (Row a))))
+
+ (def: (= v1 v2)
+ (and (n.= (get@ #size v1) (get@ #size v2))
+ (let [(^open "node\.") (node_equivalence Equivalence<a>)]
+ (and (node\= (#Base (get@ #tail v1))
+ (#Base (get@ #tail v2)))
+ (node\= (#Hierarchy (get@ #root v1))
+ (#Hierarchy (get@ #root v2))))))))
+
+(implementation: node_fold
+ (Fold Node)
+
+ (def: (fold f init xs)
+ (case xs
+ (#Base base)
+ (array\fold f init base)
+
+ (#Hierarchy hierarchy)
+ (array\fold (function (_ node init') (fold f init' node))
+ init
+ hierarchy))))
+
+(implementation: #export fold
+ (Fold Row)
+
+ (def: (fold f init xs)
+ (let [(^open ".") node_fold]
+ (fold f
+ (fold f
+ init
+ (#Hierarchy (get@ #root xs)))
+ (#Base (get@ #tail xs))))))
+
+(implementation: #export monoid
+ (All [a] (Monoid (Row a)))
+
+ (def: identity ..empty)
+
+ (def: (compose xs ys)
+ (list\fold add xs (..to_list ys))))
+
+(implementation: node_functor
+ (Functor Node)
+
+ (def: (map f xs)
+ (case xs
+ (#Base base)
+ (#Base (array\map f base))
+
+ (#Hierarchy hierarchy)
+ (#Hierarchy (array\map (map f) hierarchy)))))
+
+(implementation: #export functor
+ (Functor Row)
+
+ (def: (map f xs)
+ {#level (get@ #level xs)
+ #size (get@ #size xs)
+ #root (|> xs (get@ #root) (array\map (\ node_functor map f)))
+ #tail (|> xs (get@ #tail) (array\map f))}))
+
+(implementation: #export apply
+ (Apply Row)
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (let [(^open ".") ..functor
+ (^open ".") ..fold
+ (^open ".") ..monoid
+ results (map (function (_ f) (map f fa))
+ ff)]
+ (fold compose identity results))))
+
+(implementation: #export monad
+ (Monad Row)
+
+ (def: &functor ..functor)
+
+ (def: wrap (|>> row))
+
+ (def: join
+ (let [(^open ".") ..fold
+ (^open ".") ..monoid]
+ (fold (function (_ post pre) (compose pre post)) identity))))
+
+(def: #export reverse
+ (All [a] (-> (Row a) (Row a)))
+ (|>> ..to_list list.reverse (list\fold add ..empty)))
+
+(template [<name> <array> <init> <op>]
+ [(def: #export <name>
+ (All [a]
+ (-> (Predicate a) (Row a) Bit))
+ (let [help (: (All [a]
+ (-> (Predicate a) (Node a) Bit))
+ (function (help predicate node)
+ (case node
+ (#Base base)
+ (<array> predicate base)
+
+ (#Hierarchy hierarchy)
+ (<array> (help predicate) hierarchy))))]
+ (function (<name> predicate row)
+ (let [(^slots [#root #tail]) row]
+ (<op> (help predicate (#Hierarchy root))
+ (help predicate (#Base tail)))))))]
+
+ [every? array.every? #1 and]
+ [any? array.any? #0 or]
+ )
diff --git a/stdlib/source/library/lux/data/collection/sequence.lux b/stdlib/source/library/lux/data/collection/sequence.lux
new file mode 100644
index 000000000..a7fa5cb75
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/sequence.lux
@@ -0,0 +1,151 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [functor (#+ Functor)]
+ [comonad (#+ CoMonad)]]
+ [control
+ ["//" continuation (#+ Cont)]
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [data
+ ["." bit]
+ [collection
+ ["." list ("#\." monad)]]]
+ [math
+ [number
+ ["n" nat]]]]])
+
+(type: #export (Sequence a)
+ {#.doc "An infinite sequence of values."}
+ (Cont [a (Sequence a)]))
+
+(def: #export (iterate f x)
+ {#.doc "Create a sequence by applying a function to a value, and to its result, on and on..."}
+ (All [a]
+ (-> (-> a a) a (Sequence a)))
+ (//.pending [x (iterate f (f x))]))
+
+(def: #export (repeat x)
+ {#.doc "Repeat a value forever."}
+ (All [a]
+ (-> a (Sequence a)))
+ (//.pending [x (repeat x)]))
+
+(def: #export (cycle [start next])
+ {#.doc (doc "Go over the elements of a list forever."
+ "The list should not be empty.")}
+ (All [a]
+ (-> [a (List a)] (Sequence a)))
+ (loop [head start
+ tail next]
+ (//.pending [head (case tail
+ #.Nil
+ (recur start next)
+
+ (#.Cons head' tail')
+ (recur head' tail'))])))
+
+(template [<name> <return>]
+ [(def: #export (<name> sequence)
+ (All [a] (-> (Sequence a) <return>))
+ (let [[head tail] (//.run sequence)]
+ <name>))]
+
+ [head a]
+ [tail (Sequence a)]
+ )
+
+(def: #export (nth idx sequence)
+ (All [a] (-> Nat (Sequence a) a))
+ (let [[head tail] (//.run sequence)]
+ (case idx
+ 0 head
+ _ (nth (dec idx) tail))))
+
+(template [<taker> <dropper> <splitter> <pred_type> <pred_test> <pred_step>]
+ [(def: #export (<taker> pred xs)
+ (All [a]
+ (-> <pred_type> (Sequence a) (List a)))
+ (let [[x xs'] (//.run xs)]
+ (if <pred_test>
+ (list& x (<taker> <pred_step> xs'))
+ (list))))
+
+ (def: #export (<dropper> pred xs)
+ (All [a]
+ (-> <pred_type> (Sequence a) (Sequence a)))
+ (let [[x xs'] (//.run xs)]
+ (if <pred_test>
+ (<dropper> <pred_step> xs')
+ xs)))
+
+ (def: #export (<splitter> pred xs)
+ (All [a]
+ (-> <pred_type> (Sequence a) [(List a) (Sequence a)]))
+ (let [[x xs'] (//.run xs)]
+ (if <pred_test>
+ (let [[tail next] (<splitter> <pred_step> xs')]
+ [(#.Cons [x tail]) next])
+ [(list) xs])))]
+
+ [take_while drop_while split_while (-> a Bit) (pred x) pred]
+ [take drop split Nat (n.> 0 pred) (dec pred)]
+ )
+
+(def: #export (unfold step init)
+ {#.doc "A stateful way of infinitely calculating the values of a sequence."}
+ (All [a b]
+ (-> (-> a [a b]) a (Sequence b)))
+ (let [[next x] (step init)]
+ (//.pending [x (unfold step next)])))
+
+(def: #export (filter predicate sequence)
+ (All [a] (-> (-> a Bit) (Sequence a) (Sequence a)))
+ (let [[head tail] (//.run sequence)]
+ (if (predicate head)
+ (//.pending [head (filter predicate tail)])
+ (filter predicate tail))))
+
+(def: #export (partition left? xs)
+ {#.doc (doc "Split a sequence in two based on a predicate."
+ "The left side contains all entries for which the predicate is #1."
+ "The right side contains all entries for which the predicate is #0.")}
+ (All [a] (-> (-> a Bit) (Sequence a) [(Sequence a) (Sequence a)]))
+ [(filter left? xs) (filter (bit.complement left?) xs)])
+
+(implementation: #export functor
+ (Functor Sequence)
+
+ (def: (map f fa)
+ (let [[head tail] (//.run fa)]
+ (//.pending [(f head) (map f tail)]))))
+
+(implementation: #export comonad
+ (CoMonad Sequence)
+
+ (def: &functor ..functor)
+
+ (def: unwrap head)
+
+ (def: (split wa)
+ (let [[head tail] (//.run wa)]
+ (//.pending [wa (split tail)]))))
+
+(syntax: #export (^sequence& {patterns (<code>.form (<>.many <code>.any))}
+ body
+ {branches (<>.some <code>.any)})
+ {#.doc (doc "Allows destructuring of sequences in pattern-matching expressions."
+ "Caveat emptor: Only use it for destructuring, and not for testing values within the sequences."
+ (let [(^sequence& x y z _tail) (some_sequence_func +1 +2 +3)]
+ (func x y z)))}
+ (with_gensyms [g!sequence]
+ (let [body+ (` (let [(~+ (list\join (list\map (function (_ pattern)
+ (list (` [(~ pattern) (~ g!sequence)])
+ (` ((~! //.run) (~ g!sequence)))))
+ patterns)))]
+ (~ body)))]
+ (wrap (list& g!sequence body+ branches)))))
diff --git a/stdlib/source/library/lux/data/collection/set.lux b/stdlib/source/library/lux/data/collection/set.lux
new file mode 100644
index 000000000..0ae6cee25
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/set.lux
@@ -0,0 +1,105 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]
+ [predicate (#+ Predicate)]
+ [monoid (#+ Monoid)]]
+ [data
+ [collection
+ ["." list ("#\." fold)]]]
+ [math
+ [number
+ ["n" nat]]]]]
+ ["." // #_
+ ["#" dictionary (#+ Dictionary)]])
+
+(type: #export (Set a)
+ (Dictionary a Any))
+
+(def: #export member_hash
+ (All [a] (-> (Set a) (Hash a)))
+ //.key_hash)
+
+(def: #export new
+ (All [a] (-> (Hash a) (Set a)))
+ //.new)
+
+(def: #export size
+ (All [a] (-> (Set a) Nat))
+ //.size)
+
+(def: #export (add elem set)
+ (All [a] (-> a (Set a) (Set a)))
+ (|> set (//.put elem [])))
+
+(def: #export remove
+ (All [a] (-> a (Set a) (Set a)))
+ //.remove)
+
+(def: #export member?
+ (All [a] (-> (Set a) a Bit))
+ //.key?)
+
+(def: #export to_list
+ (All [a] (-> (Set a) (List a)))
+ //.keys)
+
+(def: #export union
+ (All [a] (-> (Set a) (Set a) (Set a)))
+ //.merge)
+
+(def: #export (difference sub base)
+ (All [a] (-> (Set a) (Set a) (Set a)))
+ (list\fold ..remove base (..to_list sub)))
+
+(def: #export (intersection filter base)
+ (All [a] (-> (Set a) (Set a) (Set a)))
+ (//.select (//.keys filter)
+ base))
+
+(implementation: #export equivalence
+ (All [a] (Equivalence (Set a)))
+
+ (def: (= (^@ reference [hash _]) sample)
+ (and (n.= (..size reference)
+ (..size sample))
+ (list.every? (..member? reference)
+ (..to_list sample)))))
+
+(implementation: #export hash
+ (All [a] (Hash (Set a)))
+
+ (def: &equivalence ..equivalence)
+
+ (def: (hash set)
+ (|> set
+ ..to_list
+ (\ (list.hash (..member_hash set)) hash))))
+
+(implementation: #export (monoid hash)
+ (All [a] (-> (Hash a) (Monoid (Set a))))
+
+ (def: identity (..new hash))
+ (def: compose ..union))
+
+(def: #export empty?
+ (All [a] (-> (Set a) Bit))
+ (|>> ..size (n.= 0)))
+
+(def: #export (from_list hash elements)
+ (All [a] (-> (Hash a) (List a) (Set a)))
+ (list\fold ..add (..new hash) elements))
+
+(def: #export (sub? super sub)
+ (All [a] (-> (Set a) (Set a) Bit))
+ (list.every? (..member? super) (..to_list sub)))
+
+(def: #export (super? sub super)
+ (All [a] (-> (Set a) (Set a) Bit))
+ (..sub? super sub))
+
+(def: #export predicate
+ (All [a] (-> (Set a) (Predicate a)))
+ ..member?)
diff --git a/stdlib/source/library/lux/data/collection/set/multi.lux b/stdlib/source/library/lux/data/collection/set/multi.lux
new file mode 100644
index 000000000..efd266c18
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/set/multi.lux
@@ -0,0 +1,158 @@
+## https://en.wikipedia.org/wiki/Multiset
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]]
+ [control
+ ["." function]]
+ [math
+ [number
+ ["n" nat]]]
+ [type
+ [abstract (#+ abstract: :abstraction :representation ^:representation)]]]]
+ ["." //
+ [//
+ ["." list ("#\." fold monoid)]
+ ["." dictionary (#+ Dictionary)]
+ [//
+ ["." maybe]]]])
+
+(abstract: #export (Set a)
+ (Dictionary a Nat)
+
+ (def: #export new
+ (All [a] (-> (Hash a) (Set a)))
+ (|>> dictionary.new :abstraction))
+
+ (def: #export size
+ (All [a] (-> (Set a) Nat))
+ (|>> :representation dictionary.values (list\fold n.+ 0)))
+
+ (def: #export (add multiplicity elem set)
+ (All [a] (-> Nat a (Set a) (Set a)))
+ (case multiplicity
+ 0 set
+ _ (|> set
+ :representation
+ (dictionary.upsert elem 0 (n.+ multiplicity))
+ :abstraction)))
+
+ (def: #export (remove multiplicity elem set)
+ (All [a] (-> Nat a (Set a) (Set a)))
+ (case multiplicity
+ 0 set
+ _ (case (dictionary.get elem (:representation set))
+ (#.Some current)
+ (:abstraction
+ (if (n.> multiplicity current)
+ (dictionary.update elem (n.- multiplicity) (:representation set))
+ (dictionary.remove elem (:representation set))))
+
+ #.None
+ set)))
+
+ (def: #export (multiplicity set elem)
+ (All [a] (-> (Set a) a Nat))
+ (|> set :representation (dictionary.get elem) (maybe.default 0)))
+
+ (def: #export to_list
+ (All [a] (-> (Set a) (List a)))
+ (|>> :representation
+ dictionary.entries
+ (list\fold (function (_ [elem multiplicity] output)
+ (list\compose (list.repeat multiplicity elem) output))
+ #.Nil)))
+
+ (template [<name> <compose>]
+ [(def: #export (<name> parameter subject)
+ (All [a] (-> (Set a) (Set a) (Set a)))
+ (:abstraction (dictionary.merge_with <compose> (:representation parameter) (:representation subject))))]
+
+ [union n.max]
+ [sum n.+]
+ )
+
+ (def: #export (intersection parameter (^:representation subject))
+ (All [a] (-> (Set a) (Set a) (Set a)))
+ (list\fold (function (_ [elem multiplicity] output)
+ (..add (n.min (..multiplicity parameter elem)
+ multiplicity)
+ elem
+ output))
+ (..new (dictionary.key_hash subject))
+ (dictionary.entries subject)))
+
+ (def: #export (difference parameter subject)
+ (All [a] (-> (Set a) (Set a) (Set a)))
+ (|> parameter
+ :representation
+ dictionary.entries
+ (list\fold (function (_ [elem multiplicity] output)
+ (..remove multiplicity elem output))
+ subject)))
+
+ (def: #export (sub? reference subject)
+ (All [a] (-> (Set a) (Set a) Bit))
+ (|> subject
+ :representation
+ dictionary.entries
+ (list.every? (function (_ [elem multiplicity])
+ (|> elem
+ (..multiplicity reference)
+ (n.>= multiplicity))))))
+
+ (def: #export (support set)
+ (All [a] (-> (Set a) (//.Set a)))
+ (let [(^@ set [hash _]) (:representation set)]
+ (|> set
+ dictionary.keys
+ (//.from_list hash))))
+
+ (implementation: #export equivalence
+ (All [a] (Equivalence (Set a)))
+
+ (def: (= (^:representation reference) sample)
+ (and (n.= (dictionary.size reference)
+ (dictionary.size (:representation sample)))
+ (|> reference
+ dictionary.entries
+ (list.every? (function (_ [elem multiplicity])
+ (|> elem
+ (..multiplicity sample)
+ (n.= multiplicity))))))))
+
+ (implementation: #export hash
+ (All [a] (Hash (Set a)))
+
+ (def: &equivalence ..equivalence)
+
+ (def: (hash (^:representation set))
+ (let [[hash _] set]
+ (list\fold (function (_ [elem multiplicity] acc)
+ (|> elem (\ hash hash) (n.* multiplicity) (n.+ acc)))
+ 0
+ (dictionary.entries set)))))
+ )
+
+(def: #export (member? set elem)
+ (All [a] (-> (Set a) a Bit))
+ (|> elem (..multiplicity set) (n.> 0)))
+
+(def: #export empty?
+ (All [a] (-> (Set a) Bit))
+ (|>> ..size (n.= 0)))
+
+(def: #export (from_list hash subject)
+ (All [a] (-> (Hash a) (List a) (Set a)))
+ (list\fold (..add 1) (..new hash) subject))
+
+(def: #export (from_set subject)
+ (All [a] (-> (//.Set a) (Set a)))
+ (..from_list (//.member_hash subject)
+ (//.to_list subject)))
+
+(def: #export super?
+ (All [a] (-> (Set a) (Set a) Bit))
+ (function.flip sub?))
diff --git a/stdlib/source/library/lux/data/collection/set/ordered.lux b/stdlib/source/library/lux/data/collection/set/ordered.lux
new file mode 100644
index 000000000..b61bfb546
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/set/ordered.lux
@@ -0,0 +1,85 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]]
+ [data
+ [collection
+ ["." list ("#\." fold)]
+ [dictionary
+ ["/" ordered]]]]
+ [type
+ abstract]]])
+
+(abstract: #export (Set a)
+ (/.Dictionary a a)
+
+ (def: #export new
+ (All [a] (-> (Order a) (Set a)))
+ (|>> /.new :abstraction))
+
+ (def: #export (member? set elem)
+ (All [a] (-> (Set a) a Bit))
+ (/.key? (:representation set) elem))
+
+ (template [<type> <name> <alias>]
+ [(def: #export <name>
+ (All [a] (-> (Set a) <type>))
+ (|>> :representation <alias>))]
+
+ [(Maybe a) min /.min]
+ [(Maybe a) max /.max]
+ [Nat size /.size]
+ [Bit empty? /.empty?]
+ )
+
+ (def: #export (add elem set)
+ (All [a] (-> a (Set a) (Set a)))
+ (|> set :representation (/.put elem elem) :abstraction))
+
+ (def: #export (remove elem set)
+ (All [a] (-> a (Set a) (Set a)))
+ (|> set :representation (/.remove elem) :abstraction))
+
+ (def: #export to_list
+ (All [a] (-> (Set a) (List a)))
+ (|>> :representation /.keys))
+
+ (def: #export (from_list &order list)
+ (All [a] (-> (Order a) (List a) (Set a)))
+ (list\fold add (..new &order) list))
+
+ (def: #export (union left right)
+ (All [a] (-> (Set a) (Set a) (Set a)))
+ (list\fold ..add right (..to_list left)))
+
+ (def: #export (intersection left right)
+ (All [a] (-> (Set a) (Set a) (Set a)))
+ (|> (..to_list right)
+ (list.filter (..member? left))
+ (..from_list (get@ #/.&order (:representation right)))))
+
+ (def: #export (difference param subject)
+ (All [a] (-> (Set a) (Set a) (Set a)))
+ (|> (..to_list subject)
+ (list.filter (|>> (..member? param) not))
+ (..from_list (get@ #/.&order (:representation subject)))))
+
+ (implementation: #export equivalence
+ (All [a] (Equivalence (Set a)))
+
+ (def: (= reference sample)
+ (\ (list.equivalence (\ (:representation reference) &equivalence))
+ = (..to_list reference) (..to_list sample))))
+ )
+
+(def: #export (sub? super sub)
+ (All [a] (-> (Set a) (Set a) Bit))
+ (|> sub
+ ..to_list
+ (list.every? (..member? super))))
+
+(def: #export (super? sub super)
+ (All [a] (-> (Set a) (Set a) Bit))
+ (sub? super sub))
diff --git a/stdlib/source/library/lux/data/collection/stack.lux b/stdlib/source/library/lux/data/collection/stack.lux
new file mode 100644
index 000000000..c81240c29
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/stack.lux
@@ -0,0 +1,66 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [functor (#+ Functor)]]
+ [data
+ [collection
+ ["//" list]]]
+ [type
+ abstract]]])
+
+(abstract: #export (Stack a)
+ (List a)
+
+ (def: #export empty
+ Stack
+ (:abstraction (list)))
+
+ (def: #export size
+ (All [a] (-> (Stack a) Nat))
+ (|>> :representation //.size))
+
+ (def: #export empty?
+ (All [a] (-> (Stack a) Bit))
+ (|>> :representation //.empty?))
+
+ (def: #export (peek stack)
+ (All [a] (-> (Stack a) (Maybe a)))
+ (case (:representation stack)
+ #.Nil
+ #.None
+
+ (#.Cons value _)
+ (#.Some value)))
+
+ (def: #export (pop stack)
+ (All [a] (-> (Stack a) (Maybe [a (Stack a)])))
+ (case (:representation stack)
+ #.Nil
+ #.None
+
+ (#.Cons top stack')
+ (#.Some [top (:abstraction stack')])))
+
+ (def: #export (push value stack)
+ (All [a] (-> a (Stack a) (Stack a)))
+ (:abstraction (#.Cons value (:representation stack))))
+
+ (implementation: #export (equivalence super)
+ (All [a]
+ (-> (Equivalence a)
+ (Equivalence (Stack a))))
+
+ (def: (= reference subject)
+ (\ (//.equivalence super) = (:representation reference) (:representation subject))))
+
+ (implementation: #export functor
+ (Functor Stack)
+
+ (def: (map f value)
+ (|> value
+ :representation
+ (\ //.functor map f)
+ :abstraction)))
+ )
diff --git a/stdlib/source/library/lux/data/collection/tree.lux b/stdlib/source/library/lux/data/collection/tree.lux
new file mode 100644
index 000000000..f6b3746e7
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/tree.lux
@@ -0,0 +1,85 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [functor (#+ Functor)]
+ [equivalence (#+ Equivalence)]
+ [fold (#+ Fold)]
+ [monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<c>" code (#+ Parser)]]]
+ [data
+ [collection
+ ["." list ("#\." monad fold)]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]]]])
+
+(type: #export (Tree a)
+ {#value a
+ #children (List (Tree a))})
+
+(def: #export (flatten tree)
+ (All [a] (-> (Tree a) (List a)))
+ (#.Cons (get@ #value tree)
+ (list\join (list\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})
+
+(type: #rec Tree-Code
+ [Code (List Tree-Code)])
+
+(def: tree^
+ (Parser Tree-Code)
+ (|> (|>> <>.some
+ <c>.record
+ (<>.and <c>.any))
+ <>.rec
+ <>.some
+ <c>.record
+ (<>.default (list))
+ (<>.and <c>.any)))
+
+(syntax: #export (tree {root tree^})
+ {#.doc (doc "Tree literals."
+ (: (Tree Nat)
+ (tree 10
+ {20 {}
+ 30 {}
+ 40 {}})))}
+ (wrap (list (` (~ (loop [[value children] root]
+ (` {#value (~ value)
+ #children (list (~+ (list\map recur children)))})))))))
+
+(implementation: #export (equivalence super)
+ (All [a] (-> (Equivalence a) (Equivalence (Tree a))))
+
+ (def: (= tx ty)
+ (and (\ super = (get@ #value tx) (get@ #value ty))
+ (\ (list.equivalence (equivalence super)) = (get@ #children tx) (get@ #children ty)))))
+
+(implementation: #export functor
+ (Functor Tree)
+
+ (def: (map f fa)
+ {#value (f (get@ #value fa))
+ #children (list\map (map f)
+ (get@ #children fa))}))
+
+(implementation: #export fold
+ (Fold Tree)
+
+ (def: (fold f init tree)
+ (list\fold (function (_ tree' init') (fold f init' tree'))
+ (f (get@ #value tree)
+ init)
+ (get@ #children tree))))
diff --git a/stdlib/source/library/lux/data/collection/tree/finger.lux b/stdlib/source/library/lux/data/collection/tree/finger.lux
new file mode 100644
index 000000000..a3b1be634
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/tree/finger.lux
@@ -0,0 +1,108 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [predicate (#+ Predicate)]
+ ["." monoid (#+ Monoid)]]
+ [data
+ [collection
+ ["." list ("#\." monoid)]]]
+ [type
+ [abstract (#+ abstract: :abstraction :representation)]]]])
+
+(abstract: #export (Tree @ t v)
+ {#monoid (Monoid t)
+ #tag t
+ #root (| v
+ [(Tree @ t v) (Tree @ t v)])}
+
+ (interface: #export (Builder @ t)
+ (: (All [v]
+ (-> t v (Tree @ t v)))
+ leaf)
+ (: (All [v]
+ (-> (Tree @ t v)
+ (Tree @ t v)
+ (Tree @ t v)))
+ branch))
+
+ (template [<name> <tag> <output>]
+ [(def: #export <name>
+ (All [@ t v] (-> (Tree @ t v) <output>))
+ (|>> :representation (get@ <tag>)))]
+
+ [tag #tag t]
+ [root #root (Either v [(Tree @ t v) (Tree @ t v)])]
+ )
+
+ (implementation: #export (builder monoid)
+ (All [t] (Ex [@] (-> (Monoid t) (Builder @ t))))
+
+ (def: (leaf tag value)
+ (:abstraction
+ {#monoid monoid
+ #tag tag
+ #root (0 #0 value)}))
+
+ (def: (branch left right)
+ (:abstraction
+ {#monoid monoid
+ #tag (\ monoid compose (..tag left) (..tag right))
+ #root (0 #1 [left right])})))
+
+ (def: #export (value tree)
+ (All [@ t v] (-> (Tree @ t v) v))
+ (case (get@ #root (:representation tree))
+ (0 #0 value)
+ value
+
+ (0 #1 [left right])
+ (value left)))
+
+ (def: #export (tags tree)
+ (All [@ t v] (-> (Tree @ t v) (List t)))
+ (case (get@ #root (:representation tree))
+ (0 #0 value)
+ (list (get@ #tag (:representation tree)))
+
+ (0 #1 [left right])
+ (list\compose (tags left)
+ (tags right))))
+
+ (def: #export (values tree)
+ (All [@ t v] (-> (Tree @ t v) (List v)))
+ (case (get@ #root (:representation tree))
+ (0 #0 value)
+ (list value)
+
+ (0 #1 [left right])
+ (list\compose (values left)
+ (values right))))
+
+ (def: #export (search predicate tree)
+ (All [@ t v] (-> (Predicate t) (Tree @ t v) (Maybe v)))
+ (let [[monoid tag root] (:representation tree)]
+ (if (predicate tag)
+ (let [(^open "tag//.") monoid]
+ (loop [_tag tag//identity
+ _node root]
+ (case _node
+ (0 #0 value)
+ (#.Some value)
+
+ (0 #1 [left right])
+ (let [shifted_tag (tag//compose _tag (..tag left))]
+ (if (predicate shifted_tag)
+ (recur _tag (get@ #root (:representation left)))
+ (recur shifted_tag (get@ #root (:representation right))))))))
+ #.None)))
+ )
+
+(def: #export (found? predicate tree)
+ (All [@ t v] (-> (Predicate t) (Tree @ t v) Bit))
+ (case (..search predicate tree)
+ (#.Some _)
+ true
+
+ #.None
+ false))
diff --git a/stdlib/source/library/lux/data/collection/tree/zipper.lux b/stdlib/source/library/lux/data/collection/tree/zipper.lux
new file mode 100644
index 000000000..bb36e3e38
--- /dev/null
+++ b/stdlib/source/library/lux/data/collection/tree/zipper.lux
@@ -0,0 +1,318 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ [abstract
+ [functor (#+ Functor)]
+ [comonad (#+ CoMonad)]
+ [monad (#+ do)]
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." product]
+ ["." maybe ("#\." monad)]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold monoid)]]]]]
+ ["." // (#+ Tree) ("#\." functor)])
+
+(type: (Family Zipper a)
+ {#parent (Zipper a)
+ #lefts (List (Tree a))
+ #rights (List (Tree a))})
+
+(type: #export (Zipper a)
+ {#.doc "Tree zippers, for easy navigation and editing of trees."}
+ {#family (Maybe (Family Zipper a))
+ #node (Tree a)})
+
+(implementation: #export (equivalence super)
+ (All [a]
+ (-> (Equivalence a)
+ (Equivalence (Zipper a))))
+
+ (def: (= reference sample)
+ (let [== ($_ product.equivalence
+ (maybe.equivalence
+ ($_ product.equivalence
+ =
+ (list.equivalence (//.equivalence super))
+ (list.equivalence (//.equivalence super))))
+ (//.equivalence super))]
+ (== reference sample))))
+
+(def: #export (zip tree)
+ (All [a] (-> (Tree a) (Zipper a)))
+ {#family #.None
+ #node tree})
+
+(def: #export unzip
+ (All [a] (-> (Zipper a) (Tree a)))
+ (get@ #node))
+
+(def: #export value
+ (All [a] (-> (Zipper a) a))
+ (get@ [#node #//.value]))
+
+(def: #export set
+ (All [a] (-> a (Zipper a) (Zipper a)))
+ (set@ [#node #//.value]))
+
+(def: #export update
+ (All [a] (-> (-> a a) (Zipper a) (Zipper a)))
+ (update@ [#node #//.value]))
+
+(def: children
+ (All [a] (-> (Zipper a) (List (Tree a))))
+ (get@ [#node #//.children]))
+
+(def: #export leaf?
+ (All [a] (-> (Zipper a) Bit))
+ (|>> ..children list.empty?))
+
+(def: #export branch?
+ (All [a] (-> (Zipper a) Bit))
+ (|>> ..leaf? not))
+
+(def: #export (start? zipper)
+ (All [a] (-> (Zipper a) Bit))
+ (case (get@ #family zipper)
+ #.None
+ true
+
+ _
+ false))
+
+(def: #export (down zipper)
+ (All [a] (-> (Zipper a) (Maybe (Zipper a))))
+ (case (..children zipper)
+ #.Nil
+ #.None
+
+ (#.Cons head tail)
+ (#.Some {#family (#.Some {#parent (set@ [#node #//.children] (list) zipper)
+ #lefts #.Nil
+ #rights tail})
+ #node head})))
+
+(def: #export (up zipper)
+ (All [a] (-> (Zipper a) (Maybe (Zipper a))))
+ (do maybe.monad
+ [family (get@ #family zipper)]
+ (wrap (let [(^slots [#parent #lefts #rights]) family]
+ (for {@.old
+ (update@ #node (: (-> (Tree ($ 0)) (Tree ($ 0)))
+ (set@ #//.children (list\compose (list.reverse lefts)
+ (#.Cons (get@ #node zipper)
+ rights))))
+ parent)}
+ (set@ [#node #//.children]
+ (list\compose (list.reverse lefts)
+ (#.Cons (get@ #node zipper)
+ rights))
+ parent))))))
+
+(template [<one> <all> <side> <op-side>]
+ [(def: #export (<one> zipper)
+ (All [a] (-> (Zipper a) (Maybe (Zipper a))))
+ (case (get@ #family zipper)
+ (#.Some family)
+ (case (get@ <side> family)
+ (#.Cons next side')
+ (#.Some (for {@.old
+ {#family (#.Some (|> family
+ (set@ <side> side')
+ (update@ <op-side> (|>> (#.Cons (get@ #node zipper))))))
+ #node next}}
+ (let [move (: (All [a] (-> (List (Tree a)) (Zipper a) (Family Zipper a) (Family Zipper a)))
+ (function (_ side' zipper)
+ (|>> (set@ <side> side')
+ (update@ <op-side> (|>> (#.Cons (get@ #node zipper)))))))]
+ {#family (#.Some (move side' zipper family))
+ #node next})))
+
+ #.Nil
+ #.None)
+
+ #.None
+ #.None))
+
+ (def: #export (<all> zipper)
+ (All [a] (-> (Zipper a) (Maybe (Zipper a))))
+ (case (get@ #family zipper)
+ #.None
+ #.None
+
+ (#.Some family)
+ (case (list.reverse (get@ <side> family))
+ #.Nil
+ #.None
+
+ (#.Cons last prevs)
+ (#.Some (for {@.old {#family (#.Some (|> family
+ (set@ <side> #.Nil)
+ (update@ <op-side> (|>> (#.Cons (get@ #node zipper))
+ (list\compose prevs)))))
+ #node last}}
+ (let [move (: (All [a] (-> (List (Tree a)) (Zipper a) (Family Zipper a) (Family Zipper a)))
+ (function (_ prevs zipper)
+ (|>> (set@ <side> #.Nil)
+ (update@ <op-side> (|>> (#.Cons (get@ #node zipper))
+ (list\compose prevs))))))]
+ {#family (#.Some (move prevs zipper family))
+ #node last}))))))]
+
+ [right rightmost #rights #lefts]
+ [left leftmost #lefts #rights]
+ )
+
+(def: #export (next zipper)
+ (All [a] (-> (Zipper a) (Maybe (Zipper a))))
+ (case (..down zipper)
+ (#.Some forward)
+ (#.Some forward)
+
+ #.None
+ (loop [@ zipper]
+ (case (..right @)
+ (#.Some forward)
+ (#.Some forward)
+
+ #.None
+ (do maybe.monad
+ [@ (..up @)]
+ (recur @))))))
+
+(def: (bottom zipper)
+ (All [a] (-> (Zipper a) (Zipper a)))
+ (case (..right zipper)
+ (#.Some forward)
+ (bottom forward)
+
+ #.None
+ (case (..down zipper)
+ (#.Some forward)
+ (bottom forward)
+
+ #.None
+ zipper)))
+
+(def: #export (previous zipper)
+ (All [a] (-> (Zipper a) (Maybe (Zipper a))))
+ (case (..left zipper)
+ #.None
+ (..up zipper)
+
+ (#.Some backward)
+ (#.Some (case (..down backward)
+ (#.Some then)
+ (..bottom then)
+
+ #.None
+ backward))))
+
+(template [<name> <move>]
+ [(def: #export (<name> zipper)
+ (All [a] (-> (Zipper a) (Maybe (Zipper a))))
+ (case (<move> zipper)
+ #.None
+ #.None
+
+ (#.Some @)
+ (loop [@ @]
+ (case (<move> @)
+ #.None
+ (#.Some @)
+
+ (#.Some @)
+ (recur @)))))]
+
+ [end ..next]
+ [start ..previous]
+ )
+
+(def: #export (end? zipper)
+ (All [a] (-> (Zipper a) Bit))
+ (case (..end zipper)
+ #.None
+ true
+
+ (#.Some _)
+ false))
+
+(def: #export (interpose value zipper)
+ (All [a] (-> a (Zipper a) (Zipper a)))
+ (update@ [#node #//.children]
+ (|>> (//.branch value) list)
+ zipper))
+
+(def: #export (adopt value zipper)
+ (All [a] (-> a (Zipper a) (Zipper a)))
+ (update@ [#node #//.children]
+ (|>> (#.Cons (//.leaf value)))
+ zipper))
+
+(def: #export (remove zipper)
+ (All [a] (-> (Zipper a) (Maybe (Zipper a))))
+ (do maybe.monad
+ [family (get@ #family zipper)]
+ (case (get@ #lefts family)
+ #.Nil
+ (wrap (set@ [#node #//.children]
+ (get@ #rights family)
+ (get@ #parent family)))
+
+ (#.Cons next side)
+ (wrap (|> zipper
+ (set@ #family (|> family
+ (set@ #lefts side)
+ #.Some))
+ (set@ #node next))))))
+
+(template [<name> <side>]
+ [(def: #export (<name> value zipper)
+ (All [a] (-> a (Zipper a) (Maybe (Zipper a))))
+ (case (get@ #family zipper)
+ #.None
+ #.None
+
+ (#.Some family)
+ (#.Some (set@ #family
+ (#.Some (update@ <side> (|>> (#.Cons (//.leaf value))) family))
+ zipper))))]
+
+ [insert-left #lefts]
+ [insert-right #rights]
+ )
+
+(implementation: #export functor
+ (Functor Zipper)
+
+ (def: (map f (^slots [#family #node]))
+ {#family (maybe\map (function (_ (^slots [#parent #lefts #rights]))
+ {#parent (map f parent)
+ #lefts (list\map (//\map f) lefts)
+ #rights (list\map (//\map f) rights)})
+ family)
+ #node (//\map f node)}))
+
+(implementation: #export comonad
+ (CoMonad Zipper)
+
+ (def: &functor ..functor)
+
+ (def: unwrap (get@ [#node #//.value]))
+
+ (def: (split (^slots [#family #node]))
+ (let [tree-splitter (: (All [a] (-> (Tree a) (Tree (Zipper a))))
+ (function (tree-splitter tree)
+ {#//.value (..zip tree)
+ #//.children (|> tree
+ (get@ #//.children)
+ (list\map tree-splitter))}))]
+ {#family (maybe\map (function (_ (^slots [#parent #lefts #rights]))
+ {#parent (split parent)
+ #lefts (list\map tree-splitter lefts)
+ #rights (list\map tree-splitter rights)})
+ family)
+ #node (tree-splitter node)})))
diff --git a/stdlib/source/library/lux/data/color.lux b/stdlib/source/library/lux/data/color.lux
new file mode 100644
index 000000000..72847c91d
--- /dev/null
+++ b/stdlib/source/library/lux/data/color.lux
@@ -0,0 +1,425 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monoid (#+ Monoid)]
+ ["." hash (#+ Hash)]]
+ [data
+ [collection
+ ["." list ("#\." functor)]]]
+ ["." math
+ [number
+ ["n" nat]
+ ["f" frac]
+ ["." int]
+ ["." rev ("#\." interval)]
+ ["." i64]]]
+ [type
+ abstract]]])
+
+(def: rgb 256)
+(def: top (dec rgb))
+
+(def: rgb_factor (|> top .int int.frac))
+
+(def: down
+ (-> Nat Frac)
+ (|>> .int int.frac (f./ rgb_factor)))
+
+(def: up
+ (-> Frac Nat)
+ (|>> (f.* rgb_factor) f.int .nat))
+
+(type: #export RGB
+ {#red Nat
+ #green Nat
+ #blue Nat})
+
+(type: #export HSL
+ [Frac Frac Frac])
+
+(type: #export CMYK
+ {#cyan Frac
+ #magenta Frac
+ #yellow Frac
+ #key Frac})
+
+(type: #export HSB
+ [Frac Frac Frac])
+
+(abstract: #export Color
+ RGB
+
+ (def: #export (from_rgb [red green blue])
+ (-> RGB Color)
+ (:abstraction {#red (n.% ..rgb red)
+ #green (n.% ..rgb green)
+ #blue (n.% ..rgb blue)}))
+
+ (def: #export to_rgb
+ (-> Color RGB)
+ (|>> :representation))
+
+ (implementation: #export equivalence
+ (Equivalence Color)
+
+ (def: (= reference sample)
+ (let [[rR gR bR] (:representation reference)
+ [rS gS bS] (:representation sample)]
+ (and (n.= rR rS)
+ (n.= gR gS)
+ (n.= bR bS)))))
+
+ (implementation: #export hash
+ (Hash Color)
+
+ (def: &equivalence ..equivalence)
+
+ (def: (hash value)
+ (let [[r g b] (:representation value)]
+ ($_ i64.or
+ (i64.left_shift 16 r)
+ (i64.left_shift 8 g)
+ b))))
+
+ (def: #export black
+ (..from_rgb {#red 0
+ #green 0
+ #blue 0}))
+
+ (def: #export white
+ (..from_rgb {#red ..top
+ #green ..top
+ #blue ..top}))
+
+ (implementation: #export addition
+ (Monoid Color)
+
+ (def: identity ..black)
+
+ (def: (compose left right)
+ (let [[lR lG lB] (:representation left)
+ [rR rG rB] (:representation right)]
+ (:abstraction {#red (n.max lR rR)
+ #green (n.max lG rG)
+ #blue (n.max lB rB)}))))
+
+ (def: (complement' value)
+ (-> Nat Nat)
+ (|> ..top (n.- value)))
+
+ (def: #export (complement color)
+ (-> Color Color)
+ (let [[red green blue] (:representation color)]
+ (:abstraction {#red (complement' red)
+ #green (complement' green)
+ #blue (complement' blue)})))
+
+ (implementation: #export subtraction
+ (Monoid Color)
+
+ (def: identity ..white)
+
+ (def: (compose left right)
+ (let [[lR lG lB] (:representation (..complement left))
+ [rR rG rB] (:representation right)]
+ (:abstraction {#red (n.min lR rR)
+ #green (n.min lG rG)
+ #blue (n.min lB rB)}))))
+ )
+
+(def: #export (to_hsl color)
+ (-> Color HSL)
+ (let [[red green blue] (to_rgb color)
+ red (..down red)
+ green (..down green)
+ blue (..down blue)
+ max ($_ f.max red green blue)
+ min ($_ f.min red green blue)
+ luminance (|> (f.+ max min) (f./ +2.0))]
+ (if (f.= max min)
+ ## Achromatic
+ [+0.0
+ +0.0
+ luminance]
+ ## Chromatic
+ (let [diff (|> max (f.- min))
+ saturation (|> diff
+ (f./ (if (f.> +0.5 luminance)
+ (|> +2.0 (f.- max) (f.- min))
+ (|> max (f.+ min)))))
+ hue' (cond (f.= red max)
+ (|> green (f.- blue) (f./ diff)
+ (f.+ (if (f.< blue green) +6.0 +0.0)))
+
+ (f.= green max)
+ (|> blue (f.- red) (f./ diff)
+ (f.+ +2.0))
+
+ ## (f.= blue max)
+ (|> red (f.- green) (f./ diff)
+ (f.+ +4.0)))]
+ [(|> hue' (f./ +6.0))
+ saturation
+ luminance]))))
+
+(def: (hue_to_rgb p q t)
+ (-> Frac Frac Frac Frac)
+ (let [t (cond (f.< +0.0 t) (f.+ +1.0 t)
+ (f.> +1.0 t) (f.- +1.0 t)
+ ## else
+ t)
+ f2/3 (f./ +3.0 +2.0)]
+ (cond (f.< (f./ +6.0 +1.0) t)
+ (|> q (f.- p) (f.* +6.0) (f.* t) (f.+ p))
+
+ (f.< (f./ +2.0 +1.0) t)
+ q
+
+ (f.< f2/3 t)
+ (|> q (f.- p) (f.* (|> f2/3 (f.- t))) (f.* +6.0) (f.+ p))
+
+ ## else
+ p)))
+
+(def: #export (from_hsl [hue saturation luminance])
+ (-> HSL Color)
+ (if (f.= +0.0 saturation)
+ ## Achromatic
+ (let [intensity (..up luminance)]
+ (from_rgb {#red intensity
+ #green intensity
+ #blue intensity}))
+ ## Chromatic
+ (let [q (if (f.< +0.5 luminance)
+ (|> saturation (f.+ +1.0) (f.* luminance))
+ (|> luminance (f.+ saturation) (f.- (f.* saturation luminance))))
+ p (|> luminance (f.* +2.0) (f.- q))
+ third (|> +1.0 (f./ +3.0))]
+ (from_rgb {#red (..up (|> hue (f.+ third) (hue_to_rgb p q)))
+ #green (..up (|> hue (hue_to_rgb p q)))
+ #blue (..up (|> hue (f.- third) (hue_to_rgb p q)))}))))
+
+(def: #export (to_hsb color)
+ (-> Color HSB)
+ (let [[red green blue] (to_rgb color)
+ red (..down red)
+ green (..down green)
+ blue (..down blue)
+ max ($_ f.max red green blue)
+ min ($_ f.min red green blue)
+ brightness max
+ diff (|> max (f.- min))
+ saturation (if (f.= +0.0 max)
+ +0.0
+ (|> diff (f./ max)))]
+ (if (f.= max min)
+ ## Achromatic
+ [+0.0 saturation brightness]
+ ## Chromatic
+ (let [hue (cond (f.= red max)
+ (|> green (f.- blue) (f./ diff)
+ (f.+ (if (f.< blue green) +6.0 +0.0)))
+
+ (f.= green max)
+ (|> blue (f.- red) (f./ diff)
+ (f.+ +2.0))
+
+ ## (f.= blue max)
+ (|> red (f.- green) (f./ diff)
+ (f.+ +4.0)))]
+ [(|> hue (f./ +6.0))
+ saturation
+ brightness]))))
+
+(def: #export (from_hsb [hue saturation brightness])
+ (-> HSB Color)
+ (let [hue (|> hue (f.* +6.0))
+ i (math.floor hue)
+ f (|> hue (f.- i))
+ p (|> +1.0 (f.- saturation) (f.* brightness))
+ q (|> +1.0 (f.- (f.* f saturation)) (f.* brightness))
+ t (|> +1.0 (f.- (|> +1.0 (f.- f) (f.* saturation))) (f.* brightness))
+ v brightness
+ mod (|> i (f.% +6.0) f.int .nat)
+ red (case mod 0 v 1 q 2 p 3 p 4 t 5 v _ (undefined))
+ green (case mod 0 t 1 v 2 v 3 q 4 p 5 p _ (undefined))
+ blue (case mod 0 p 1 p 2 t 3 v 4 v 5 q _ (undefined))]
+ (from_rgb {#red (..up red)
+ #green (..up green)
+ #blue (..up blue)})))
+
+(def: #export (to_cmyk color)
+ (-> Color CMYK)
+ (let [[red green blue] (to_rgb color)
+ red (..down red)
+ green (..down green)
+ blue (..down blue)
+ key (|> +1.0 (f.- ($_ f.max red green blue)))
+ f (if (f.< +1.0 key)
+ (|> +1.0 (f./ (|> +1.0 (f.- key))))
+ +0.0)
+ cyan (|> +1.0 (f.- red) (f.- key) (f.* f))
+ magenta (|> +1.0 (f.- green) (f.- key) (f.* f))
+ yellow (|> +1.0 (f.- blue) (f.- key) (f.* f))]
+ {#cyan cyan
+ #magenta magenta
+ #yellow yellow
+ #key key}))
+
+(def: #export (from_cmyk [cyan magenta yellow key])
+ (-> CMYK Color)
+ (if (f.= +1.0 key)
+ (from_rgb {#red 0
+ #green 0
+ #blue 0})
+ (let [red (|> (|> +1.0 (f.- cyan))
+ (f.* (|> +1.0 (f.- key))))
+ green (|> (|> +1.0 (f.- magenta))
+ (f.* (|> +1.0 (f.- key))))
+ blue (|> (|> +1.0 (f.- yellow))
+ (f.* (|> +1.0 (f.- key))))]
+ (from_rgb {#red (..up red)
+ #green (..up green)
+ #blue (..up blue)}))))
+
+(def: (normalize ratio)
+ (-> Frac Frac)
+ (cond (f.> +1.0 ratio)
+ (f.% +1.0 ratio)
+
+ (f.< +0.0 ratio)
+ (|> ratio (f.% +1.0) (f.+ +1.0))
+
+ ## else
+ ratio))
+
+(def: #export (interpolate ratio end start)
+ (-> Frac Color Color Color)
+ (let [dS (..normalize ratio)
+ dE (|> +1.0 (f.- dS))
+ interpolate' (: (-> Nat Nat Nat)
+ (function (_ end start)
+ (|> (|> start .int int.frac (f.* dS))
+ (f.+ (|> end .int int.frac (f.* dE)))
+ f.int
+ .nat)))
+ [redS greenS blueS] (to_rgb start)
+ [redE greenE blueE] (to_rgb end)]
+ (from_rgb {#red (interpolate' redE redS)
+ #green (interpolate' greenE greenS)
+ #blue (interpolate' blueE blueS)})))
+
+(template [<name> <target>]
+ [(def: #export (<name> ratio color)
+ (-> Frac Color Color)
+ (..interpolate ratio <target> color))]
+
+ [darker black]
+ [brighter white]
+ )
+
+(template [<name> <op>]
+ [(def: #export (<name> ratio color)
+ (-> Frac Color Color)
+ (let [[hue saturation luminance] (to_hsl color)]
+ (from_hsl [hue
+ (|> saturation
+ (f.* (|> +1.0 (<op> (..normalize ratio))))
+ (f.min +1.0))
+ luminance])))]
+
+ [saturate f.+]
+ [de_saturate f.-]
+ )
+
+(def: #export (gray_scale color)
+ (-> Color Color)
+ (let [[_ _ luminance] (to_hsl color)]
+ (from_hsl [+0.0
+ +0.0
+ luminance])))
+
+(template [<name> <1> <2>]
+ [(def: #export (<name> color)
+ (-> Color [Color Color Color])
+ (let [[hue saturation luminance] (to_hsl color)]
+ [color
+ (from_hsl [(|> hue (f.+ <1>) ..normalize)
+ saturation
+ luminance])
+ (from_hsl [(|> hue (f.+ <2>) ..normalize)
+ saturation
+ luminance])]))]
+
+ [triad (|> +1.0 (f./ +3.0)) (|> +2.0 (f./ +3.0))]
+ [clash (|> +1.0 (f./ +4.0)) (|> +3.0 (f./ +4.0))]
+ [split_complement (|> +1.0 (f./ +5.0)) (|> +3.0 (f./ +5.0))]
+ )
+
+(template [<name> <1> <2> <3>]
+ [(def: #export (<name> color)
+ (-> Color [Color Color Color Color])
+ (let [[hue saturation luminance] (to_hsb color)]
+ [color
+ (from_hsb [(|> hue (f.+ <1>) ..normalize)
+ saturation
+ luminance])
+ (from_hsb [(|> hue (f.+ <2>) ..normalize)
+ saturation
+ luminance])
+ (from_hsb [(|> hue (f.+ <3>) ..normalize)
+ saturation
+ luminance])]))]
+
+ [square (|> +1.0 (f./ +4.0)) (|> +2.0 (f./ +4.0)) (|> +3.0 (f./ +4.0))]
+ [tetradic (|> +2.0 (f./ +12.0)) (|> +6.0 (f./ +12.0)) (|> +8.0 (f./ +12.0))]
+ )
+
+(type: #export Spread
+ Frac)
+
+(type: #export Palette
+ (-> Spread Nat Color (List Color)))
+
+(def: #export (analogous spread variations color)
+ (-> Spread Nat Color (List Color))
+ (let [[hue saturation brightness] (to_hsb color)
+ spread (..normalize spread)]
+ (list\map (function (_ idx)
+ (from_hsb [(|> idx inc .int int.frac (f.* spread) (f.+ hue) ..normalize)
+ saturation
+ brightness]))
+ (list.indices variations))))
+
+(def: #export (monochromatic spread variations color)
+ (-> Spread Nat Color (List Color))
+ (let [[hue saturation brightness] (to_hsb color)
+ spread (..normalize spread)]
+ (|> (list.indices variations)
+ (list\map (|>> inc .int int.frac
+ (f.* spread)
+ (f.+ brightness)
+ ..normalize
+ [hue saturation]
+ from_hsb)))))
+
+(type: #export Alpha
+ Rev)
+
+(def: #export transparent
+ Alpha
+ rev\bottom)
+
+(def: #export translucent
+ Alpha
+ .5)
+
+(def: #export opaque
+ Alpha
+ rev\top)
+
+(type: #export Pigment
+ {#color Color
+ #alpha Alpha})
diff --git a/stdlib/source/library/lux/data/color/named.lux b/stdlib/source/library/lux/data/color/named.lux
new file mode 100644
index 000000000..a9a9ab4ab
--- /dev/null
+++ b/stdlib/source/library/lux/data/color/named.lux
@@ -0,0 +1,156 @@
+(.module:
+ [library
+ [lux #*
+ [math
+ [number (#+ hex)]]]]
+ ["." // (#+ Color)])
+
+(template [<red> <green> <blue> <name>]
+ [(def: #export <name>
+ Color
+ (//.from_rgb {#//.red (hex <red>)
+ #//.green (hex <green>)
+ #//.blue (hex <blue>)}))]
+
+ ["F0" "F8" "FF" alice_blue]
+ ["FA" "EB" "D7" antique_white]
+ ["00" "FF" "FF" aqua]
+ ["7F" "FF" "D4" aquamarine]
+ ["F0" "FF" "FF" azure]
+ ["F5" "F5" "DC" beige]
+ ["FF" "E4" "C4" bisque]
+ ["00" "00" "00" black]
+ ["FF" "EB" "CD" blanched_almond]
+ ["00" "00" "FF" blue]
+ ["8A" "2B" "E2" blue_violet]
+ ["A5" "2A" "2A" brown]
+ ["DE" "B8" "87" burly_wood]
+ ["5F" "9E" "A0" cadet_blue]
+ ["7F" "FF" "00" chartreuse]
+ ["D2" "69" "1E" chocolate]
+ ["FF" "7F" "50" coral]
+ ["64" "95" "ED" cornflower_blue]
+ ["FF" "F8" "DC" cornsilk]
+ ["DC" "14" "3C" crimson]
+ ["00" "FF" "FF" cyan]
+ ["00" "00" "8B" dark_blue]
+ ["00" "8B" "8B" dark_cyan]
+ ["B8" "86" "0B" dark_goldenrod]
+ ["A9" "A9" "A9" dark_gray]
+ ["00" "64" "00" dark_green]
+ ["BD" "B7" "6B" dark_khaki]
+ ["8B" "00" "8B" dark_magenta]
+ ["55" "6B" "2F" dark_olive_green]
+ ["FF" "8C" "00" dark_orange]
+ ["99" "32" "CC" dark_orchid]
+ ["8B" "00" "00" dark_red]
+ ["E9" "96" "7A" dark_salmon]
+ ["8F" "BC" "8F" dark_sea_green]
+ ["48" "3D" "8B" dark_slate_blue]
+ ["2F" "4F" "4F" dark_slate_gray]
+ ["00" "CE" "D1" dark_turquoise]
+ ["94" "00" "D3" dark_violet]
+ ["FF" "14" "93" deep_pink]
+ ["00" "BF" "FF" deep_sky_blue]
+ ["69" "69" "69" dim_gray]
+ ["1E" "90" "FF" dodger_blue]
+ ["B2" "22" "22" fire_brick]
+ ["FF" "FA" "F0" floral_white]
+ ["22" "8B" "22" forest_green]
+ ["FF" "00" "FF" fuchsia]
+ ["DC" "DC" "DC" gainsboro]
+ ["F8" "F8" "FF" ghost_white]
+ ["FF" "D7" "00" gold]
+ ["DA" "A5" "20" goldenrod]
+ ["80" "80" "80" gray]
+ ["00" "80" "00" green]
+ ["AD" "FF" "2F" green_yellow]
+ ["F0" "FF" "F0" honey_dew]
+ ["FF" "69" "B4" hot_pink]
+ ["CD" "5C" "5C" indian_red]
+ ["4B" "00" "82" indigo]
+ ["FF" "FF" "F0" ivory]
+ ["F0" "E6" "8C" khaki]
+ ["E6" "E6" "FA" lavender]
+ ["FF" "F0" "F5" lavender_blush]
+ ["7C" "FC" "00" lawn_green]
+ ["FF" "FA" "CD" lemon_chiffon]
+ ["AD" "D8" "E6" light_blue]
+ ["F0" "80" "80" light_coral]
+ ["E0" "FF" "FF" light_cyan]
+ ["FA" "FA" "D2" light_goldenrod_yellow]
+ ["D3" "D3" "D3" light_gray]
+ ["90" "EE" "90" light_green]
+ ["FF" "B6" "C1" light_pink]
+ ["FF" "A0" "7A" light_salmon]
+ ["20" "B2" "AA" light_sea_green]
+ ["87" "CE" "FA" light_sky_blue]
+ ["77" "88" "99" light_slate_gray]
+ ["B0" "C4" "DE" light_steel_blue]
+ ["FF" "FF" "E0" light_yellow]
+ ["00" "FF" "00" lime]
+ ["32" "CD" "32" lime_green]
+ ["FA" "F0" "E6" linen]
+ ["FF" "00" "FF" magenta]
+ ["80" "00" "00" maroon]
+ ["66" "CD" "AA" medium_aquamarine]
+ ["00" "00" "CD" medium_blue]
+ ["BA" "55" "D3" medium_orchid]
+ ["93" "70" "DB" medium_purple]
+ ["3C" "B3" "71" medium_sea_green]
+ ["7B" "68" "EE" medium_slate_blue]
+ ["00" "FA" "9A" medium_spring_green]
+ ["48" "D1" "CC" medium_turquoise]
+ ["C7" "15" "85" medium_violet_red]
+ ["19" "19" "70" midnight_blue]
+ ["F5" "FF" "FA" mint_cream]
+ ["FF" "E4" "E1" misty_rose]
+ ["FF" "E4" "B5" moccasin]
+ ["FF" "DE" "AD" navajo_white]
+ ["00" "00" "80" navy]
+ ["FD" "F5" "E6" old_lace]
+ ["80" "80" "00" olive]
+ ["6B" "8E" "23" olive_drab]
+ ["FF" "A5" "00" orange]
+ ["FF" "45" "00" orange_red]
+ ["DA" "70" "D6" orchid]
+ ["EE" "E8" "AA" pale_goldenrod]
+ ["98" "FB" "98" pale_green]
+ ["AF" "EE" "EE" pale_turquoise]
+ ["DB" "70" "93" pale_violet_red]
+ ["FF" "EF" "D5" papaya_whip]
+ ["FF" "DA" "B9" peach_puff]
+ ["CD" "85" "3F" peru]
+ ["FF" "C0" "CB" pink]
+ ["DD" "A0" "DD" plum]
+ ["B0" "E0" "E6" powder_blue]
+ ["80" "00" "80" purple]
+ ["66" "33" "99" rebecca_purple]
+ ["FF" "00" "00" red]
+ ["BC" "8F" "8F" rosy_brown]
+ ["41" "69" "E1" royal_blue]
+ ["8B" "45" "13" saddle_brown]
+ ["FA" "80" "72" salmon]
+ ["F4" "A4" "60" sandy_brown]
+ ["2E" "8B" "57" sea_green]
+ ["FF" "F5" "EE" sea_shell]
+ ["A0" "52" "2D" sienna]
+ ["C0" "C0" "C0" silver]
+ ["87" "CE" "EB" sky_blue]
+ ["6A" "5A" "CD" slate_blue]
+ ["70" "80" "90" slate_gray]
+ ["FF" "FA" "FA" snow]
+ ["00" "FF" "7F" spring_green]
+ ["46" "82" "B4" steel_blue]
+ ["D2" "B4" "8C" tan]
+ ["00" "80" "80" teal]
+ ["D8" "BF" "D8" thistle]
+ ["FF" "63" "47" tomato]
+ ["40" "E0" "D0" turquoise]
+ ["EE" "82" "EE" violet]
+ ["F5" "DE" "B3" wheat]
+ ["FF" "FF" "FF" white]
+ ["F5" "F5" "F5" white_smoke]
+ ["FF" "FF" "00" yellow]
+ ["9A" "CD" "32" yellow_green]
+ )
diff --git a/stdlib/source/library/lux/data/format/binary.lux b/stdlib/source/library/lux/data/format/binary.lux
new file mode 100644
index 000000000..7103f7d9d
--- /dev/null
+++ b/stdlib/source/library/lux/data/format/binary.lux
@@ -0,0 +1,292 @@
+(.module:
+ [library
+ [lux (#- and or nat int rev list type)
+ [type (#+ :share)]
+ [abstract
+ [monoid (#+ Monoid)]
+ [monad (#+ Monad do)]
+ [equivalence (#+ Equivalence)]]
+ [control
+ [pipe (#+ case>)]
+ ["." function]
+ ["." try (#+ Try)]
+ ["<>" parser ("#\." monad)
+ ["/" binary (#+ Offset Size Parser)]]]
+ [data
+ ["." product]
+ ["." binary (#+ Binary)]
+ [text
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." list]
+ ["." row (#+ Row) ("#\." functor)]
+ ["." set (#+ Set)]]]
+ [math
+ [number
+ ["." i64]
+ ["n" nat]
+ ["." frac]]]]])
+
+(def: mask
+ (-> Size (I64 Any))
+ (|>> (n.* i64.bits_per_byte) i64.mask))
+
+(type: #export Mutation
+ (-> [Offset Binary] [Offset Binary]))
+
+(type: #export Specification
+ [Size Mutation])
+
+(def: #export no_op
+ Specification
+ [0 function.identity])
+
+(def: #export (instance [size mutation])
+ (-> Specification Binary)
+ (|> size binary.create [0] mutation product.right))
+
+(implementation: #export monoid
+ (Monoid Specification)
+
+ (def: identity
+ ..no_op)
+
+ (def: (compose [sizeL mutL] [sizeR mutR])
+ [(n.+ sizeL sizeR)
+ (|>> mutL mutR)]))
+
+(type: #export (Writer a)
+ (-> a Specification))
+
+(def: #export (run writer value)
+ (All [a] (-> (Writer a) a Binary))
+ (..instance (writer value)))
+
+(template [<name> <size> <write>]
+ [(def: #export <name>
+ (Writer (I64 Any))
+ (function (_ value)
+ [<size>
+ (function (_ [offset binary])
+ [(n.+ <size> offset)
+ (|> binary
+ (<write> offset value)
+ try.assume)])]))]
+
+ [bits/8 /.size/8 binary.write/8]
+ [bits/16 /.size/16 binary.write/16]
+ [bits/32 /.size/32 binary.write/32]
+ [bits/64 /.size/64 binary.write/64]
+ )
+
+(def: #export (or left right)
+ (All [l r] (-> (Writer l) (Writer r) (Writer (| l r))))
+ (function (_ altV)
+ (case altV
+ (^template [<number> <tag> <writer>]
+ [(<tag> caseV)
+ (let [[caseS caseT] (<writer> caseV)]
+ [(.inc caseS)
+ (function (_ [offset binary])
+ (|> binary
+ (binary.write/8 offset <number>)
+ try.assume
+ [(.inc offset)]
+ caseT))])])
+ ([0 #.Left left]
+ [1 #.Right right])
+ )))
+
+(def: #export (and pre post)
+ (All [a b] (-> (Writer a) (Writer b) (Writer [a b])))
+ (function (_ [preV postV])
+ (\ ..monoid compose (pre preV) (post postV))))
+
+(def: #export (rec body)
+ (All [a] (-> (-> (Writer a) (Writer a)) (Writer a)))
+ (function (recur value)
+ (body recur value)))
+
+(def: #export any
+ (Writer Any)
+ (function.constant ..no_op))
+
+(def: #export bit
+ (Writer Bit)
+ (|>> (case> #0 0 #1 1) ..bits/8))
+
+(template [<name> <type>]
+ [(def: #export <name> (Writer <type>) ..bits/64)]
+
+ [nat Nat]
+ [int Int]
+ [rev Rev]
+ )
+
+(def: #export frac
+ (Writer Frac)
+ (|>> frac.to_bits ..bits/64))
+
+(def: #export (segment size)
+ (-> Nat (Writer Binary))
+ (function (_ value)
+ [size
+ (function (_ [offset binary])
+ [(n.+ size offset)
+ (try.assume
+ (binary.copy (n.min size (binary.size value))
+ 0
+ value
+ offset
+ binary))])]))
+
+(template [<name> <bits> <size> <write>]
+ [(def: #export <name>
+ (Writer Binary)
+ (let [mask (..mask <size>)]
+ (function (_ value)
+ (let [size (|> value binary.size (i64.and mask))
+ size' (n.+ <size> size)]
+ [size'
+ (function (_ [offset binary])
+ [(n.+ size' offset)
+ (try.assume
+ (do try.monad
+ [_ (<write> offset size binary)]
+ (binary.copy size 0 value (n.+ <size> offset) binary)))])]))))]
+
+ [binary/8 ..bits/8 /.size/8 binary.write/8]
+ [binary/16 ..bits/16 /.size/16 binary.write/16]
+ [binary/32 ..bits/32 /.size/32 binary.write/32]
+ [binary/64 ..bits/64 /.size/64 binary.write/64]
+ )
+
+(template [<name> <binary>]
+ [(def: #export <name>
+ (Writer Text)
+ (|>> (\ utf8.codec encode) <binary>))]
+
+ [utf8/8 ..binary/8]
+ [utf8/16 ..binary/16]
+ [utf8/32 ..binary/32]
+ [utf8/64 ..binary/64]
+ )
+
+(def: #export text ..utf8/64)
+
+(template [<name> <size> <write>]
+ [(def: #export (<name> valueW)
+ (All [v] (-> (Writer v) (Writer (Row v))))
+ (function (_ value)
+ (let [original_count (row.size value)
+ capped_count (i64.and (..mask <size>)
+ original_count)
+ value (if (n.= original_count capped_count)
+ value
+ (|> value row.to_list (list.take capped_count) row.from_list))
+ (^open "specification\.") ..monoid
+ [size mutation] (|> value
+ (row\map valueW)
+ (\ row.fold fold
+ (function (_ post pre)
+ (specification\compose pre post))
+ specification\identity))]
+ [(n.+ <size> size)
+ (function (_ [offset binary])
+ (try.assume
+ (do try.monad
+ [_ (<write> offset capped_count binary)]
+ (wrap (mutation [(n.+ <size> offset) binary])))))])))]
+
+ [row/8 /.size/8 binary.write/8]
+ [row/16 /.size/16 binary.write/16]
+ [row/32 /.size/32 binary.write/32]
+ [row/64 /.size/64 binary.write/64]
+ )
+
+(def: #export maybe
+ (All [a] (-> (Writer a) (Writer (Maybe a))))
+ (..or ..any))
+
+(def: #export (list value)
+ (All [a] (-> (Writer a) (Writer (List a))))
+ (..rec
+ (|>> (..and value)
+ (..or ..any))))
+
+(def: #export (set value)
+ (All [a] (-> (Writer a) (Writer (Set a))))
+ (|>> set.to_list (..list value)))
+
+(def: #export name
+ (Writer Name)
+ (..and ..text ..text))
+
+(def: #export type
+ (Writer Type)
+ (..rec
+ (function (_ recur)
+ (let [pair (..and recur recur)
+ indexed ..nat
+ quantified (..and (..list recur) recur)]
+ (function (_ altV)
+ (case altV
+ (^template [<number> <tag> <writer>]
+ [(<tag> caseV)
+ (let [[caseS caseT] (<writer> caseV)]
+ [(.inc caseS)
+ (function (_ [offset binary])
+ (|> binary
+ (binary.write/8 offset <number>)
+ try.assume
+ [(.inc offset)]
+ caseT))])])
+ ([0 #.Primitive (..and ..text (..list recur))]
+ [1 #.Sum pair]
+ [2 #.Product pair]
+ [3 #.Function pair]
+ [4 #.Parameter indexed]
+ [5 #.Var indexed]
+ [6 #.Ex indexed]
+ [7 #.UnivQ quantified]
+ [8 #.ExQ quantified]
+ [9 #.Apply pair]
+ [10 #.Named (..and ..name recur)])
+ ))))))
+
+(def: #export location
+ (Writer Location)
+ ($_ ..and ..text ..nat ..nat))
+
+(def: #export code
+ (Writer Code)
+ (..rec
+ (function (_ recur)
+ (let [sequence (..list recur)]
+ (..and ..location
+ (function (_ altV)
+ (case altV
+ (^template [<number> <tag> <writer>]
+ [(<tag> caseV)
+ (let [[caseS caseT] (<writer> caseV)]
+ [(.inc caseS)
+ (function (_ [offset binary])
+ (|> binary
+ (binary.write/8 offset <number>)
+ try.assume
+ [(.inc offset)]
+ caseT))])])
+ ([0 #.Bit ..bit]
+ [1 #.Nat ..nat]
+ [2 #.Int ..int]
+ [3 #.Rev ..rev]
+ [4 #.Frac ..frac]
+ [5 #.Text ..text]
+ [6 #.Identifier ..name]
+ [7 #.Tag ..name]
+ [8 #.Form sequence]
+ [9 #.Tuple sequence]
+ [10 #.Record (..list (..and recur recur))])
+ )))))))
diff --git a/stdlib/source/library/lux/data/format/css.lux b/stdlib/source/library/lux/data/format/css.lux
new file mode 100644
index 000000000..041feace9
--- /dev/null
+++ b/stdlib/source/library/lux/data/format/css.lux
@@ -0,0 +1,126 @@
+(.module:
+ [library
+ [lux (#- and)
+ [data
+ ["." maybe]
+ [number
+ ["." nat]]
+ ["." text
+ ["%" format (#+ format)]
+ ["." encoding (#+ Encoding)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [type
+ abstract]
+ [world
+ [net (#+ URL)]]]]
+ ["." / #_
+ ["#." selector (#+ Selector Combinator)]
+ ["#." value (#+ Value Animation Percentage)]
+ ["#." font (#+ Font)]
+ ["#." style (#+ Style)]
+ ["#." query (#+ Query)]])
+
+(abstract: #export Common Any)
+(abstract: #export Special Any)
+
+(abstract: #export (CSS brand)
+ Text
+
+ (def: #export css (-> (CSS Any) Text) (|>> :representation))
+
+ (def: #export empty (CSS Common) (:abstraction ""))
+
+ (def: #export (rule selector style)
+ (-> (Selector Any) Style (CSS Common))
+ (:abstraction (format (/selector.selector selector) "{" (/style.inline style) "}")))
+
+ (def: #export char-set
+ (-> Encoding (CSS Special))
+ (|>> encoding.name
+ %.text
+ (text.enclose ["@charset " ";"])
+ :abstraction))
+
+ (def: #export (font font)
+ (-> Font (CSS Special))
+ (let [with-unicode (case (get@ #/font.unicode-range font)
+ (#.Some unicode-range)
+ (let [unicode-range' (format "U+" (\ nat.hex encode (get@ #/font.start unicode-range))
+ "-" (\ nat.hex encode (get@ #/font.end unicode-range)))]
+ (list ["unicode-range" unicode-range']))
+
+ #.None
+ (list))]
+ (|> (list& ["font-family" (get@ #/font.family font)]
+ ["src" (format "url(" (get@ #/font.source font) ")")]
+ ["font-stretch" (|> font (get@ #/font.stretch) (maybe.default /value.normal-stretch) /value.value)]
+ ["font-style" (|> font (get@ #/font.style) (maybe.default /value.normal-style) /value.value)]
+ ["font-weight" (|> font (get@ #/font.weight) (maybe.default /value.normal-weight) /value.value)]
+ with-unicode)
+ (list\map (function (_ [property value])
+ (format property ": " value ";")))
+ (text.join-with /style.separator)
+ (text.enclose ["{" "}"])
+ (format "@font-face")
+ :abstraction)))
+
+ (def: #export (import url query)
+ (-> URL (Maybe Query) (CSS Special))
+ (:abstraction (format (format "@import url(" (%.text url) ")")
+ (case query
+ (#.Some query)
+ (format " " (/query.query query))
+
+ #.None
+ "")
+ ";")))
+
+ (def: css-separator text.new-line)
+
+ (type: #export Frame
+ {#when Percentage
+ #what Style})
+
+ (def: #export (key-frames animation frames)
+ (-> (Value Animation) (List Frame) (CSS Special))
+ (:abstraction (format "@keyframes " (/value.value animation) " {"
+ (|> frames
+ (list\map (function (_ frame)
+ (format (/value.percentage (get@ #when frame)) " {"
+ (/style.inline (get@ #what frame))
+ "}")))
+ (text.join-with ..css-separator))
+ "}")))
+
+ (template: (!compose <pre> <post>)
+ (:abstraction (format (:representation <pre>) ..css-separator
+ (:representation <post>))))
+
+ (def: #export (and pre post)
+ (-> (CSS Any) (CSS Any) (CSS Any))
+ (!compose pre post))
+
+ (def: #export (alter combinator selector css)
+ (-> Combinator (Selector Any) (CSS Common) (CSS Common))
+ (|> css
+ :representation
+ (text.split-all-with ..css-separator)
+ (list\map (|>> (format (/selector.selector (|> selector (combinator (/selector.tag "")))))))
+ (text.join-with ..css-separator)
+ :abstraction))
+
+ (def: #export (dependent combinator selector style inner)
+ (-> Combinator (Selector Any) Style (CSS Common) (CSS Common))
+ (!compose (..rule selector style)
+ (..alter combinator selector inner)))
+
+ (template [<name> <combinator>]
+ [(def: #export <name>
+ (-> (Selector Any) Style (CSS Common) (CSS Common))
+ (..dependent <combinator>))]
+
+ [with-descendants /selector.in]
+ [with-children /selector.sub]
+ )
+ )
diff --git a/stdlib/source/library/lux/data/format/css/font.lux b/stdlib/source/library/lux/data/format/css/font.lux
new file mode 100644
index 000000000..c153ec0b8
--- /dev/null
+++ b/stdlib/source/library/lux/data/format/css/font.lux
@@ -0,0 +1,26 @@
+(.module:
+ [library
+ [lux #*
+ [type
+ abstract]
+ [control
+ [parser
+ ["s" code]]]
+ ["." macro
+ [syntax (#+ syntax:)]]
+ [world
+ [net (#+ URL)]]]]
+ ["." // #_
+ ["#." value (#+ Value Font-Stretch Font-Style Font-Weight)]])
+
+(type: #export Unicode-Range
+ {#start Nat
+ #end Nat})
+
+(type: #export Font
+ {#family Text
+ #source URL
+ #stretch (Maybe (Value Font-Stretch))
+ #style (Maybe (Value Font-Style))
+ #weight (Maybe (Value Font-Weight))
+ #unicode-range (Maybe Unicode-Range)})
diff --git a/stdlib/source/library/lux/data/format/css/property.lux b/stdlib/source/library/lux/data/format/css/property.lux
new file mode 100644
index 000000000..273ab75b8
--- /dev/null
+++ b/stdlib/source/library/lux/data/format/css/property.lux
@@ -0,0 +1,503 @@
+(.module:
+ [library
+ [lux (#- All Cursor)
+ [control
+ [parser
+ ["s" code]]]
+ [type
+ abstract]
+ [macro
+ ["." template]
+ ["." code]
+ [syntax (#+ syntax:)]]]]
+ [//
+ [value (#+ All
+ Number
+ Length Thickness Time
+ Color
+ Location Fit
+ Slice
+ Alignment Animation-Direction
+ Animation Animation-Fill
+ Column-Fill Column-Span
+ Iteration Count
+ Play
+ Timing Visibility Attachment
+ Blend Span Image
+ Angle Repeat Border
+ Collapse Box-Decoration-Break Caption
+ Float Clear
+ Content
+ Cursor
+ Shadow Clip
+ Text-Direction
+ Display Empty
+ Filter
+ Flex-Direction Flex-Wrap
+ Font Font-Kerning Font-Size Font-Variant
+ Grid Grid-Content Grid-Flow Grid-Span Grid-Template
+ Hanging-Punctuation Hyphens Isolation
+ List-Style-Position List-Style-Type
+ Overflow Page-Break Pointer-Events
+ Position
+ Quotes
+ Resize Scroll-Behavior Table-Layout
+ Text-Align Text-Align-Last
+ Text-Decoration-Line Text-Decoration-Style
+ Text-Justification Text-Overflow Text-Transform
+ Transform Transform-Origin Transform-Style
+ Transition
+ Bidi User-Select
+ Vertical-Align
+ White-Space Word-Break Word-Wrap Writing-Mode
+ Z-Index)]])
+
+(syntax: (text-identifier {identifier s.text})
+ (wrap (list (code.local-identifier identifier))))
+
+(abstract: #export (Property brand)
+ Text
+
+ (def: #export name
+ (-> (Property Any) Text)
+ (|>> :representation))
+
+ (template [<brand> <alias>+ <property>+]
+ [(`` (template [<alias> <property>]
+ [(def: #export <alias>
+ (Property <brand>)
+ (:abstraction <property>))]
+
+ (~~ (template.splice <alias>+))))
+
+ (with-expansions [<rows> (template.splice <property>+)]
+ (template [<property>]
+ [(`` (def: #export (~~ (text-identifier <property>))
+ (Property <brand>)
+ (:abstraction <property>)))]
+
+ <rows>))]
+
+ [All
+ []
+ [["all"]]]
+
+ [Length
+ []
+ [["border-image-outset"]
+ ["border-image-width"]
+ ["bottom"]
+ ["column-gap"]
+ ["column-width"]
+ ["flex-basis"]
+ ["grid-column-gap"]
+ ["grid-gap"]
+ ["grid-row-gap"]
+ ["height"]
+ ["left"]
+ ["letter-spacing"]
+ ["line-height"]
+ ["margin"]
+ ["margin-bottom"]
+ ["margin-left"]
+ ["margin-right"]
+ ["margin-top"]
+ ["max-height"]
+ ["max-width"]
+ ["min-height"]
+ ["min-width"]
+ ["outline-offset"]
+ ["padding"]
+ ["padding-bottom"]
+ ["padding-left"]
+ ["padding-right"]
+ ["padding-top"]
+ ["perspective"]
+ ["right"]
+ ["text-indent"]
+ ["top"]
+ ["width"]
+ ["word-spacing"]]]
+
+ [Time
+ []
+ [["animation-delay"]
+ ["animation-duration"]
+ ["transition-delay"]
+ ["transition-duration"]]]
+
+ [Slice
+ []
+ [["border-image-slice"]]]
+
+ [Color
+ [[text-color "color"]]
+ [["background-color"]
+ ["border-color"]
+ ["border-bottom-color"]
+ ["border-left-color"]
+ ["border-right-color"]
+ ["border-top-color"]
+ ["caret-color"]
+ ["column-rule-color"]
+ ["outline-color"]
+ ["text-decoration-color"]]]
+
+ [Alignment
+ []
+ [["align-content"]
+ ["align-items"]
+ ["align-self"]
+ ["justify-content"]]]
+
+ [Animation
+ []
+ [["animation-name"]]]
+
+ [Animation-Direction
+ []
+ [["animation-direction"]]]
+
+ [Animation-Fill
+ []
+ [["animation-fill-mode"]]]
+
+ [Column-Fill
+ []
+ [["column-fill"]]]
+
+ [Column-Span
+ []
+ [["column-span"]]]
+
+ [Iteration
+ []
+ [["animation-iteration-count"]]]
+
+ [Count
+ []
+ [["column-count"]
+ ["flex-grow"]
+ ["flex-shrink"]
+ ["order"]
+ ["tab-size"]]]
+
+ [Play
+ []
+ [["animation-play-state"]]]
+
+ [Timing
+ []
+ [["animation-timing-function"]
+ ["transition-timing-function"]]]
+
+ [Visibility
+ []
+ [["backface-visibility"]
+ ["visibility"]]]
+
+ [Attachment
+ []
+ [["background-attachment"]]]
+
+ [Blend
+ []
+ [["background-blend-mode"]
+ ["mix-blend-mode"]]]
+
+ [Image
+ []
+ [["background-image"]
+ ["border-image-source"]
+ ["list-style-image"]]]
+
+ [Span
+ []
+ [["background-clip"]
+ ["background-origin"]
+ ["box-sizing"]]]
+
+ [Location
+ []
+ [["background-position"]
+ ["object-position"]
+ ["perspective-origin"]]]
+
+ [Repeat
+ []
+ [["background-repeat"]
+ ["border-image-repeat"]]]
+
+ [Fit
+ []
+ [["background-size"]
+ ["border-radius"]
+ ["border-bottom-left-radius"]
+ ["border-bottom-right-radius"]
+ ["border-top-left-radius"]
+ ["border-top-right-radius"]
+ ["border-spacing"]
+ ["object-fit"]]]
+
+ [Border
+ []
+ [["border-style"]
+ ["border-bottom-style"]
+ ["border-left-style"]
+ ["border-right-style"]
+ ["border-top-style"]
+ ["column-rule-style"]
+ ["outline-style"]]]
+
+ [Thickness
+ []
+ [["border-width"]
+ ["border-bottom-width"]
+ ["border-left-width"]
+ ["border-right-width"]
+ ["border-top-width"]
+ ["column-rule-width"]
+ ["outline-width"]]]
+
+ [Collapse
+ []
+ [["border-collapse"]]]
+
+ [Box-Decoration-Break
+ []
+ [["box-decoration-break"]]]
+
+ [Caption
+ []
+ [["caption-side"]]]
+
+ [Clear
+ []
+ [["clear"]]]
+
+ [Shadow
+ []
+ [["box-shadow"]
+ ["text-shadow"]]]
+
+ [Clip
+ []
+ [["clip"]]]
+
+ [Content
+ []
+ [["counter-reset"]
+ ["counter-increment"]]]
+
+ [Cursor
+ []
+ [["cursor"]]]
+
+ [Text-Direction
+ [[text-direction "direction"]]
+ []]
+
+ [Display
+ []
+ [["display"]]]
+
+ [Empty
+ []
+ [["empty-cells"]]]
+
+ [Filter
+ []
+ [["filter"]]]
+
+ [Flex-Direction
+ []
+ [["flex-direction"]]]
+
+ [Flex-Wrap
+ []
+ [["flex-wrap"]]]
+
+ [Float
+ []
+ [["float"]]]
+
+ [Font
+ []
+ [["font-family"]]]
+
+ [Font-Kerning
+ []
+ [["font-kerning"]]]
+
+ [Font-Size
+ []
+ [["font-size"]]]
+
+ [Number
+ []
+ [["font-size-adjust"]
+ ["opacity"]]]
+
+ [Font-Variant
+ []
+ [["font-variant"]]]
+
+ [Grid
+ []
+ [["grid-area"]]]
+
+ [Grid-Content
+ []
+ [["grid-auto-columns"]
+ ["grid-auto-rows"]
+ ["grid-template-columns"]
+ ["grid-template-rows"]]]
+
+ [Grid-Flow
+ []
+ [["grid-auto-flow"]]]
+
+ [Grid-Span
+ []
+ [["grid-column-end"]
+ ["grid-column-start"]
+ ["grid-row-end"]
+ ["grid-row-start"]]]
+
+ [Grid-Template
+ []
+ [["grid-template-areas"]]]
+
+ [Hanging-Punctuation
+ []
+ [["hanging-punctuation"]]]
+
+ [Hyphens
+ []
+ [["hyphens"]]]
+
+ [Isolation
+ []
+ [["isolation"]]]
+
+ [List-Style-Position
+ []
+ [["list-style-position"]]]
+
+ [List-Style-Type
+ []
+ [["list-style-type"]]]
+
+ [Overflow
+ []
+ [["overflow"]
+ ["overflow-x"]
+ ["overflow-y"]]]
+
+ [Page-Break
+ []
+ [["page-break-after"]
+ ["page-break-before"]
+ ["page-break-inside"]]]
+
+ [Pointer-Events
+ []
+ [["pointer-events"]]]
+
+ [Position
+ []
+ [["position"]]]
+
+ [Quotes
+ []
+ [["quotes"]]]
+
+ [Resize
+ []
+ [["resize"]]]
+
+ [Scroll-Behavior
+ []
+ [["scroll-behavior"]]]
+
+ [Table-Layout
+ []
+ [["table-layout"]]]
+
+ [Text-Align
+ []
+ [["text-align"]]]
+
+ [Text-Align-Last
+ []
+ [["text-align-last"]]]
+
+ [Text-Decoration-Line
+ []
+ [["text-decoration-line"]]]
+
+ [Text-Decoration-Style
+ []
+ [["text-decoration-style"]]]
+
+ [Text-Justification
+ []
+ [["text-justify"]]]
+
+ [Text-Overflow
+ []
+ [["text-overflow"]]]
+
+ [Text-Transform
+ []
+ [["text-transform"]]]
+
+ [Transform
+ []
+ [["transform"]]]
+
+ [Transform-Origin
+ []
+ [["transform-origin"]]]
+
+ [Transform-Style
+ []
+ [["transform-style"]]]
+
+ [Transition
+ []
+ [["transition-property"]]]
+
+ [Bidi
+ []
+ [["unicode-bidi"]]]
+
+ [User-Select
+ []
+ [["user-select"]]]
+
+ [Vertical-Align
+ []
+ [["vertical-align"]]]
+
+ [White-Space
+ []
+ [["white-space"]]]
+
+ [Word-Break
+ []
+ [["word-break"]]]
+
+ [Word-Wrap
+ []
+ [["word-wrap"]]]
+
+ [Writing-Mode
+ []
+ [["writing-mode"]]]
+
+ [Z-Index
+ []
+ [["z-index"]]]
+ )
+ )
diff --git a/stdlib/source/library/lux/data/format/css/query.lux b/stdlib/source/library/lux/data/format/css/query.lux
new file mode 100644
index 000000000..3e40701eb
--- /dev/null
+++ b/stdlib/source/library/lux/data/format/css/query.lux
@@ -0,0 +1,135 @@
+(.module:
+ [library
+ [lux (#- and or not)
+ [control
+ [parser
+ ["s" code]]]
+ [data
+ [text
+ ["%" format (#+ format)]]]
+ [macro
+ ["." template]
+ ["." code]
+ [syntax (#+ syntax:)]]
+ [type
+ abstract]]]
+ ["." // #_
+ ["#." value (#+ Value Length Count Resolution Ratio
+ Orientation Scan Boolean Update
+ Block-Overflow Inline-Overflow
+ Display-Mode Color-Gamut Inverted-Colors
+ Pointer Hover
+ Light Scripting Motion Color-Scheme)]])
+
+(syntax: (text-identifier {identifier s.text})
+ (wrap (list (code.local-identifier identifier))))
+
+(abstract: #export Media
+ Text
+
+ (def: #export media
+ (-> Media Text)
+ (|>> :representation))
+
+ (template [<media>]
+ [(`` (def: #export (~~ (text-identifier <media>))
+ Media
+ (:abstraction <media>)))]
+
+ ["all"]
+ ["print"]
+ ["screen"]
+ ["speech"]
+ ))
+
+(abstract: #export Feature
+ Text
+
+ (def: #export feature
+ (-> Feature Text)
+ (|>> :representation))
+
+ (template [<feature> <brand>]
+ [(`` (def: #export ((~~ (text-identifier <feature>)) input)
+ (-> (Value <brand>) Feature)
+ (:abstraction (format "(" <feature> ": " (//value.value input) ")"))))]
+
+ ["min-color" Count]
+ ["color" Count]
+ ["max-color" Count]
+
+ ["min-color-index" Count]
+ ["color-index" Count]
+ ["max-color-index" Count]
+
+ ["min-monochrome" Count]
+ ["monochrome" Count]
+ ["max-monochrome" Count]
+
+ ["min-height" Length]
+ ["height" Length]
+ ["max-height" Length]
+
+ ["min-width" Length]
+ ["width" Length]
+ ["max-width" Length]
+
+ ["min-resolution" Resolution]
+ ["resolution" Resolution]
+ ["max-resolution" Resolution]
+
+ ["aspect-ratio" Ratio]
+ ["max-aspect-ratio" Ratio]
+ ["min-aspect-ratio" Ratio]
+
+ ["display-mode" Display-Mode]
+ ["color-gamut" Color-Gamut]
+ ["grid" Boolean]
+ ["orientation" Orientation]
+ ["overflow-block" Block-Overflow]
+ ["overflow-inline" Inline-Overflow]
+ ["scan" Scan]
+ ["update" Update]
+ ["inverted-colors" Inverted-Colors]
+ ["pointer" Pointer]
+ ["any-pointer" Pointer]
+ ["hover" Hover]
+ ["any-hover" Hover]
+ ["light-level" Light]
+ ["scripting" Scripting]
+ ["prefers-reduced-motion" Motion]
+ ["prefers-color-scheme" Color-Scheme]
+ )
+ )
+
+(abstract: #export Query
+ Text
+
+ (def: #export query
+ (-> Query Text)
+ (|>> :representation))
+
+ (template [<name> <operator>]
+ [(def: #export <name>
+ (-> Media Query)
+ (|>> ..media (format <operator>) :abstraction))]
+
+ [except "not "]
+ [only "only "]
+ )
+
+ (def: #export not
+ (-> Feature Query)
+ (|>> ..feature (format "not ") :abstraction))
+
+ (template [<name> <operator>]
+ [(def: #export (<name> left right)
+ (-> Query Query Query)
+ (:abstraction (format (:representation left)
+ <operator>
+ (:representation right))))]
+
+ [and " and "]
+ [or " or "]
+ )
+ )
diff --git a/stdlib/source/library/lux/data/format/css/selector.lux b/stdlib/source/library/lux/data/format/css/selector.lux
new file mode 100644
index 000000000..2a0210f7a
--- /dev/null
+++ b/stdlib/source/library/lux/data/format/css/selector.lux
@@ -0,0 +1,205 @@
+(.module:
+ [library
+ [lux (#- or and for is? not)
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [number
+ ["i" int]]]
+ [type
+ abstract]
+ [macro
+ ["." template]]
+ ["." locale (#+ Locale)]]])
+
+(type: #export Label Text)
+
+(type: #export Tag Label)
+(type: #export ID Label)
+(type: #export Class Label)
+(type: #export Attribute Label)
+
+(abstract: #export (Generic brand) Any)
+
+(template [<generic> <brand>]
+ [(abstract: <brand> Any)
+ (type: #export <generic> (Generic <brand>))]
+
+ [Can-Chain Can-Chain']
+ [Cannot-Chain Cannot-Chain']
+ )
+
+(abstract: #export Unique Any)
+(abstract: #export Specific Any)
+(abstract: #export Composite Any)
+
+(abstract: #export (Selector kind)
+ Text
+
+ (def: #export selector
+ (-> (Selector Any) Text)
+ (|>> :representation))
+
+ (def: #export any
+ (Selector Cannot-Chain)
+ (:abstraction "*"))
+
+ (def: #export tag
+ (-> Tag (Selector Cannot-Chain))
+ (|>> :abstraction))
+
+ (template [<name> <type> <prefix> <kind>]
+ [(def: #export <name>
+ (-> <type> (Selector <kind>))
+ (|>> (format <prefix>) :abstraction))]
+
+ [id ID "#" Unique]
+ [class Class "." Can-Chain]
+ )
+
+ (template [<right> <left> <combo> <combinator>+]
+ [(`` (template [<combinator> <name>]
+ [(def: #export (<name> right left)
+ (-> (Selector <right>) (Selector <left>) (Selector <combo>))
+ (:abstraction (format (:representation left)
+ <combinator>
+ (:representation right))))]
+
+ (~~ (template.splice <combinator>+))))]
+
+ [Can-Chain (Generic Any) Can-Chain
+ [["" and]]]
+ [Unique (Generic Any) Composite
+ [["" for]]]
+ [Specific (Generic Any) Composite
+ [["" at]]]
+ [Any Any Composite
+ [["," or]
+ [" " in]
+ [">" sub]
+ ["+" next]
+ ["~" later]]]
+ )
+
+ (type: #export Combinator
+ (-> (Selector Any) (Selector Any) (Selector Composite)))
+
+ (def: #export (with? attribute)
+ (-> Attribute (Selector Can-Chain))
+ (:abstraction (format "[" attribute "]")))
+
+ (template [<check> <name>]
+ [(def: #export (<name> attribute value)
+ (-> Attribute Text (Selector Can-Chain))
+ (:abstraction (format "[" attribute <check> value "]")))]
+
+ ["=" is?]
+ ["~=" has?]
+ ["|=" has-start?]
+ ["^=" starts?]
+ ["$=" ends?]
+ ["*=" contains?]
+ )
+
+ (template [<kind> <pseudo>+]
+ [(`` (template [<name> <pseudo>]
+ [(def: #export <name>
+ (Selector Can-Chain)
+ (:abstraction <pseudo>))]
+
+ (~~ (template.splice <pseudo>+))))]
+
+ [Can-Chain
+ [[active ":active"]
+ [checked ":checked"]
+ [default ":default"]
+ [disabled ":disabled"]
+ [empty ":empty"]
+ [enabled ":enabled"]
+ [first-child ":first-child"]
+ [first-of-type ":first-of-type"]
+ [focused ":focus"]
+ [hovered ":hover"]
+ [in-range ":in-range"]
+ [indeterminate ":indeterminate"]
+ [invalid ":invalid"]
+ [last-child ":last-child"]
+ [last-of-type ":last-of-type"]
+ [link ":link"]
+ [only-of-type ":only-of-type"]
+ [only-child ":only-child"]
+ [optional ":optional"]
+ [out-of-range ":out-of-range"]
+ [read-only ":read-only"]
+ [read-write ":read-write"]
+ [required ":required"]
+ [root ":root"]
+ [target ":target"]
+ [valid ":valid"]
+ [visited ":visited"]]]
+
+ [Specific
+ [[after "::after"]
+ [before "::before"]
+ [first-letter "::first-letter"]
+ [first-line "::first-line"]
+ [placeholder "::placeholder"]
+ [selection "::selection"]]]
+ )
+
+ (def: #export (language locale)
+ (-> Locale (Selector Can-Chain))
+ (|> locale
+ locale.code
+ (text.enclose ["(" ")"])
+ (format ":lang")
+ :abstraction))
+
+ (def: #export not
+ (-> (Selector Any) (Selector Can-Chain))
+ (|>> :representation
+ (text.enclose ["(" ")"])
+ (format ":not")
+ :abstraction))
+
+ (abstract: #export Index
+ Text
+
+ (def: #export index
+ (-> Nat Index)
+ (|>> %.nat :abstraction))
+
+ (template [<name> <index>]
+ [(def: #export <name> Index (:abstraction <index>))]
+
+ [odd "odd"]
+ [even "even"]
+ )
+
+ (type: #export Formula
+ {#constant Int
+ #variable Int})
+
+ (def: #export (formula input)
+ (-> Formula Index)
+ (let [(^slots [#constant #variable]) input]
+ (:abstraction (format (if (i.< +0 variable)
+ (%.int variable)
+ (%.nat (.nat variable)))
+ (%.int constant)))))
+
+ (template [<name> <pseudo>]
+ [(def: #export (<name> index)
+ (-> Index (Selector Can-Chain))
+ (|> (:representation index)
+ (text.enclose ["(" ")"])
+ (format <pseudo>)
+ (:abstraction Selector)))]
+
+ [nth-child ":nth-child"]
+ [nth-last-child ":nth-last-child"]
+ [nth-last-of-type ":nth-last-of-type"]
+ [nth-of-type ":nth-of-type"]
+ )
+ )
+ )
diff --git a/stdlib/source/library/lux/data/format/css/style.lux b/stdlib/source/library/lux/data/format/css/style.lux
new file mode 100644
index 000000000..5f2c68888
--- /dev/null
+++ b/stdlib/source/library/lux/data/format/css/style.lux
@@ -0,0 +1,36 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [text
+ ["%" format (#+ format)]]]
+ [type
+ abstract]]]
+ ["." // #_
+ ["#." value (#+ Value)]
+ ["#." property (#+ Property)]])
+
+(abstract: #export Style
+ Text
+
+ {#.doc "The style associated with a CSS selector."}
+
+ (def: #export empty
+ Style
+ (:abstraction ""))
+
+ (def: #export separator
+ " ")
+
+ (def: #export (with [property value])
+ (All [brand]
+ (-> [(Property brand) (Value brand)]
+ (-> Style Style)))
+ (|>> :representation
+ (format (//property.name property) ": " (//value.value value) ";" ..separator)
+ :abstraction))
+
+ (def: #export inline
+ (-> Style Text)
+ (|>> :representation))
+ )
diff --git a/stdlib/source/library/lux/data/format/css/value.lux b/stdlib/source/library/lux/data/format/css/value.lux
new file mode 100644
index 000000000..f85272a04
--- /dev/null
+++ b/stdlib/source/library/lux/data/format/css/value.lux
@@ -0,0 +1,1329 @@
+(.module:
+ [library
+ [lux (#- All Cursor and static false true)
+ [control
+ [parser
+ ["s" code]]]
+ [data
+ ["." color]
+ ["." product]
+ ["." maybe]
+ [number
+ ["n" nat]
+ ["i" int]
+ ["r" rev]
+ ["f" frac]]
+ ["." text
+ ["%" format (#+ Format format)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [type
+ abstract]
+ [macro
+ ["." template]
+ ["." code]
+ [syntax (#+ syntax:)]]
+ [world
+ [net (#+ URL)]]]]
+ [//
+ [selector (#+ Label)]])
+
+(syntax: (text-identifier {identifier s.text})
+ (wrap (list (code.local-identifier identifier))))
+
+(template: (enumeration: <abstraction> <representation> <out> <sample>+ <definition>+)
+ (abstract: #export <abstraction>
+ <representation>
+
+ (def: #export <out>
+ (-> <abstraction> <representation>)
+ (|>> :representation))
+
+ (`` (template [<name> <value>]
+ [(def: #export <name> <abstraction> (:abstraction <value>))]
+
+ (~~ (template.splice <sample>+))
+ ))
+
+ (template.splice <definition>+)))
+
+(template: (multi: <multi> <type> <separator>)
+ (def: #export (<multi> pre post)
+ (-> (Value <type>) (Value <type>) (Value <type>))
+ (:abstraction (format (:representation pre)
+ <separator>
+ (:representation post)))))
+
+(def: (%number value)
+ (Format Frac)
+ (let [raw (%.frac value)]
+ (if (f.< +0.0 value)
+ raw
+ (|> raw (text.split 1) maybe.assume product.right))))
+
+(abstract: #export (Value brand)
+ Text
+
+ (def: #export value
+ (-> (Value Any) Text)
+ (|>> :representation))
+
+ (template [<name> <value>]
+ [(def: #export <name> Value (:abstraction <value>))]
+
+ [initial "initial"]
+ [inherit "inherit"]
+ [unset "unset"]
+ )
+
+ (template [<brand> <alias>+ <value>+]
+ [(abstract: #export <brand> Any)
+
+ (`` (template [<name> <value>]
+ [(def: #export <name>
+ (Value <brand>)
+ (:abstraction <value>))]
+
+ (~~ (template.splice <alias>+))))
+
+ (with-expansions [<rows> (template.splice <value>+)]
+ (template [<value>]
+ [(`` (def: #export (~~ (text-identifier <value>))
+ (Value <brand>)
+ (:abstraction <value>)))]
+
+ <rows>))]
+
+ [All
+ []
+ []]
+
+ [Number
+ []
+ []]
+
+ [Length
+ []
+ []]
+
+ [Time
+ []
+ []]
+
+ [Thickness
+ []
+ [["medium"]
+ ["thin"]
+ ["thick"]]]
+
+ [Slice
+ [[full-slice "fill"]]
+ []]
+
+ [Alignment
+ [[auto-alignment "auto"]]
+ [["stretch"]
+ ["center"]
+ ["flex-start"]
+ ["flex-end"]
+ ["baseline"]
+ ["space-between"]
+ ["space-around"]]]
+
+ [Animation
+ []
+ []]
+
+ [Animation-Direction
+ [[normal-direction "normal"]]
+ [["reverse"]
+ ["alternate"]
+ ["alternate-reverse"]]]
+
+ [Animation-Fill
+ [[fill-forwards "forwards"]
+ [fill-backwards "backwards"]
+ [fill-both "both"]]
+ []]
+
+ [Column-Fill
+ []
+ [["balance"]
+ ["auto"]]]
+
+ [Column-Span
+ []
+ [["all"]]]
+
+ [Iteration
+ []
+ [["infinite"]]]
+
+ [Count
+ []
+ []]
+
+ [Play
+ []
+ [["paused"]
+ ["running"]]]
+
+ [Timing
+ []
+ [["linear"]
+ ["ease"]
+ ["ease-in"]
+ ["ease-out"]
+ ["ease-in-out"]
+ ["step-start"]
+ ["step-end"]]]
+
+ [Visibility
+ [[invisible "hidden"]
+ [collapse-visibility "collapse"]]
+ [["visible"]]]
+
+ [Attachment
+ [[scroll-attachment "scroll"]
+ [fixed-attachment "fixed"]
+ [local-attachment "local"]]
+ []]
+
+ [Blend
+ [[normal-blend "normal"]]
+ [["multiply"]
+ ["screen"]
+ ["overlay"]
+ ["darken"]
+ ["lighten"]
+ ["color-dodge"]
+ ["color-burn"]
+ ["difference"]
+ ["exclusion"]
+ ["hue"]
+ ["saturation"]
+ ["color"]
+ ["luminosity"]]]
+
+ [Span
+ []
+ [["border-box"]
+ ["padding-box"]
+ ["content-box"]]]
+
+ [Image
+ [[no-image "none"]]
+ []]
+
+ [Repeat
+ [[stretch-repeat "stretch"]]
+ [["repeat"]
+ ["repeat-x"]
+ ["repeat-y"]
+ ["no-repeat"]
+ ["space"]
+ ["round"]]]
+
+ [Location
+ [[left-top "left top"]
+ [left-center "left center"]
+ [left-bottom "left bottom"]
+ [right-top "right top"]
+ [right-center "right center"]
+ [right-bottom "right bottom"]
+ [center-top "center top"]
+ [center-center "center center"]
+ [center-bottom "center bottom"]]
+ []]
+
+ [Fit
+ [[no-fit "none"]]
+ [["fill"]
+ ["cover"]
+ ["contain"]
+ ["scale-down"]]]
+
+ [Border
+ []
+ [["hidden"]
+ ["dotted"]
+ ["dashed"]
+ ["solid"]
+ ["double"]
+ ["groove"]
+ ["ridge"]
+ ["inset"]
+ ["outset"]]]
+
+ [Collapse
+ []
+ [["separate"]
+ ["collapse"]]]
+
+ [Box-Decoration-Break
+ []
+ [["slice"]
+ ["clone"]]]
+
+ [Caption
+ []
+ [["top"]
+ ["bottom"]]]
+
+ [Float
+ [[float-left "left"]
+ [float-right "right"]]
+ []]
+
+ [Clear
+ [[clear-left "left"]
+ [clear-right "right"]
+ [clear-both "both"]]
+ []]
+
+ [Counter
+ []
+ []]
+
+ [Content
+ []
+ [["open-quote"]
+ ["close-quote"]
+ ["no-open-quote"]
+ ["no-close-quote"]]]
+
+ [Cursor
+ [[horizontal-text "text"]
+ [no-cursor "none"]]
+ [["alias"]
+ ["all-scroll"]
+ ["cell"]
+ ["context-menu"]
+ ["col-resize"]
+ ["copy"]
+ ["crosshair"]
+ ["default"]
+ ["e-resize"]
+ ["ew-resize"]
+ ["grab"]
+ ["grabbing"]
+ ["help"]
+ ["move"]
+ ["n-resize"]
+ ["ne-resize"]
+ ["nesw-resize"]
+ ["ns-resize"]
+ ["nw-resize"]
+ ["nwse-resize"]
+ ["no-drop"]
+ ["not-allowed"]
+ ["pointer"]
+ ["progress"]
+ ["row-resize"]
+ ["s-resize"]
+ ["se-resize"]
+ ["sw-resize"]
+ ["vertical-text"]
+ ["w-resize"]
+ ["wait"]
+ ["zoom-in"]
+ ["zoom-out"]]]
+
+ [Shadow
+ []
+ []]
+
+ [Clip
+ []
+ []]
+
+ [Text-Direction
+ [[left-to-right "ltr"]
+ [right-to-left "rtl"]]
+ []]
+
+ [Display
+ [[grid-display "grid"]
+ [no-display "none"]]
+ [["inline"]
+ ["block"]
+ ["contents"]
+ ["flex"]
+ ["inline-block"]
+ ["inline-flex"]
+ ["inline-grid"]
+ ["inline-table"]
+ ["list-item"]
+ ["run-in"]
+ ["table"]
+ ["table-caption"]
+ ["table-column-group"]
+ ["table-header-group"]
+ ["table-footer-group"]
+ ["table-row-group"]
+ ["table-cell"]
+ ["table-column"]
+ ["table-row"]]]
+
+ [Empty
+ []
+ [["show"]
+ ["hide"]]]
+
+ [Filter
+ []
+ []]
+
+ [Flex-Direction
+ []
+ [["row"]
+ ["row-reverse"]
+ ["column"]
+ ["column-reverse"]]]
+
+ [Flex-Wrap
+ [[no-wrap "nowrap"]]
+ [["wrap"]
+ ["wrap-reverse"]]]
+
+ [Font-Kerning
+ [[auto-kerning "auto"]
+ [normal-kerning "normal"]
+ [no-kerning "none"]]
+ []]
+
+ [Font-Size
+ [[medium-size "medium"]
+ [xx-small-size "xx-small"]
+ [x-small-size "x-small"]
+ [small-size "small"]
+ [large-size "large"]
+ [x-large-size "x-large"]
+ [xx-large-size "xx-large"]
+ [smaller-size "smaller"]
+ [larger-size "larger"]]
+ []]
+
+ [Font-Stretch
+ [[normal-stretch "normal"]]
+ [["condensed"]
+ ["ultra-condensed"]
+ ["extra-condensed"]
+ ["semi-condensed"]
+ ["expanded"]
+ ["semi-expanded"]
+ ["extra-expanded"]
+ ["ultra-expanded"]]]
+
+ [Font-Style
+ [[normal-style "normal"]]
+ [["italic"]
+ ["oblique"]]]
+
+ [Font-Weight
+ [[normal-weight "normal"]
+ [weight-100 "100"]
+ [weight-200 "200"]
+ [weight-300 "300"]
+ [weight-400 "400"]
+ [weight-500 "500"]
+ [weight-600 "600"]
+ [weight-700 "700"]
+ [weight-800 "800"]
+ [weight-900 "900"]]
+ [["bold"]]]
+
+ [Font-Variant
+ [[normal-font "normal"]]
+ [["small-caps"]]]
+
+ [Grid
+ []
+ []]
+
+ [Grid-Content
+ [[auto-content "auto"]]
+ [["max-content"]
+ ["min-content"]]]
+
+ [Grid-Flow
+ [[row-flow "row"]
+ [column-flow "column"]
+ [dense-flow "dense"]
+ [row-dense-flow "row dense"]
+ [column-dense-flow "column dense"]]
+ []]
+
+ [Grid-Span
+ [[auto-span "auto"]]
+ []]
+
+ [Grid-Template
+ []
+ []]
+
+ [Hanging-Punctuation
+ [[no-hanging-punctuation "none"]]
+ [["first"]
+ ["last"]
+ ["allow-end"]
+ ["force-end"]]]
+
+ [Hyphens
+ [[no-hyphens "none"]
+ [manual-hyphens "manual"]
+ [auto-hyphens "auto"]]
+ []]
+
+ [Orientation
+ []
+ [["portrait"]
+ ["landscape"]]]
+
+ [Resolution
+ []
+ []]
+
+ [Scan
+ []
+ [["interlace"]
+ ["progressive"]]]
+
+ [Boolean
+ [[false "0"]
+ [true "1"]]
+ []]
+
+ [Update
+ [[no-update "none"]
+ [slow-update "slow"]
+ [fast-update "fast"]]
+ []]
+
+ [Block-Overflow
+ [[no-block-overflow "none"]
+ [scroll-block-overflow "scroll"]
+ [optional-paged-block-overflow "optional-paged"]
+ [paged-block-overflow "paged"]]
+ []]
+
+ [Inline-Overflow
+ [[no-inline-overflow "none"]
+ [scroll-inline-overflow "scroll"]]
+ []]
+
+ [Display-Mode
+ []
+ [["fullscreen"]
+ ["standalone"]
+ ["minimal-ui"]
+ ["browser"]]]
+
+ [Color-Gamut
+ []
+ [["srgb"]
+ ["p3"]
+ ["rec2020"]]]
+
+ [Inverted-Colors
+ [[no-inverted-colors "none"]
+ [inverted-colors "inverted"]]
+ []]
+
+ [Pointer
+ [[no-pointer "none"]
+ [coarse-pointer "coarse"]
+ [fine-pointer "fine"]]
+ []]
+
+ [Hover
+ [[no-hover "none"]]
+ [["hover"]]]
+
+ [Light
+ [[dim-light "dim"]
+ [normal-light "normal"]
+ [washed-light "washed"]]
+ []]
+
+ [Ratio
+ []
+ []]
+
+ [Scripting
+ [[no-scripting "none"]
+ [initial-scripting-only "initial-only"]
+ [scripting-enabled "enabled"]]
+ []]
+
+ [Motion
+ [[no-motion-preference "no-preference"]
+ [reduced-motion "reduce"]]
+ []]
+
+ [Color-Scheme
+ [[no-color-scheme-preference "no-preference"]
+ [light-color-scheme "light"]
+ [dark-color-scheme "dark"]]
+ []]
+
+ [Isolation
+ [[auto-isolation "auto"]]
+ [["isolate"]]]
+
+ [List-Style-Position
+ []
+ [["inside"]
+ ["outside"]]]
+
+ [List-Style-Type
+ [[no-list-style "none"]]
+ [["disc"]
+ ["armenian"]
+ ["circle"]
+ ["cjk-ideographic"]
+ ["decimal"]
+ ["decimal-leading-zero"]
+ ["georgian"]
+ ["hebrew"]
+ ["hiragana"]
+ ["hiragana-iroha"]
+ ["katakana"]
+ ["katakana-iroha"]
+ ["lower-alpha"]
+ ["lower-greek"]
+ ["lower-latin"]
+ ["lower-roman"]
+ ["square"]
+ ["upper-alpha"]
+ ["upper-greek"]
+ ["upper-latin"]
+ ["upper-roman"]]]
+
+ [Color
+ []
+ []]
+
+ [Overflow
+ [[visible-overflow "visible"]
+ [hidden-overflow "hidden"]
+ [scroll-overflow "scroll"]
+ [auto-overflow "auto"]]
+ []]
+
+ [Page-Break
+ [[auto-page-break "auto"]
+ [always-page-break "always"]
+ [avoid-page-break "avoid"]
+ [left-page-break "left"]
+ [right-page-break "right"]]
+ []]
+
+ [Pointer-Events
+ [[auto-pointer-events "auto"]
+ [no-pointer-events "none"]]
+ []]
+
+ [Position
+ []
+ [["static"]
+ ["absolute"]
+ ["fixed"]
+ ["relative"]
+ ["sticky"]]]
+
+ [Quotes
+ [[no-quotes "none"]]
+ []]
+
+ [Resize
+ [[resize-none "none"]
+ [resize-both "both"]
+ [resize-horizontal "horizontal"]
+ [resize-vertical "vertical"]]
+ []]
+
+ [Scroll-Behavior
+ [[auto-scroll-behavior "auto"]
+ [smooth-scroll-behavior "smooth"]]
+ []]
+
+ [Table-Layout
+ [[auto-table-layout "auto"]
+ [fixed-table-layout "fixed"]]
+ []]
+
+ [Text-Align
+ [[left-text-align "left"]
+ [right-text-align "right"]
+ [center-text-align "center"]
+ [justify-text-align "justify"]]
+ []]
+
+ [Text-Align-Last
+ [[auto-text-align-last "auto"]
+ [left-text-align-last "left"]
+ [right-text-align-last "right"]
+ [center-text-align-last "center"]
+ [justify-text-align-last "justify"]
+ [start-text-align-last "start"]
+ [end-text-align-last "end"]]
+ []]
+
+ [Text-Decoration-Line
+ [[no-text-decoration-line "none"]
+ [underline-text-decoration-line "underline"]
+ [overline-text-decoration-line "overline"]
+ [line-through-text-decoration-line "line-through"]]
+ []]
+
+ [Text-Decoration-Style
+ [[solid-text-decoration-style "solid"]
+ [double-text-decoration-style "double"]
+ [dotted-text-decoration-style "dotted"]
+ [dashed-text-decoration-style "dashed"]
+ [wavy-text-decoration-style "wavy"]]
+ []]
+
+ [Text-Justification
+ [[auto-text-justification "auto"]
+ [inter-word-text-justification "inter-word"]
+ [inter-character-text-justification "inter-character"]
+ [no-text-justification "none"]]
+ []]
+
+ [Text-Overflow
+ [[clip-text-overflow "clip"]
+ [ellipsis-text-overflow "ellipsis"]]
+ []]
+
+ [Text-Transform
+ [[no-text-transform "none"]]
+ [["capitalize"]
+ ["uppercase"]
+ ["lowercase"]]]
+
+ [Transform
+ [[no-transform "none"]]
+ []]
+
+ [Transform-Origin
+ []
+ []]
+
+ [Transform-Style
+ []
+ [["flat"]
+ ["preserve-3d"]]]
+
+ [Transition
+ [[transition-none "none"]
+ [transition-all "all"]]
+ []]
+
+ [Bidi
+ [[bidi-normal "normal"]
+ [bidi-embed "embed"]
+ [bidi-isolate "isolate"]
+ [bidi-isolate-override "isolate-override"]
+ [bidi-plaintext "plaintext"]]
+ [["bidi-override"]]]
+
+ [User-Select
+ [[user-select-auto "auto"]
+ [user-select-none "none"]
+ [user-select-text "text"]
+ [user-select-all "all"]]
+ []]
+
+ [Vertical-Align
+ [[vertical-align-baseline "baseline"]
+ [vertical-align-sub "sub"]
+ [vertical-align-super "super"]
+ [vertical-align-top "top"]
+ [vertical-align-text-top "text-top"]
+ [vertical-align-middle "middle"]
+ [vertical-align-bottom "bottom"]
+ [vertical-align-text-bottom "text-bottom"]]
+ []]
+
+ [White-Space
+ [[normal-white-space "normal"]
+ [no-wrap-white-space "nowrap"]
+ [pre-white-space "pre"]
+ [pre-line-white-space "pre-line"]
+ [pre-wrap-white-space "pre-wrap"]]
+ []]
+
+ [Word-Break
+ [[normal-word-break "normal"]]
+ [["break-all"]
+ ["keep-all"]
+ ["break-word"]]]
+
+ [Word-Wrap
+ [[normal-word-wrap "normal"]
+ [break-word-word-wrap "break-word"]]
+ []]
+
+ [Writing-Mode
+ [[top-to-bottom-writing-mode "horizontal-tb"]
+ [left-to-right-writing-mode "vertical-rl"]
+ [right-to-left-writing-mode "vertical-lr"]]
+ []]
+
+ [Z-Index
+ []
+ []]
+ )
+
+ (def: value-separator ",")
+
+ (def: (apply name inputs)
+ (-> Text (List Text) Value)
+ (|> inputs
+ (text.join-with ..value-separator)
+ (text.enclose ["(" ")"])
+ (format name)
+ :abstraction))
+
+ (enumeration: Step Text
+ step
+ [[start "start"]
+ [end "end"]]
+ [])
+
+ (def: #export (steps intervals step)
+ (-> Nat Step (Value Timing))
+ (..apply "steps" (list (%.nat intervals) (..step step))))
+
+ (def: #export (cubic-bezier p0 p1 p2 p3)
+ (-> Frac Frac Frac Frac (Value Timing))
+ (|> (list p0 p1 p2 p3)
+ (list\map %number)
+ (..apply "cubic-bezier")))
+
+ (template [<name> <brand>]
+ [(def: #export <name>
+ (-> Nat (Value <brand>))
+ (|>> %.nat :abstraction))]
+
+ [iteration Iteration]
+ [count Count]
+ [slice-number/1 Slice]
+ [span-line Grid-Span]
+ )
+
+ (def: #export animation
+ (-> Label (Value Animation))
+ (|>> :abstraction))
+
+ (def: #export (rgb color)
+ (-> color.Color (Value Color))
+ (let [[red green blue] (color.to-rgb color)]
+ (..apply "rgb" (list (%.nat red)
+ (%.nat green)
+ (%.nat blue)))))
+
+ (def: #export (rgba pigment)
+ (-> color.Pigment (Value Color))
+ (let [(^slots [#color.color #color.alpha]) pigment
+ [red green blue] (color.to-rgb color)]
+ (..apply "rgba" (list (%.nat red)
+ (%.nat green)
+ (%.nat blue)
+ (if (r.= (\ r.interval top) alpha)
+ "1.0"
+ (format "0" (%.rev alpha)))))))
+
+ (template [<name> <suffix>]
+ [(def: #export (<name> value)
+ (-> Frac (Value Length))
+ (:abstraction (format (%number value) <suffix>)))]
+
+ [em "em"]
+ [ex "ex"]
+ [rem "rem"]
+ [ch "ch"]
+ [vw "vw"]
+ [vh "vh"]
+ [vmin "vmin"]
+ [vmax "vmax"]
+ [% "%"]
+ [cm "cm"]
+ [mm "mm"]
+ [in "in"]
+ [px "px"]
+ [pt "pt"]
+ [pc "pc"]
+ [fr "fr"]
+ )
+
+ (def: (%int value)
+ (Format Int)
+ (if (i.< +0 value)
+ (%.int value)
+ (%.nat (.nat value))))
+
+ (template [<name> <suffix>]
+ [(def: #export (<name> value)
+ (-> Int (Value Time))
+ (:abstraction (format (if (i.< +0 value)
+ (%.int value)
+ (%.nat (.nat value)))
+ <suffix>)))]
+
+
+ [seconds "s"]
+ [milli-seconds "ms"]
+ )
+
+ (def: #export thickness
+ (-> (Value Length) (Value Thickness))
+ (|>> :transmutation))
+
+ (def: slice-separator " ")
+
+ (def: #export (slice-number/2 horizontal vertical)
+ (-> Nat Nat (Value Slice))
+ (:abstraction (format (%.nat horizontal) ..slice-separator
+ (%.nat vertical))))
+
+ (abstract: #export Stop
+ Text
+
+ (def: #export stop
+ (-> (Value Color) Stop)
+ (|>> (:representation Value) (:abstraction Stop)))
+
+ (def: stop-separator " ")
+
+ (def: #export (single-stop length color)
+ (-> (Value Length) (Value Color) Stop)
+ (:abstraction (format (:representation Value color) ..stop-separator
+ (:representation Value length))))
+
+ (def: #export (double-stop start end color)
+ (-> (Value Length) (Value Length) (Value Color) Stop)
+ (:abstraction (format (:representation Value color) ..stop-separator
+ (:representation Value start) ..stop-separator
+ (:representation Value end))))
+
+ (abstract: #export Hint
+ Text
+
+ (def: #export hint
+ (-> (Value Length) Hint)
+ (|>> (:representation Value) (:abstraction Hint)))
+
+ (def: (with-hint [hint stop])
+ (-> [(Maybe Hint) Stop] Text)
+ (case hint
+ #.None
+ (:representation Stop stop)
+
+ (#.Some hint)
+ (format (:representation Hint hint) ..value-separator (:representation Stop stop))))))
+
+ (type: #export (List/1 a)
+ [a (List a)])
+
+ (abstract: #export Angle
+ Text
+
+ (def: #export angle
+ (-> Angle Text)
+ (|>> :representation))
+
+ (def: #export (turn value)
+ (-> Rev Angle)
+ (:abstraction (format (%.rev value) "turn")))
+
+ (def: degree-limit Nat 360)
+
+ (def: #export (degree value)
+ (-> Nat Angle)
+ (:abstraction (format (%.nat (n.% ..degree-limit value)) "deg")))
+
+ (template [<degree> <name>]
+ [(def: #export <name> Angle (..degree <degree>))]
+
+ [000 to-top]
+ [090 to-right]
+ [180 to-bottom]
+ [270 to-left]
+ )
+
+ (template [<name> <function>]
+ [(def: #export (<name> angle start next)
+ (-> Angle Stop (List/1 [(Maybe Hint) Stop]) (Value Image))
+ (let [[now after] next]
+ (..apply <function> (list& (:representation Angle angle)
+ (with-hint now)
+ (list\map with-hint after)))))]
+
+ [linear-gradient "linear-gradient"]
+ [repeating-linear-gradient "repeating-linear-gradient"]
+ )
+ )
+
+ (abstract: #export Percentage
+ Text
+
+ (def: #export percentage
+ (-> Percentage Text)
+ (|>> :representation))
+
+ (def: percentage-limit Nat (.inc 100))
+
+ (def: #export (%% value)
+ (-> Nat Percentage)
+ (:abstraction (format (%.nat (n.% percentage-limit value)) "%")))
+
+ (def: #export slice-percent/1
+ (-> Percentage (Value Slice))
+ (|>> :representation (:abstraction Value)))
+
+ (def: #export (slice-percent/2 horizontal vertical)
+ (-> Percentage Percentage (Value Slice))
+ (:abstraction Value (format (:representation horizontal) ..slice-separator
+ (:representation vertical))))
+
+ (template [<input> <pre> <function>+]
+ [(`` (template [<name> <function>]
+ [(def: #export <name>
+ (-> <input> (Value Filter))
+ (|>> <pre> (list) (..apply <function>)))]
+
+ (~~ (template.splice <function>+))))]
+
+ [Nat (<| (:representation Value) ..px n.frac)
+ [[blur "blur"]]]
+ [Nat (<| ..angle ..degree)
+ [[hue-rotate "hue-rotate"]]]
+ [Percentage (:representation Percentage)
+ [[brightness "brightness"]
+ [contrast "contrast"]
+ [grayscale "grayscale"]
+ [invert "invert"]
+ [opacity "opacity"]
+ [saturate "saturate"]
+ [sepia "sepia"]]]
+ )
+ )
+
+ (def: #export svg-filter
+ (-> URL (Value Filter))
+ (|>> (list) (..apply "url")))
+
+ (def: default-shadow-length (px +0.0))
+
+ (def: #export (drop-shadow horizontal vertical blur spread color)
+ (-> (Value Length) (Value Length)
+ (Maybe (Value Length)) (Maybe (Value Length))
+ (Value Color)
+ (Value Filter))
+ (|> (list (:representation horizontal)
+ (:representation vertical)
+ (|> blur (maybe.default ..default-shadow-length) :representation)
+ (|> spread (maybe.default ..default-shadow-length) :representation)
+ (:representation color))
+ (text.join-with " ")
+ (list)
+ (..apply "drop-shadow")))
+
+ (def: length-separator " ")
+
+ (template [<name> <type>]
+ [(def: #export (<name> horizontal vertical)
+ (-> (Value Length) (Value Length) (Value <type>))
+ (:abstraction (format (:representation horizontal)
+ ..length-separator
+ (:representation vertical))))]
+
+ [location Location]
+ [fit Fit]
+ )
+
+ (def: #export (fit/1 length)
+ (-> (Value Length) (Value Fit))
+ (..fit length length))
+
+ (def: #export image
+ (-> URL (Value Image))
+ (|>> %.text
+ (list)
+ (..apply "url")))
+
+ (enumeration: Shape Text
+ shape
+ [[ellipse-shape "ellipse"]
+ [circle-shape "circle"]]
+ [])
+
+ (enumeration: Extent Text
+ extent
+ [[closest-side "closest-side"]
+ [closest-corner "closest-corner"]
+ [farthest-side "farthest-side"]
+ [farthest-corner "farthest-corner"]]
+ [])
+
+ (template [<name> <function>]
+ [(def: #export (<name> shape extent location start next)
+ (-> Shape (Maybe Extent) (Value Location)
+ Stop (List/1 [(Maybe Hint) Stop])
+ (Value Image))
+ (let [after-extent (format "at " (:representation location))
+ with-extent (case extent
+ (#.Some extent)
+ (format (..extent extent) " " after-extent)
+
+ #.None
+ after-extent)
+ where (format (..shape shape) " " with-extent)
+ [now after] next]
+ (..apply <function> (list& (..shape shape)
+ (with-hint now)
+ (list\map with-hint after)))))]
+
+ [radial-gradient "radial-gradient"]
+ [repeating-radial-gradient "repeating-radial-gradient"]
+ )
+
+ (def: #export (shadow horizontal vertical blur spread color inset?)
+ (-> (Value Length) (Value Length)
+ (Maybe (Value Length)) (Maybe (Value Length))
+ (Value Color) Bit
+ (Value Shadow))
+ (let [with-inset (if inset?
+ (list "inset")
+ (list))]
+ (|> (list& (:representation horizontal)
+ (:representation vertical)
+ (|> blur (maybe.default ..default-shadow-length) :representation)
+ (|> spread (maybe.default ..default-shadow-length) :representation)
+ (:representation color)
+ with-inset)
+ (text.join-with " ")
+ :abstraction)))
+
+ (type: #export Rectangle
+ {#top (Value Length)
+ #right (Value Length)
+ #bottom (Value Length)
+ #left (Value Length)})
+
+ (def: #export (clip rectangle)
+ (-> Rectangle (Value Clip))
+ (`` (..apply "rect" (list (~~ (template [<side>]
+ [(:representation (get@ <side> rectangle))]
+
+ [#top] [#right] [#bottom] [#left]))))))
+
+ (def: #export counter
+ (-> Label (Value Counter))
+ (|>> :abstraction))
+
+ (def: #export current-count
+ (-> (Value Counter) (Value Content))
+ (|>> :representation (list) (..apply "counter")))
+
+ (def: #export text
+ (-> Text (Value Content))
+ (|>> %.text :abstraction))
+
+ (def: #export attribute
+ (-> Label (Value Content))
+ (|>> (list) (..apply "attr")))
+
+ (def: #export media
+ (-> URL (Value Content))
+ (|>> (list) (..apply "url")))
+
+ (enumeration: Font Text
+ font-name
+ [[serif "serif"]
+ [sans-serif "sans-serif"]
+ [cursive "cursive"]
+ [fantasy "fantasy"]
+ [monospace "monospace"]]
+ [(def: #export font
+ (-> Text Font)
+ (|>> %.text :abstraction))
+
+ (def: #export (font-family options)
+ (-> (List Font) (Value Font))
+ (case options
+ (#.Cons _)
+ (|> options
+ (list\map ..font-name)
+ (text.join-with ",")
+ (:abstraction Value))
+
+ #.Nil
+ ..initial))])
+
+ (def: #export font-size
+ (-> (Value Length) (Value Font-Size))
+ (|>> :transmutation))
+
+ (def: #export number
+ (-> Frac (Value Number))
+ (|>> %number :abstraction))
+
+ (def: #export grid
+ (-> Label (Value Grid))
+ (|>> :abstraction))
+
+ (def: #export fit-content
+ (-> (Value Length) (Value Grid-Content))
+ (|>> :representation (list) (..apply "fit-content")))
+
+ (def: #export (min-max min max)
+ (-> (Value Grid-Content) (Value Grid-Content) (Value Grid-Content))
+ (..apply "minmax" (list (:representation min)
+ (:representation max))))
+
+ (def: #export grid-span
+ (-> Nat (Value Grid-Span))
+ (|>> %.nat (format "span ") :abstraction))
+
+ (def: grid-column-separator " ")
+ (def: grid-row-separator " ")
+
+ (def: #export grid-template
+ (-> (List (List (Maybe (Value Grid)))) (Value Grid-Template))
+ (let [empty (: (Value Grid)
+ (:abstraction "."))]
+ (|>> (list\map (|>> (list\map (|>> (maybe.default empty)
+ :representation))
+ (text.join-with ..grid-column-separator)
+ (text.enclose ["'" "'"])))
+ (text.join-with ..grid-row-separator)
+ :abstraction)))
+
+ (def: #export (resolution dpi)
+ (-> Nat (Value Resolution))
+ (:abstraction (format (%.nat dpi) "dpi")))
+
+ (def: #export (ratio numerator denominator)
+ (-> Nat Nat (Value Ratio))
+ (:abstraction (format (%.nat numerator) "/" (%.nat denominator))))
+
+ (enumeration: Quote Text
+ quote-text
+ [[double-quote "\0022"]
+ [single-quote "\0027"]
+ [single-left-angle-quote "\2039"]
+ [single-right-angle-quote "\203A"]
+ [double-left-angle-quote "\00AB"]
+ [double-right-angle-quote "\00BB"]
+ [single-left-quote "\2018"]
+ [single-right-quote "\2019"]
+ [double-left-quote "\201C"]
+ [double-right-quote "\201D"]
+ [low-double-quote "\201E"]]
+ [(def: #export quote
+ (-> Text Quote)
+ (|>> :abstraction))])
+
+ (def: quote-separator " ")
+
+ (def: #export (quotes [left0 right0] [left1 right1])
+ (-> [Quote Quote] [Quote Quote] (Value Quotes))
+ (|> (list left0 right0 left1 right1)
+ (list\map (|>> ..quote-text %.text))
+ (text.join-with ..quote-separator)
+ :abstraction))
+
+ (def: #export (matrix-2d [a b] [c d] [tx ty])
+ (-> [Frac Frac]
+ [Frac Frac]
+ [Frac Frac]
+ (Value Transform))
+ (|> (list a b c d tx ty)
+ (list\map %number)
+ (..apply "matrix")))
+
+ (def: #export (matrix-3d [a0 b0 c0 d0] [a1 b1 c1 d1] [a2 b2 c2 d2] [a3 b3 c3 d3])
+ (-> [Frac Frac Frac Frac]
+ [Frac Frac Frac Frac]
+ [Frac Frac Frac Frac]
+ [Frac Frac Frac Frac]
+ (Value Transform))
+ (|> (list a0 b0 c0 d0 a1 b1 c1 d1 a2 b2 c2 d2 a3 b3 c3 d3)
+ (list\map %number)
+ (..apply "matrix3d")))
+
+ (template [<name> <function> <input-types> <input-values>]
+ [(`` (def: #export (<name> [(~~ (template.splice <input-values>))])
+ (-> [(~~ (template.splice <input-types>))] (Value Transform))
+ (|> (list (~~ (template.splice <input-values>)))
+ (list\map %number)
+ (..apply <function>))))]
+
+ [translate-2d "translate" [Frac Frac] [x y]]
+ [translate-3d "translate3d" [Frac Frac Frac] [x y z]]
+ [translate-x "translateX" [Frac] [value]]
+ [translate-y "translateY" [Frac] [value]]
+ [translate-z "translateZ" [Frac] [value]]
+
+ [scale-2d "scale" [Frac Frac] [x y]]
+ [scale-3d "scale3d" [Frac Frac Frac] [x y z]]
+ [scale-x "scaleX" [Frac] [value]]
+ [scale-y "scaleY" [Frac] [value]]
+ [scale-z "scaleZ" [Frac] [value]]
+
+ [perspective "perspective" [Frac] [value]]
+ )
+
+ (template [<name> <function> <input-types> <input-values>]
+ [(`` (def: #export (<name> [(~~ (template.splice <input-values>))])
+ (-> [(~~ (template.splice <input-types>))] (Value Transform))
+ (|> (list (~~ (template.splice <input-values>)))
+ (list\map ..angle)
+ (..apply <function>))))]
+
+ [rotate-2d "rotate" [Angle] [angle]]
+ [rotate-x "rotateX" [Angle] [angle]]
+ [rotate-y "rotateY" [Angle] [angle]]
+ [rotate-z "rotateZ" [Angle] [angle]]
+
+ [skew "skew" [Angle Angle] [x-angle y-angle]]
+ [skew-x "skewX" [Angle] [angle]]
+ [skew-y "skewY" [Angle] [angle]]
+ )
+
+ (def: #export (rotate-3d [x y z angle])
+ (-> [Frac Frac Frac Angle] (Value Transform))
+ (..apply "rotate3d"
+ (list (%number x) (%number y) (%number z) (..angle angle))))
+
+ (def: origin-separator " ")
+
+ (def: #export (origin-2d x y)
+ (-> (Value Length) (Value Length) (Value Transform-Origin))
+ (:abstraction (format (:representation x) ..origin-separator
+ (:representation y))))
+
+ (def: #export (origin-3d x y z)
+ (-> (Value Length) (Value Length) (Value Length) (Value Transform-Origin))
+ (:abstraction (format (:representation x) ..origin-separator
+ (:representation y) ..origin-separator
+ (:representation z))))
+
+ (def: #export vertical-align
+ (-> (Value Length) (Value Vertical-Align))
+ (|>> :transmutation))
+
+ (def: #export (z-index index)
+ (-> Int (Value Z-Index))
+ (:abstraction (if (i.< +0 index)
+ (%.int index)
+ (%.nat (.nat index)))))
+
+ (multi: multi-image Image ",")
+ (multi: multi-shadow Shadow ",")
+ (multi: multi-content Content " ")
+ )
diff --git a/stdlib/source/library/lux/data/format/html.lux b/stdlib/source/library/lux/data/format/html.lux
new file mode 100644
index 000000000..6a8e0b24f
--- /dev/null
+++ b/stdlib/source/library/lux/data/format/html.lux
@@ -0,0 +1,563 @@
+(.module:
+ [library
+ [lux (#- Meta Source comment and)
+ ["." function]
+ [data
+ ["." product]
+ ["." maybe ("#\." functor)]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [type
+ abstract]
+ [host
+ ["." js]]
+ [macro
+ ["." template]]
+ [world
+ [net (#+ URL)]]]]
+ [//
+ [css
+ ["." selector]
+ ["." style (#+ Style)]]
+ ["." xml (#+ XML)]])
+
+(type: #export Tag selector.Tag)
+(type: #export ID selector.ID)
+(type: #export Class selector.Class)
+
+(type: #export Attributes
+ {#.doc "Attributes for an HTML tag."}
+ (List [Text Text]))
+
+(type: #export Script js.Statement)
+
+(type: #export Target
+ #Blank
+ #Parent
+ #Self
+ #Top
+ (#Frame Text))
+
+(def: (target value)
+ (-> Target Text)
+ (case value
+ #Blank "_blank"
+ #Parent "_parent"
+ #Self "_self"
+ #Top "_top"
+ (#Frame name) name))
+
+(def: sanitize
+ {#.doc "Properly formats text to ensure no injection can happen on the HTML."}
+ (-> Text Text)
+ (|>> (text.replace-all "&" "&amp;")
+ (text.replace-all "<" "&lt;")
+ (text.replace-all ">" "&gt;")
+ (text.replace-all text.double-quote "&quot;")
+ (text.replace-all "'" "&#x27;")
+ (text.replace-all "/" "&#x2F;")))
+
+(def: attributes
+ (-> Attributes Text)
+ (|>> (list\map (function (_ [key val])
+ (format key "=" text.double-quote (..sanitize val) text.double-quote)))
+ (text.join-with " ")))
+
+(def: (open tag attributes)
+ (-> Tag Attributes Text)
+ (|> attributes
+ ..attributes
+ (format tag " ")
+ (text.enclose ["<" ">"])))
+
+(def: close
+ (-> Tag Text)
+ (text.enclose ["</" ">"]))
+
+(abstract: #export (HTML brand)
+ Text
+
+ (template [<name> <brand>]
+ [(abstract: #export <brand> Any)
+ (type: #export <name> (HTML <brand>))]
+
+ [Meta Meta']
+ [Head Head']
+ [Item Item']
+ [Option Option']
+ [Input Input']
+ [Cell Cell']
+ [Header Header']
+ [Row Row']
+ [Column Column']
+ [Parameter Parameter']
+ [Body Body']
+ [Document Document']
+ )
+
+ (template [<super> <super-raw> <sub>+]
+ [(abstract: #export (<super-raw> brand) Any)
+ (type: #export <super> (HTML (<super-raw> Any)))
+
+ (`` (template [<sub> <sub-raw>]
+ [(abstract: #export <sub-raw> Any)
+ (type: #export <sub> (HTML (<super-raw> <sub-raw>)))]
+
+ (~~ (template.splice <sub>+))))]
+
+ [Element Element'
+ [[Content Content']
+ [Image Image']]]
+
+ [Media Media'
+ [[Source Source']
+ [Track Track']]]
+ )
+
+ (def: #export html
+ (-> Document Text)
+ (|>> :representation))
+
+ (def: #export (and pre post)
+ (All [brand] (-> (HTML brand) (HTML brand) (HTML brand)))
+ (:abstraction (format (:representation pre) (:representation post))))
+
+ (def: #export (comment content node)
+ (All [brand] (-> Text (HTML brand) (HTML brand)))
+ (:abstraction
+ (format (text.enclose ["<!--" "-->"] content)
+ (:representation node))))
+
+ (def: (empty name attributes)
+ (-> Tag Attributes HTML)
+ (:abstraction
+ (format (..open name attributes)
+ (..close name))))
+
+ (def: (simple tag attributes)
+ (-> Tag Attributes HTML)
+ (|> attributes
+ (..open tag)
+ :abstraction))
+
+ (def: (tag name attributes content)
+ (-> Tag Attributes (HTML Any) HTML)
+ (:abstraction
+ (format (..open name attributes)
+ (:representation content)
+ (..close name))))
+
+ (def: (raw tag attributes content)
+ (-> Text Attributes Text HTML)
+ (:abstraction
+ (format (..open tag attributes)
+ content
+ (..close tag))))
+
+ (template [<name> <tag> <brand>]
+ [(def: #export <name>
+ (-> Attributes <brand>)
+ (..simple <tag>))]
+
+ [link "link" Meta]
+ [meta "meta" Meta]
+ [input "input" Input]
+ [embedded "embed" Element]
+ [column "col" Column]
+ [parameter "param" Parameter]
+ )
+
+ (def: #export (base href target)
+ (-> URL (Maybe Target) Meta)
+ (let [partial (list ["href" href])
+ full (case target
+ (#.Some target)
+ (list& ["target" (..target target)] partial)
+
+ #.None
+ partial)]
+ (..simple "base" full)))
+
+ (def: #export style
+ (-> Style Meta)
+ (|>> style.inline (..raw "style" (list))))
+
+ (def: #export (script attributes inline)
+ (-> Attributes (Maybe Script) Meta)
+ (|> inline
+ (maybe\map js.code)
+ (maybe.default "")
+ (..raw "script" attributes)))
+
+ (def: #export text
+ (-> Text Content)
+ (|>> ..sanitize
+ :abstraction))
+
+ (template [<tag> <alias> <name>]
+ [(def: #export <name>
+ Element
+ (..simple <tag> (list)))
+
+ (def: #export <alias> <name>)]
+ ["br" br line-break]
+ ["wbr" wbr word-break]
+ ["hr" hr separator]
+ )
+
+ (def: #export (image source attributes)
+ (-> URL Attributes Image)
+ (|> attributes
+ (#.Cons ["src" source])
+ (..simple "img")))
+
+ (def: #export (svg attributes content)
+ (-> Attributes XML Element)
+ (|> content
+ (\ xml.codec encode)
+ (..raw "svg" attributes)))
+
+ (type: #export Coord
+ {#horizontal Nat
+ #vertical Nat})
+
+ (def: metric-separator ",")
+ (def: coord-separator ",")
+
+ (def: (%coord [horizontal vertical])
+ (Format Coord)
+ (format (%.nat horizontal) ..metric-separator (%.nat vertical)))
+
+ (type: #export Rectangle
+ {#start Coord
+ #end Coord})
+
+ (type: #export Circle
+ {#center Coord
+ #radius Nat})
+
+ (type: #export Polygon
+ {#first Coord
+ #second Coord
+ #third Coord
+ #extra (List Coord)})
+
+ (def: (%rectangle [start end])
+ (Format Rectangle)
+ (format (%coord start) ..coord-separator (%coord end)))
+
+ (def: (%circle [center radius])
+ (Format Circle)
+ (format (%coord center) ..metric-separator (%.nat radius)))
+
+ (def: (%polygon [first second third extra])
+ (Format Polygon)
+ (|> (list& first second third extra)
+ (list\map %coord)
+ (text.join-with ..coord-separator)))
+
+ (type: #export Shape
+ (#Rectangle Rectangle)
+ (#Circle Circle)
+ (#Polygon Polygon))
+
+ (template [<name> <shape> <type> <format>]
+ [(def: (<name> attributes shape)
+ (-> Attributes <type> (HTML Any))
+ (..simple "area" (list& ["shape" <shape>]
+ ["coords" (<format> shape)]
+ attributes)))]
+
+ [rectangle "rect" Rectangle ..%rectangle]
+ [circle "circle" Circle ..%circle]
+ [polygon "poly" Polygon ..%polygon]
+ )
+
+ (def: (area attributes shape)
+ (-> Attributes Shape (HTML Any))
+ (case shape
+ (#Rectangle rectangle)
+ (..rectangle attributes rectangle)
+
+ (#Circle circle)
+ (..circle attributes circle)
+
+ (#Polygon polygon)
+ (..polygon attributes polygon)))
+
+ (def: #export (map attributes areas for)
+ (-> Attributes (List [Attributes Shape]) Image Image)
+ ($_ ..and
+ for
+ (case (list\map (product.uncurry ..area) areas)
+ #.Nil
+ (..empty "map" attributes)
+
+ (#.Cons head tail)
+ (..tag "map" attributes
+ (list\fold (function.flip ..and) head tail)))))
+
+ (template [<name> <tag> <type>]
+ [(def: #export <name>
+ (-> Attributes <type>)
+ (..empty <tag>))]
+
+ [canvas "canvas" Element]
+ [progress "progress" Element]
+ [output "output" Input]
+ [source "source" Source]
+ [track "track" Track]
+ )
+
+ (template [<name> <tag>]
+ [(def: #export (<name> attributes media on-unsupported)
+ (-> Attributes Media (Maybe Content) Element)
+ (..tag <tag> attributes
+ (|> on-unsupported
+ (maybe.default (..text ""))
+ (..and media))))]
+
+ [audio "audio"]
+ [video "video"]
+ )
+
+ (def: #export (picture attributes sources image)
+ (-> Attributes Source Image Element)
+ (..tag "picture" attributes (..and sources image)))
+
+ (def: #export (anchor href attributes content)
+ (-> URL Attributes Element Element)
+ (..tag "a" (list& ["href" href] attributes) content))
+
+ (def: #export label
+ (-> ID Input)
+ (|>> ["for"] list (..empty "label")))
+
+ (template [<name> <container-tag> <description-tag> <type>]
+ [(def: #export (<name> description attributes content)
+ (-> (Maybe Content) Attributes <type> <type>)
+ (..tag <container-tag> attributes
+ (case description
+ (#.Some description)
+ ($_ ..and
+ (..tag <description-tag> (list) description)
+ content)
+
+ #.None
+ content)))]
+
+ [details "details" "summary" Element]
+ [field-set "fieldset" "legend" Input]
+ [figure "figure" "figcaption" Element]
+ )
+
+ (template [<name> <tag> <type>]
+ [(def: #export (<name> attributes content)
+ (-> Attributes (Maybe Content) <type>)
+ (|> content
+ (maybe.default (..text ""))
+ (..tag <tag> attributes)))]
+
+ [text-area "textarea" Input]
+ [iframe "iframe" Element]
+ )
+
+ (type: #export Phrase (-> Attributes Content Element))
+
+ (template [<name> <tag>]
+ [(def: #export <name>
+ Phrase
+ (..tag <tag>))]
+
+ [abbrebiation "abbr"]
+ [block-quote "blockquote"]
+ [bold "b"]
+ [cite "cite"]
+ [code "code"]
+ [definition "dfn"]
+ [deleted "del"]
+ [emphasized "em"]
+ [h1 "h1"]
+ [h2 "h2"]
+ [h3 "h3"]
+ [h4 "h4"]
+ [h5 "h5"]
+ [h6 "h6"]
+ [inserted "ins"]
+ [italic "i"]
+ [keyboard "kbd"]
+ [marked "mark"]
+ [meter "meter"]
+ [pre "pre"]
+ [quote "q"]
+ [sample "samp"]
+ [struck "s"]
+ [small "small"]
+ [sub "sub"]
+ [super "sup"]
+ [strong "strong"]
+ [time "time"]
+ [underlined "u"]
+ [variable "var"]
+ )
+
+ (def: #export incorrect ..struck)
+
+ (def: (ruby-pronunciation pronunciation)
+ (-> Content (HTML Any))
+ (..tag "rt" (list)
+ ($_ ..and
+ (..tag "rp" (list) (..text "("))
+ pronunciation
+ (..tag "rp" (list) (..text ")")))))
+
+ (def: #export (ruby attributes content pronunciation)
+ (-> Attributes Content Content Element)
+ (..tag "ruby" attributes
+ ($_ ..and
+ content
+ (ruby-pronunciation pronunciation))))
+
+ (type: #export Composite (-> Attributes Element Element))
+
+ (template [<name> <tag>]
+ [(def: #export <name>
+ Composite
+ (..tag <tag>))]
+
+ [article "article"]
+ [aside "aside"]
+ [dialog "dialog"]
+ [div "div"]
+ [footer "footer"]
+ [header "header"]
+ [main "main"]
+ [navigation "nav"]
+ [paragraph "p"]
+ [section "section"]
+ [span "span"]
+ )
+
+ (template [<tag> <name> <input>]
+ [(def: <name>
+ (-> <input> (HTML Any))
+ (..tag <tag> (list)))]
+
+ ["dt" term Content]
+ ["dd" description Element]
+ )
+
+ (def: #export (description-list attributes descriptions)
+ (-> Attributes (List [Content Element]) Element)
+ (case (list\map (function (_ [term description])
+ ($_ ..and
+ (..term term)
+ (..description description)))
+ descriptions)
+ #.Nil
+ (..empty "dl" attributes)
+
+ (#.Cons head tail)
+ (..tag "dl" attributes
+ (list\fold (function.flip ..and) head tail))))
+
+ (def: #export p ..paragraph)
+
+ (template [<name> <tag> <input> <output>]
+ [(def: #export <name>
+ (-> Attributes <input> <output>)
+ (..tag <tag>))]
+
+ [button "button" Element Input]
+ [item "li" Element Item]
+ [ordered-list "ol" Item Element]
+ [unordered-list "ul" Item Element]
+ [option "option" Content Option]
+ [option-group "optgroup" Option Option]
+ [data-list "datalist" Option Element]
+ [select "select" Option Input]
+ [address "address" Element Element]
+ [form "form" Input Element]
+ [data "data" Element Element]
+ [object "object" Parameter Element]
+ )
+
+ (template [<name> <tag> <input> <output>]
+ [(def: #export <name>
+ (-> <input> <output>)
+ (..tag <tag> (list)))]
+
+ [title "title" Content Meta]
+ [no-script "noscript" Content Meta]
+ [template "template" (HTML Any) (HTML Nothing)]
+ [table-header "th" Element Header]
+ [table-cell "td" Element Cell]
+ [head "head" Meta Head]
+ [body "body" Element Body]
+ )
+
+ (template [<name> <tag> <input> <output>]
+ [(def: <name>
+ (-> <input> <output>)
+ (..tag <tag> (list)))]
+
+ [table-row "tr" (HTML Any) Row]
+ [table-head "thead" Row HTML]
+ [table-body "tbody" Row HTML]
+ [table-foot "tfoot" Row HTML]
+ [columns-group "colgroup" Column HTML]
+ )
+
+ (def: #export (table attributes caption columns headers rows footer)
+ (-> Attributes (Maybe Content) (Maybe Column) Header (List Cell) (Maybe Cell) Element)
+ (let [head (..table-head (..table-row headers))
+ content (case (list\map table-row rows)
+ #.Nil
+ head
+
+ (#.Cons first rest)
+ (..and head
+ (..table-body
+ (list\fold (function.flip ..and) first rest))))
+ content (case footer
+ #.None
+ content
+
+ (#.Some footer)
+ (..and content
+ (..table-foot (..table-row footer))))
+ content (case columns
+ #.None
+ content
+
+ (#.Some columns)
+ (..and (..columns-group columns)
+ content))
+ content (case caption
+ #.None
+ content
+
+ (#.Some caption)
+ (..and (:as HTML caption)
+ content))]
+ (..tag "table" attributes
+ content)))
+
+ (template [<name> <doc-type>]
+ [(def: #export <name>
+ (-> Head Body Document)
+ (let [doc-type <doc-type>]
+ (function (_ head body)
+ (|> (..tag "html" (list) (..and head body))
+ :representation
+ (format doc-type)
+ :abstraction))))]
+
+ [html-5 "<!DOCTYPE html>"]
+ [html-4_01 (format "<!DOCTYPE HTML PUBLIC " text.double-quote "-//W3C//DTD HTML 4.01//EN" text.double-quote " " text.double-quote "http://www.w3.org/TR/html4/strict.dtd" text.double-quote ">")]
+ [xhtml-1_0 (format "<!DOCTYPE html PUBLIC " text.double-quote "-//W3C//DTD XHTML 1.0 Strict//EN" text.double-quote " " text.double-quote "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd" text.double-quote ">")]
+ [xhtml-1_1 (format "<!DOCTYPE html PUBLIC " text.double-quote "-//W3C//DTD XHTML 1.1//EN" text.double-quote " " text.double-quote "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd" text.double-quote ">")]
+ )
+ )
diff --git a/stdlib/source/library/lux/data/format/json.lux b/stdlib/source/library/lux/data/format/json.lux
new file mode 100644
index 000000000..142a15610
--- /dev/null
+++ b/stdlib/source/library/lux/data/format/json.lux
@@ -0,0 +1,422 @@
+(.module: {#.doc (.doc "Functionality for reading and writing values in the JSON format."
+ "For more information, please see: http://www.json.org/")}
+ [library
+ [lux #*
+ ["." meta (#+ monad)]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [codec (#+ Codec)]
+ [predicate (#+ Predicate)]
+ ["." monad (#+ do)]]
+ [control
+ pipe
+ ["." try (#+ Try)]
+ ["<>" parser ("#\." monad)
+ ["<.>" text (#+ Parser)]]]
+ [data
+ ["." bit]
+ ["." maybe]
+ ["." product]
+ ["." text ("#\." equivalence monoid)]
+ [collection
+ ["." list ("#\." fold functor)]
+ ["." row (#+ Row row) ("#\." monad)]
+ ["." dictionary (#+ Dictionary)]]]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number
+ ["n" nat]
+ ["f" frac ("#\." decimal)]]]]])
+
+(template [<name> <type>]
+ [(type: #export <name>
+ <type>)]
+
+ [Null Any]
+ [Boolean Bit]
+ [Number Frac]
+ [String Text]
+ )
+
+(type: #export #rec JSON
+ (#Null Null)
+ (#Boolean Boolean)
+ (#Number Number)
+ (#String String)
+ (#Array (Row JSON))
+ (#Object (Dictionary String JSON)))
+
+(template [<name> <type>]
+ [(type: #export <name>
+ <type>)]
+
+ [Array (Row JSON)]
+ [Object (Dictionary String JSON)]
+ )
+
+(def: #export null?
+ (Predicate JSON)
+ (|>> (case> #Null true
+ _ false)))
+
+(def: #export object
+ (-> (List [String JSON]) JSON)
+ (|>> (dictionary.from_list text.hash) #..Object))
+
+(syntax: #export (json token)
+ {#.doc (doc "A simple way to produce JSON literals."
+ (json #null)
+ (json #1)
+ (json +123.456)
+ (json "this is a string")
+ (json ["this" "is" "an" "array"])
+ (json {"this" "is"
+ "an" "object"}))}
+ (let [(^open ".") ..monad
+ wrapper (function (_ x) (` (..json (~ x))))]
+ (case token
+ (^template [<ast_tag> <ctor> <json_tag>]
+ [[_ (<ast_tag> value)]
+ (wrap (list (` (: JSON (<json_tag> (~ (<ctor> value)))))))])
+ ([#.Bit code.bit #..Boolean]
+ [#.Frac code.frac #..Number]
+ [#.Text code.text #..String])
+
+ [_ (#.Tag ["" "null"])]
+ (wrap (list (` (: JSON #..Null))))
+
+ [_ (#.Tuple members)]
+ (wrap (list (` (: JSON (#..Array ((~! row) (~+ (list\map wrapper members))))))))
+
+ [_ (#.Record pairs)]
+ (do {! ..monad}
+ [pairs' (monad.map !
+ (function (_ [slot value])
+ (case slot
+ [_ (#.Text key_name)]
+ (wrap (` [(~ (code.text key_name)) (~ (wrapper value))]))
+
+ _
+ (meta.fail "Wrong syntax for JSON object.")))
+ pairs)]
+ (wrap (list (` (: JSON (#..Object ((~! dictionary.from_list)
+ (~! text.hash)
+ (list (~+ pairs')))))))))
+
+ _
+ (wrap (list token)))))
+
+(def: #export (fields json)
+ {#.doc "Get all the fields in a JSON object."}
+ (-> JSON (Try (List String)))
+ (case json
+ (#Object obj)
+ (#try.Success (dictionary.keys obj))
+
+ _
+ (#try.Failure ($_ text\compose "Cannot get the fields of a non-object."))))
+
+(def: #export (get key json)
+ {#.doc "A JSON object field getter."}
+ (-> String JSON (Try JSON))
+ (case json
+ (#Object obj)
+ (case (dictionary.get key obj)
+ (#.Some value)
+ (#try.Success value)
+
+ #.None
+ (#try.Failure ($_ text\compose "Missing field '" key "' on object.")))
+
+ _
+ (#try.Failure ($_ text\compose "Cannot get field '" key "' on a non-object."))))
+
+(def: #export (set key value json)
+ {#.doc "A JSON object field setter."}
+ (-> String JSON JSON (Try JSON))
+ (case json
+ (#Object obj)
+ (#try.Success (#Object (dictionary.put key value obj)))
+
+ _
+ (#try.Failure ($_ text\compose "Cannot set field '" key "' on a non-object."))))
+
+(template [<name> <tag> <type> <desc>]
+ [(def: #export (<name> key json)
+ {#.doc (code.text ($_ text\compose "A JSON object field getter for " <desc> "."))}
+ (-> Text JSON (Try <type>))
+ (case (get key json)
+ (#try.Success (<tag> value))
+ (#try.Success value)
+
+ (#try.Success _)
+ (#try.Failure ($_ text\compose "Wrong value type at key: " key))
+
+ (#try.Failure error)
+ (#try.Failure error)))]
+
+ [get_boolean #Boolean Boolean "booleans"]
+ [get_number #Number Number "numbers"]
+ [get_string #String String "strings"]
+ [get_array #Array Array "arrays"]
+ [get_object #Object Object "objects"]
+ )
+
+(implementation: #export equivalence
+ (Equivalence JSON)
+
+ (def: (= x y)
+ (case [x y]
+ [#Null #Null]
+ #1
+
+ (^template [<tag> <struct>]
+ [[(<tag> x') (<tag> y')]
+ (\ <struct> = x' y')])
+ ([#Boolean bit.equivalence]
+ [#Number f.equivalence]
+ [#String text.equivalence])
+
+ [(#Array xs) (#Array ys)]
+ (and (n.= (row.size xs) (row.size ys))
+ (list\fold (function (_ idx prev)
+ (and prev
+ (maybe.default #0
+ (do maybe.monad
+ [x' (row.nth idx xs)
+ y' (row.nth idx ys)]
+ (wrap (= x' y'))))))
+ #1
+ (list.indices (row.size xs))))
+
+ [(#Object xs) (#Object ys)]
+ (and (n.= (dictionary.size xs) (dictionary.size ys))
+ (list\fold (function (_ [xk xv] prev)
+ (and prev
+ (case (dictionary.get xk ys)
+ #.None #0
+ (#.Some yv) (= xv yv))))
+ #1
+ (dictionary.entries xs)))
+
+ _
+ #0)))
+
+############################################################
+############################################################
+############################################################
+
+(def: (format_null _)
+ (-> Null Text)
+ "null")
+
+(def: format_boolean
+ (-> Boolean Text)
+ (|>> (case>
+ #0 "false"
+ #1 "true")))
+
+(def: format_number
+ (-> Number Text)
+ (|>> (case>
+ (^or +0.0 -0.0) "0.0"
+ value (let [raw (\ f.decimal encode value)]
+ (if (f.< +0.0 value)
+ raw
+ (|> raw (text.split 1) maybe.assume product.right))))))
+
+(def: escape "\")
+(def: escaped_dq (text\compose ..escape text.double_quote))
+
+(def: format_string
+ (-> String Text)
+ (|>> (text.replace_all text.double_quote ..escaped_dq)
+ (text.enclose [text.double_quote text.double_quote])))
+
+(template [<token> <name>]
+ [(def: <name>
+ Text
+ <token>)]
+
+ ["," separator]
+ [":" entry_separator]
+
+ ["[" open_array]
+ ["]" close_array]
+
+ ["{" open_object]
+ ["}" close_object]
+ )
+
+(def: (format_array format)
+ (-> (-> JSON Text) (-> Array Text))
+ (|>> (row\map format)
+ row.to_list
+ (text.join_with ..separator)
+ (text.enclose [..open_array ..close_array])))
+
+(def: (format_kv format [key value])
+ (-> (-> JSON Text) (-> [String JSON] Text))
+ ($_ text\compose
+ (..format_string key)
+ ..entry_separator
+ (format value)
+ ))
+
+(def: (format_object format)
+ (-> (-> JSON Text) (-> Object Text))
+ (|>> dictionary.entries
+ (list\map (..format_kv format))
+ (text.join_with ..separator)
+ (text.enclose [..open_object ..close_object])))
+
+(def: #export (format json)
+ (-> JSON Text)
+ (case json
+ (^template [<tag> <format>]
+ [(<tag> value)
+ (<format> value)])
+ ([#Null ..format_null]
+ [#Boolean ..format_boolean]
+ [#Number ..format_number]
+ [#String ..format_string]
+ [#Array (..format_array format)]
+ [#Object (..format_object format)])
+ ))
+
+############################################################
+############################################################
+############################################################
+
+(def: parse_space
+ (Parser Text)
+ (<text>.some <text>.space))
+
+(def: parse_separator
+ (Parser [Text Any Text])
+ ($_ <>.and
+ ..parse_space
+ (<text>.this ..separator)
+ ..parse_space))
+
+(def: parse_null
+ (Parser Null)
+ (do <>.monad
+ [_ (<text>.this "null")]
+ (wrap [])))
+
+(template [<name> <token> <value>]
+ [(def: <name>
+ (Parser Boolean)
+ (do <>.monad
+ [_ (<text>.this <token>)]
+ (wrap <value>)))]
+
+ [parse_true "true" #1]
+ [parse_false "false" #0]
+ )
+
+(def: parse_boolean
+ (Parser Boolean)
+ ($_ <>.either
+ ..parse_true
+ ..parse_false))
+
+(def: parse_number
+ (Parser Number)
+ (do {! <>.monad}
+ [signed? (<>.parses? (<text>.this "-"))
+ digits (<text>.many <text>.decimal)
+ decimals (<>.default "0"
+ (do !
+ [_ (<text>.this ".")]
+ (<text>.many <text>.decimal)))
+ exp (<>.default ""
+ (do !
+ [mark (<text>.one_of "eE")
+ signed?' (<>.parses? (<text>.this "-"))
+ offset (<text>.many <text>.decimal)]
+ (wrap ($_ text\compose mark (if signed?' "-" "") offset))))]
+ (case (f\decode ($_ text\compose (if signed? "-" "") digits "." decimals exp))
+ (#try.Failure message)
+ (<>.fail message)
+
+ (#try.Success value)
+ (wrap value))))
+
+(def: parse_escaped
+ (Parser Text)
+ ($_ <>.either
+ (<>.after (<text>.this "\t")
+ (<>\wrap text.tab))
+ (<>.after (<text>.this "\b")
+ (<>\wrap text.back_space))
+ (<>.after (<text>.this "\n")
+ (<>\wrap text.new_line))
+ (<>.after (<text>.this "\r")
+ (<>\wrap text.carriage_return))
+ (<>.after (<text>.this "\f")
+ (<>\wrap text.form_feed))
+ (<>.after (<text>.this (text\compose "\" text.double_quote))
+ (<>\wrap text.double_quote))
+ (<>.after (<text>.this "\\")
+ (<>\wrap "\"))))
+
+(def: parse_string
+ (Parser String)
+ (<| (<text>.enclosed [text.double_quote text.double_quote])
+ (loop [_ []])
+ (do {! <>.monad}
+ [chars (<text>.some (<text>.none_of (text\compose "\" text.double_quote)))
+ stop <text>.peek])
+ (if (text\= "\" stop)
+ (do !
+ [escaped parse_escaped
+ next_chars (recur [])]
+ (wrap ($_ text\compose chars escaped next_chars)))
+ (wrap chars))))
+
+(def: (parse_kv parse_json)
+ (-> (Parser JSON) (Parser [String JSON]))
+ (do <>.monad
+ [key ..parse_string
+ _ ..parse_space
+ _ (<text>.this ..entry_separator)
+ _ ..parse_space
+ value parse_json]
+ (wrap [key value])))
+
+(template [<name> <type> <open> <close> <elem_parser> <prep>]
+ [(def: (<name> parse_json)
+ (-> (Parser JSON) (Parser <type>))
+ (do <>.monad
+ [_ (<text>.this <open>)
+ _ parse_space
+ elems (<>.separated_by ..parse_separator <elem_parser>)
+ _ parse_space
+ _ (<text>.this <close>)]
+ (wrap (<prep> elems))))]
+
+ [parse_array Array ..open_array ..close_array parse_json row.from_list]
+ [parse_object Object ..open_object ..close_object (parse_kv parse_json) (dictionary.from_list text.hash)]
+ )
+
+(def: parse_json
+ (Parser JSON)
+ (<>.rec
+ (function (_ parse_json)
+ ($_ <>.or
+ parse_null
+ parse_boolean
+ parse_number
+ parse_string
+ (parse_array parse_json)
+ (parse_object parse_json)))))
+
+(implementation: #export codec
+ (Codec Text JSON)
+
+ (def: encode ..format)
+ (def: decode (<text>.run parse_json)))
diff --git a/stdlib/source/library/lux/data/format/markdown.lux b/stdlib/source/library/lux/data/format/markdown.lux
new file mode 100644
index 000000000..05a8ed94a
--- /dev/null
+++ b/stdlib/source/library/lux/data/format/markdown.lux
@@ -0,0 +1,181 @@
+(.module:
+ [library
+ [lux (#- and)
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [type
+ abstract]
+ [world
+ [net (#+ URL)]]]])
+
+## https://www.markdownguide.org/basic-syntax/
+
+(def: sanitize
+ (-> Text Text)
+ (|>> (text.replace-all "\" "\\")
+ (text.replace-all "`" "\`")
+ (text.replace-all "*" "\*")
+ (text.replace-all "_" "\_")
+ (text.replace-all "{" "\{")
+ (text.replace-all "}" "\}")
+ (text.replace-all "[" "\[")
+ (text.replace-all "]" "\]")
+ (text.replace-all "(" "\(")
+ (text.replace-all ")" "\)")
+ (text.replace-all "#" "\#")
+ (text.replace-all "+" "\+")
+ (text.replace-all "-" "\-")
+ (text.replace-all "." "\.")
+ (text.replace-all "!" "\!")))
+
+(abstract: #export Span Any)
+(abstract: #export Block Any)
+
+(abstract: #export (Markdown brand)
+ Text
+
+ (def: #export empty
+ Markdown
+ (:abstraction ""))
+
+ (def: #export text
+ (-> Text (Markdown Span))
+ (|>> ..sanitize :abstraction))
+
+ (def: blank-line (format text.new-line text.new-line))
+
+ (template [<name> <prefix>]
+ [(def: #export (<name> content)
+ (-> Text Markdown)
+ (:abstraction (format <prefix> " " (..sanitize content) ..blank-line)))]
+
+ [heading/1 "#"]
+ [heading/2 "##"]
+ [heading/3 "###"]
+ [heading/4 "####"]
+ [heading/5 "#####"]
+ [heading/6 "######"]
+ )
+
+ (def: (block content)
+ (-> Text (Markdown Block))
+ (:abstraction (format content ..blank-line)))
+
+ (def: #export paragraph
+ (-> (Markdown Span) (Markdown Block))
+ (|>> :representation ..block))
+
+ (def: #export break
+ (Markdown Span)
+ (:abstraction (format " " text.new-line)))
+
+ (template [<name> <wrapper>]
+ [(def: #export <name>
+ (-> (Markdown Span) (Markdown Span))
+ (|>> :representation
+ (text.enclose [<wrapper> <wrapper>])
+ :abstraction))]
+
+ [bold "**"]
+ [italic "_"]
+ )
+
+ (def: (prefix with)
+ (-> Text (-> Text Text))
+ (|>> (text.split-all-with text.new-line)
+ (list\map (function (_ line)
+ (if (text.empty? line)
+ line
+ (format with line))))
+ (text.join-with text.new-line)))
+
+ (def: indent
+ (-> Text Text)
+ (..prefix text.tab))
+
+ (def: #export quote
+ (-> (Markdown Block) (Markdown Block))
+ (|>> :representation
+ (..prefix "> ")
+ :abstraction))
+
+ (def: #export numbered-list
+ (-> (List [(Markdown Span) (Maybe (Markdown Block))])
+ (Markdown Block))
+ (|>> list.enumeration
+ (list\map (function (_ [idx [summary detail]])
+ (format (%.nat (inc idx)) ". " (:representation summary) text.new-line
+ (case detail
+ (#.Some detail)
+ (|> detail :representation ..indent (text.enclose [text.new-line text.new-line]))
+
+ #.None
+ ""))))
+ (text.join-with text.new-line)
+ ..block))
+
+ (def: #export bullet-list
+ (-> (List [(Markdown Span) (Maybe (Markdown Block))])
+ (Markdown Block))
+ (|>> (list\map (function (_ [summary detail])
+ (format "*. " (:representation summary) text.new-line
+ (case detail
+ (#.Some detail)
+ (|> detail :representation ..indent (text.enclose [text.new-line text.new-line]))
+
+ #.None
+ ""))))
+ (text.join-with text.new-line)
+ ..block))
+
+ (def: #export snippet
+ {#.doc "A snippet of code."}
+ (-> Text (Markdown Span))
+ (|>> ..sanitize (text.enclose ["`" "`"]) :abstraction))
+
+ (def: #export code
+ {#.doc "A block of code."}
+ (-> Text (Markdown Block))
+ (let [open (format "```" text.new-line)
+ close (format text.new-line "```")]
+ (|>> (text.enclose [open close]) ..block)))
+
+ (def: #export (image description url)
+ (-> Text URL (Markdown Span))
+ (:abstraction (format "![" (..sanitize description) "](" url ")")))
+
+ (def: #export horizontal-rule
+ (Markdown Block)
+ (..block "___"))
+
+ (def: #export (link description url)
+ (-> (Markdown Span) URL (Markdown Span))
+ (:abstraction (format "[" (:representation description) "](" url ")")))
+
+ (type: #export Email Text)
+
+ (template [<name> <type>]
+ [(def: #export <name>
+ (-> <type> (Markdown Span))
+ (|>> (text.enclose ["<" ">"]) :abstraction))]
+
+ [url URL]
+ [email Email]
+ )
+
+ (template [<name> <brand> <infix>]
+ [(def: #export (<name> pre post)
+ (-> (Markdown <brand>) (Markdown <brand>) (Markdown <brand>))
+ (:abstraction (format (:representation pre) <infix> (:representation post))))]
+
+ [and Span " "]
+ [then Block ""]
+ )
+
+ (def: #export markdown
+ (-> (Markdown Any) Text)
+ (|>> :representation))
+ )
diff --git a/stdlib/source/library/lux/data/format/tar.lux b/stdlib/source/library/lux/data/format/tar.lux
new file mode 100644
index 000000000..f95b29334
--- /dev/null
+++ b/stdlib/source/library/lux/data/format/tar.lux
@@ -0,0 +1,871 @@
+(.module:
+ [library
+ [lux (#- Mode Name and)
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<b>" binary (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." binary (#+ Binary)]
+ ["." text (#+ Char)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ ["." format #_
+ ["#" binary (#+ Writer) ("#\." monoid)]]
+ [collection
+ ["." list ("#\." fold)]
+ ["." row (#+ Row) ("#\." fold)]]]
+ [math
+ ["." number
+ ["n" nat]
+ ["." i64]]]
+ [time
+ ["." instant (#+ Instant)]
+ ["." duration]]
+ [world
+ ["." file]]
+ [type
+ abstract]]])
+
+(type: Size Nat)
+
+(def: octal_size Size 8)
+
+(def: (octal_padding max_size number)
+ (-> Size Text Text)
+ (let [padding_size (n.- (text.size number)
+ max_size)
+ padding (|> "0"
+ (list.repeat padding_size)
+ (text.join_with ""))]
+ (format padding number)))
+
+(def: blank " ")
+(def: null text.null)
+
+(def: small_size Size 6)
+(def: big_size Size 11)
+
+(template [<exception> <limit> <size>
+ <type> <in> <out> <writer> <suffix>
+ <coercion>]
+ [(def: #export <limit>
+ Nat
+ (|> ..octal_size
+ (list.repeat <size>)
+ (list\fold n.* 1)
+ inc))
+
+ (exception: #export (<exception> {value Nat})
+ (exception.report
+ ["Value" (%.nat value)]
+ ["Maximum" (%.nat (dec <limit>))]))
+
+ (abstract: #export <type>
+ Nat
+
+ (def: #export (<in> value)
+ (-> Nat (Try <type>))
+ (if (n.< <limit> value)
+ (#try.Success (:abstraction value))
+ (exception.throw <exception> [value])))
+
+ (def: #export <out>
+ (-> <type> Nat)
+ (|>> :representation))
+
+ (def: <writer>
+ (Writer <type>)
+ (let [suffix <suffix>
+ padded_size (n.+ (text.size suffix) <size>)]
+ (|>> :representation
+ (\ n.octal encode)
+ (..octal_padding <size>)
+ (text.suffix suffix)
+ (\ utf8.codec encode)
+ (format.segment padded_size))))
+
+ (def: <coercion>
+ (-> Nat <type>)
+ (|>> (n.% <limit>)
+ :abstraction))
+ )]
+
+ [not_a_small_number small_limit ..small_size
+ Small small from_small
+ small_writer (format ..blank ..null)
+ coerce_small]
+ [not_a_big_number big_limit ..big_size
+ Big big from_big
+ big_writer ..blank
+ coerce_big]
+ )
+
+(exception: #export (wrong_character {expected Char} {actual Char})
+ (exception.report
+ ["Expected" (%.nat expected)]
+ ["Actual" (%.nat actual)]))
+
+(def: verify_small_suffix
+ (Parser Any)
+ (do <>.monad
+ [pre_end <b>.bits/8
+ end <b>.bits/8
+ _ (let [expected (`` (char (~~ (static ..blank))))]
+ (<>.assert (exception.construct ..wrong_character [expected pre_end])
+ (n.= expected pre_end)))
+ _ (let [expected (`` (char (~~ (static ..null))))]
+ (<>.assert (exception.construct ..wrong_character [expected end])
+ (n.= expected end)))]
+ (wrap [])))
+
+(def: small_parser
+ (Parser Small)
+ (do <>.monad
+ [digits (<b>.segment ..small_size)
+ digits (<>.lift (\ utf8.codec decode digits))
+ _ ..verify_small_suffix]
+ (<>.lift
+ (do {! try.monad}
+ [value (\ n.octal decode digits)]
+ (..small value)))))
+
+(def: big_parser
+ (Parser Big)
+ (do <>.monad
+ [digits (<b>.segment ..big_size)
+ digits (<>.lift (\ utf8.codec decode digits))
+ end <b>.bits/8
+ _ (let [expected (`` (char (~~ (static ..blank))))]
+ (<>.assert (exception.construct ..wrong_character [expected end])
+ (n.= expected end)))]
+ (<>.lift
+ (do {! try.monad}
+ [value (\ n.octal decode digits)]
+ (..big value)))))
+
+(abstract: Checksum
+ Text
+
+ (def: from_checksum
+ (-> Checksum Text)
+ (|>> :representation))
+
+ (def: dummy_checksum
+ Checksum
+ (:abstraction " "))
+
+ (def: checksum_suffix
+ (format ..blank ..null))
+
+ (def: checksum
+ (-> Binary Nat)
+ (binary.fold n.+ 0))
+
+ (def: checksum_checksum
+ (|> ..dummy_checksum
+ :representation
+ (\ utf8.codec encode)
+ ..checksum))
+
+ (def: checksum_code
+ (-> Binary Checksum)
+ (|>> ..checksum
+ ..coerce_small
+ ..from_small
+ (\ n.octal encode)
+ (..octal_padding ..small_size)
+ (text.suffix ..checksum_suffix)
+ :abstraction))
+
+ (def: checksum_writer
+ (Writer Checksum)
+ (let [padded_size (n.+ (text.size ..checksum_suffix)
+ ..small_size)]
+ (|>> :representation
+ (\ utf8.codec encode)
+ (format.segment padded_size))))
+
+ (def: checksum_parser
+ (Parser [Nat Checksum])
+ (do <>.monad
+ [ascii (<b>.segment ..small_size)
+ digits (<>.lift (\ utf8.codec decode ascii))
+ _ ..verify_small_suffix
+ value (<>.lift
+ (\ n.octal decode digits))]
+ (wrap [value
+ (:abstraction (format digits ..checksum_suffix))])))
+ )
+
+(def: last_ascii
+ Char
+ (number.hex "007F"))
+
+(def: ascii?
+ (-> Text Bit)
+ (|>> (\ utf8.codec encode)
+ (binary.fold (function (_ char verdict)
+ (.and verdict
+ (n.<= ..last_ascii char)))
+ true)))
+
+(exception: #export (not_ascii {text Text})
+ (exception.report
+ ["Text" (%.text text)]))
+
+(def: #export name_size Size 31)
+(def: #export path_size Size 99)
+
+(def: (un_pad string)
+ (-> Binary (Try Binary))
+ (case (binary.size string)
+ 0 (#try.Success string)
+ size (loop [end (dec size)]
+ (case end
+ 0 (#try.Success (\ utf8.codec encode ""))
+ _ (do try.monad
+ [last_char (binary.read/8 end string)]
+ (`` (case (.nat last_char)
+ (^ (char (~~ (static ..null))))
+ (recur (dec end))
+
+ _
+ (binary.slice 0 (inc end) string))))))))
+
+(template [<type> <representation> <size> <exception> <in> <out> <writer> <parser> <none>]
+ [(abstract: #export <type>
+ <representation>
+
+ (exception: #export (<exception> {value Text})
+ (exception.report
+ ["Value" (%.text value)]
+ ["Size" (%.nat (text.size value))]
+ ["Maximum" (%.nat <size>)]))
+
+ (def: #export (<in> value)
+ (-> <representation> (Try <type>))
+ (if (..ascii? value)
+ (if (|> value (\ utf8.codec encode) binary.size (n.<= <size>))
+ (#try.Success (:abstraction value))
+ (exception.throw <exception> [value]))
+ (exception.throw ..not_ascii [value])))
+
+ (def: #export <out>
+ (-> <type> <representation>)
+ (|>> :representation))
+
+ (def: <writer>
+ (Writer <type>)
+ (let [suffix ..null
+ padded_size (n.+ (text.size suffix) <size>)]
+ (|>> :representation
+ (text.suffix suffix)
+ (\ utf8.codec encode)
+ (format.segment padded_size))))
+
+ (def: <parser>
+ (Parser <type>)
+ (do <>.monad
+ [string (<b>.segment <size>)
+ end <b>.bits/8
+ #let [expected (`` (char (~~ (static ..null))))]
+ _ (<>.assert (exception.construct ..wrong_character [expected end])
+ (n.= expected end))]
+ (<>.lift
+ (do {! try.monad}
+ [ascii (..un_pad string)
+ text (\ utf8.codec decode ascii)]
+ (<in> text)))))
+
+ (def: #export <none>
+ <type>
+ (try.assume (<in> "")))
+ )]
+
+ [Name Text ..name_size name_is_too_long name from_name name_writer name_parser anonymous]
+ [Path file.Path ..path_size path_is_too_long path from_path path_writer path_parser no_path]
+ )
+
+(def: magic_size Size 7)
+
+(abstract: Magic
+ Text
+
+ (def: ustar (:abstraction "ustar "))
+
+ (def: from_magic
+ (-> Magic Text)
+ (|>> :representation))
+
+ (def: magic_writer
+ (Writer Magic)
+ (let [padded_size (n.+ (text.size ..null)
+ ..magic_size)]
+ (|>> :representation
+ (\ utf8.codec encode)
+ (format.segment padded_size))))
+
+ (def: magic_parser
+ (Parser Magic)
+ (do <>.monad
+ [string (<b>.segment ..magic_size)
+ end <b>.bits/8
+ #let [expected (`` (char (~~ (static ..null))))]
+ _ (<>.assert (exception.construct ..wrong_character [expected end])
+ (n.= expected end))]
+ (<>.lift
+ (\ try.monad map (|>> :abstraction)
+ (\ utf8.codec decode string)))))
+ )
+
+(def: block_size Size 512)
+
+(def: owner_id_size ..small_size)
+
+(def: blank_size Size (text.size ..blank))
+(def: null_size Size (text.size ..null))
+(def: mode_size Size ..small_size)
+(def: content_size Size ..big_size)
+(def: modification_time_size Size ..big_size)
+(def: checksum_size Size ..small_size)
+(def: link_flag_size Size 1)
+(def: device_size Size ..small_size)
+
+(def: small_number
+ (-> Size Size)
+ (|>> ($_ n.+ ..blank_size ..null_size)))
+
+(def: big_number
+ (-> Size Size)
+ (|>> ($_ n.+ ..blank_size)))
+
+(def: string
+ (-> Size Size)
+ (|>> ($_ n.+ ..null_size)))
+
+(def: header_size
+ ($_ n.+
+ ## name
+ (..string ..path_size)
+ ## mode
+ (..small_number ..mode_size)
+ ## uid
+ (..small_number ..owner_id_size)
+ ## gid
+ (..small_number ..owner_id_size)
+ ## size
+ (..big_number ..content_size)
+ ## mtime
+ (..big_number ..modification_time_size)
+ ## chksum
+ (..small_number ..checksum_size)
+ ## linkflag
+ ..link_flag_size
+ ## linkname
+ (..string ..path_size)
+ ## magic
+ (..string ..magic_size)
+ ## uname
+ (..string ..name_size)
+ ## gname
+ (..string ..name_size)
+ ## devmajor
+ (..small_number ..device_size)
+ ## devminor
+ (..small_number ..device_size)))
+
+(abstract: Link_Flag
+ Char
+
+ (def: link_flag
+ (-> Link_Flag Char)
+ (|>> :representation))
+
+ (def: link_flag_writer
+ (Writer Link_Flag)
+ (|>> :representation
+ format.bits/8))
+
+ (with_expansions [<options> (as_is [0 old_normal]
+ [(char "0") normal]
+ [(char "1") link]
+ [(char "2") symbolic_link]
+ [(char "3") character]
+ [(char "4") block]
+ [(char "5") directory]
+ [(char "6") fifo]
+ [(char "7") contiguous])]
+ (template [<flag> <name>]
+ [(def: <name>
+ Link_Flag
+ (:abstraction <flag>))]
+
+ <options>
+ )
+
+ (exception: #export (invalid_link_flag {value Nat})
+ (exception.report
+ ["Value" (%.nat value)]))
+
+ (def: link_flag_parser
+ (Parser Link_Flag)
+ (do <>.monad
+ [linkflag <b>.bits/8]
+ (case (.nat linkflag)
+ (^template [<value> <link_flag>]
+ [(^ <value>)
+ (wrap <link_flag>)])
+ (<options>)
+
+ _
+ (<>.lift
+ (exception.throw ..invalid_link_flag [(.nat linkflag)]))))))
+ )
+
+(abstract: #export Mode
+ Nat
+
+ (def: #export mode
+ (-> Mode Nat)
+ (|>> :representation))
+
+ (def: #export (and left right)
+ (-> Mode Mode Mode)
+ (:abstraction
+ (i64.or (:representation left)
+ (:representation right))))
+
+ (def: mode_writer
+ (Writer Mode)
+ (|>> :representation
+ ..small
+ try.assume
+ ..small_writer))
+
+ (exception: #export (invalid_mode {value Nat})
+ (exception.report
+ ["Value" (%.nat value)]))
+
+ (with_expansions [<options> (as_is ["0000" none]
+
+ ["0001" execute_by_other]
+ ["0002" write_by_other]
+ ["0004" read_by_other]
+
+ ["0010" execute_by_group]
+ ["0020" write_by_group]
+ ["0040" read_by_group]
+
+ ["0100" execute_by_owner]
+ ["0200" write_by_owner]
+ ["0400" read_by_owner]
+
+ ["1000" save_text]
+ ["2000" set_group_id_on_execution]
+ ["4000" set_user_id_on_execution])]
+ (template [<code> <name>]
+ [(def: #export <name>
+ Mode
+ (:abstraction (number.oct <code>)))]
+
+ <options>
+ )
+
+ (def: maximum_mode
+ Mode
+ ($_ and
+ ..none
+
+ ..execute_by_other
+ ..write_by_other
+ ..read_by_other
+
+ ..execute_by_group
+ ..write_by_group
+ ..read_by_group
+
+ ..execute_by_owner
+ ..write_by_owner
+ ..read_by_owner
+
+ ..save_text
+ ..set_group_id_on_execution
+ ..set_user_id_on_execution
+ ))
+
+ (def: mode_parser
+ (Parser Mode)
+ (do {! <>.monad}
+ [value (\ ! map ..from_small ..small_parser)]
+ (if (n.<= (:representation ..maximum_mode)
+ value)
+ (wrap (:abstraction value))
+ (<>.lift
+ (exception.throw ..invalid_mode [value]))))))
+ )
+
+(def: maximum_content_size
+ Nat
+ (|> ..octal_size
+ (list.repeat ..content_size)
+ (list\fold n.* 1)))
+
+(abstract: #export Content
+ [Big Binary]
+
+ (def: #export (content content)
+ (-> Binary (Try Content))
+ (do try.monad
+ [size (..big (binary.size content))]
+ (wrap (:abstraction [size content]))))
+
+ (def: from_content
+ (-> Content [Big Binary])
+ (|>> :representation))
+
+ (def: #export data
+ (-> Content Binary)
+ (|>> :representation product.right))
+ )
+
+(type: #export ID
+ Small)
+
+(def: #export no_id
+ ID
+ (..coerce_small 0))
+
+(type: #export Owner
+ {#name Name
+ #id ID})
+
+(type: #export Ownership
+ {#user Owner
+ #group Owner})
+
+(type: #export File
+ [Path Instant Mode Ownership Content])
+
+(type: #export Normal File)
+(type: #export Symbolic_Link Path)
+(type: #export Directory Path)
+(type: #export Contiguous File)
+
+(type: #export Entry
+ (#Normal ..Normal)
+ (#Symbolic_Link ..Symbolic_Link)
+ (#Directory ..Directory)
+ (#Contiguous ..Contiguous))
+
+(type: Device
+ Small)
+
+(def: no_device
+ Device
+ (try.assume (..small 0)))
+
+(type: #export Tar
+ (Row Entry))
+
+(def: (blocks size)
+ (-> Big Nat)
+ (n.+ (n./ ..block_size
+ (..from_big size))
+ (case (n.% ..block_size (..from_big size))
+ 0 0
+ _ 1)))
+
+(def: rounded_content_size
+ (-> Big Nat)
+ (|>> ..blocks
+ (n.* ..block_size)))
+
+(type: Header
+ {#path Path
+ #mode Mode
+ #user_id ID
+ #group_id ID
+ #size Big
+ #modification_time Big
+ #checksum Checksum
+ #link_flag Link_Flag
+ #link_name Path
+ #magic Magic
+ #user_name Name
+ #group_name Name
+ #major_device Device
+ #minor_device Device})
+
+(def: header_writer'
+ (Writer Header)
+ ($_ format.and
+ ..path_writer
+ ..mode_writer
+ ..small_writer
+ ..small_writer
+ ..big_writer
+ ..big_writer
+ ..checksum_writer
+ ..link_flag_writer
+ ..path_writer
+ ..magic_writer
+ ..name_writer
+ ..name_writer
+ ..small_writer
+ ..small_writer
+ ))
+
+(def: (header_writer header)
+ (Writer Header)
+ (let [checksum (|> header
+ (set@ #checksum ..dummy_checksum)
+ (format.run ..header_writer')
+ ..checksum_code)]
+ (|> header
+ (set@ #checksum checksum)
+ (format.run ..header_writer')
+ (format.segment ..block_size))))
+
+(def: modification_time
+ (-> Instant Big)
+ (|>> instant.relative
+ (duration.query duration.second)
+ .nat
+ ..coerce_big))
+
+(def: (file_writer link_flag)
+ (-> Link_Flag (Writer File))
+ (function (_ [path modification_time mode ownership content])
+ (let [[size content] (..from_content content)
+ writer ($_ format.and
+ ..header_writer
+ (format.segment (..rounded_content_size size)))]
+ (writer [{#path path
+ #mode mode
+ #user_id (get@ [#user #id] ownership)
+ #group_id (get@ [#group #id] ownership)
+ #size size
+ #modification_time (..modification_time modification_time)
+ #checksum ..dummy_checksum
+ #link_flag link_flag
+ #link_name ..no_path
+ #magic ..ustar
+ #user_name (get@ [#user #name] ownership)
+ #group_name (get@ [#group #name] ownership)
+ #major_device ..no_device
+ #minor_device ..no_device}
+ content]))))
+
+(def: normal_file_writer
+ (Writer File)
+ (..file_writer ..normal))
+
+(def: contiguous_file_writer
+ (Writer File)
+ (..file_writer ..contiguous))
+
+(def: (symbolic_link_writer path)
+ (Writer Path)
+ (..header_writer
+ {#path ..no_path
+ #mode ..none
+ #user_id ..no_id
+ #group_id ..no_id
+ #size (..coerce_big 0)
+ #modification_time (..coerce_big 0)
+ #checksum ..dummy_checksum
+ #link_flag ..symbolic_link
+ #link_name path
+ #magic ..ustar
+ #user_name ..anonymous
+ #group_name ..anonymous
+ #major_device ..no_device
+ #minor_device ..no_device}))
+
+(def: (directory_writer path)
+ (Writer Path)
+ (..header_writer
+ {#path path
+ #mode ..none
+ #user_id ..no_id
+ #group_id ..no_id
+ #size (..coerce_big 0)
+ #modification_time (..coerce_big 0)
+ #checksum ..dummy_checksum
+ #link_flag ..directory
+ #link_name ..no_path
+ #magic ..ustar
+ #user_name ..anonymous
+ #group_name ..anonymous
+ #major_device ..no_device
+ #minor_device ..no_device}))
+
+(def: entry_writer
+ (Writer Entry)
+ (|>> (case> (#Normal value) (..normal_file_writer value)
+ (#Symbolic_Link value) (..symbolic_link_writer value)
+ (#Directory value) (..directory_writer value)
+ (#Contiguous value) (..contiguous_file_writer value))))
+
+(def: end_of_archive_size Size (n.* 2 ..block_size))
+
+(def: #export writer
+ (Writer Tar)
+ (let [end_of_archive (binary.create ..end_of_archive_size)]
+ (function (_ tar)
+ (format\compose (row\fold (function (_ next total)
+ (format\compose total (..entry_writer next)))
+ format\identity
+ tar)
+ (format.segment ..end_of_archive_size end_of_archive)))))
+
+(exception: #export (wrong_checksum {expected Nat} {actual Nat})
+ (exception.report
+ ["Expected" (%.nat expected)]
+ ["Actual" (%.nat actual)]))
+
+(def: header_padding_size
+ (n.- header_size block_size))
+
+## When the checksum gets originally calculated, the assumption is that all the characters in the checksum field
+## of the header will be spaces.
+## This means that just calculating the checksum of the 512 bytes of the header, when reading them, would yield
+## an incorrect result, as the contents of the checksum field would be an actual checksum, instead of just spaces.
+## To correct for this, it is necessary to calculate the checksum of just the checksum field, subtract that, and then
+## add-in the checksum of the spaces.
+(def: (expected_checksum checksum header)
+ (-> Checksum Binary Nat)
+ (let [|checksum| (|> checksum
+ ..from_checksum
+ (\ utf8.codec encode)
+ ..checksum)]
+ (|> (..checksum header)
+ (n.- |checksum|)
+ (n.+ ..checksum_checksum))))
+
+(def: header_parser
+ (Parser Header)
+ (do <>.monad
+ [binary_header (<>.speculative (<b>.segment block_size))
+ path ..path_parser
+ mode ..mode_parser
+ user_id ..small_parser
+ group_id ..small_parser
+ size ..big_parser
+ modification_time ..big_parser
+ [actual checksum_code] ..checksum_parser
+ _ (let [expected (expected_checksum checksum_code binary_header)]
+ (<>.lift
+ (exception.assert ..wrong_checksum [expected actual]
+ (n.= expected actual))))
+ link_flag ..link_flag_parser
+ link_name ..path_parser
+ magic ..magic_parser
+ user_name ..name_parser
+ group_name ..name_parser
+ major_device ..small_parser
+ minor_device ..small_parser
+ _ (<b>.segment ..header_padding_size)]
+ (wrap {#path path
+ #mode mode
+ #user_id user_id
+ #group_id group_id
+ #size size
+ #modification_time modification_time
+ #checksum checksum_code
+ #link_flag link_flag
+ #link_name link_name
+ #magic magic
+ #user_name user_name
+ #group_name group_name
+ #major_device major_device
+ #minor_device minor_device})))
+
+(exception: #export (wrong_link_flag {expected Link_Flag} {actual Link_Flag})
+ (exception.report
+ ["Expected" (%.nat (..link_flag expected))]
+ ["Actual" (%.nat (..link_flag actual))]))
+
+(def: (file_parser expected)
+ (-> Link_Flag (Parser File))
+ (do <>.monad
+ [header ..header_parser
+ _ (<>.assert (exception.construct ..wrong_link_flag [expected (get@ #link_flag header)])
+ (is? expected (get@ #link_flag header)))
+ #let [size (get@ #size header)
+ rounded_size (..rounded_content_size size)]
+ content (<b>.segment (..from_big size))
+ content (<>.lift (..content content))
+ _ (<b>.segment (n.- (..from_big size) rounded_size))]
+ (wrap [(get@ #path header)
+ (|> header
+ (get@ #modification_time)
+ ..from_big
+ .int
+ duration.from_millis
+ (duration.up (|> duration.second duration.to_millis .nat))
+ instant.absolute)
+ (get@ #mode header)
+ {#user {#name (get@ #user_name header)
+ #id (get@ #user_id header)}
+ #group {#name (get@ #group_name header)
+ #id (get@ #group_id header)}}
+ content])))
+
+(def: (file_name_parser expected extractor)
+ (-> Link_Flag (-> Header Path) (Parser Path))
+ (do <>.monad
+ [header ..header_parser
+ _ (<>.lift
+ (exception.assert ..wrong_link_flag [expected (get@ #link_flag header)]
+ (n.= (..link_flag expected)
+ (..link_flag (get@ #link_flag header)))))]
+ (wrap (extractor header))))
+
+(def: entry_parser
+ (Parser Entry)
+ ($_ <>.either
+ (\ <>.monad map (|>> #..Normal)
+ (<>.either (..file_parser ..normal)
+ (..file_parser ..old_normal)))
+ (\ <>.monad map (|>> #..Symbolic_Link)
+ (..file_name_parser ..symbolic_link (get@ #link_name)))
+ (\ <>.monad map (|>> #..Directory)
+ (..file_name_parser ..directory (get@ #path)))
+ (\ <>.monad map (|>> #..Contiguous)
+ (..file_parser ..contiguous))))
+
+## It's safe to implement the parser this way because the range of values for Nat is 2^64
+## Whereas the maximum possible value for the checksum of a 512 block is (256 × 512) = 131,072
+(def: end_of_archive_block_parser
+ (Parser Any)
+ (do <>.monad
+ [block (<b>.segment ..block_size)]
+ (let [actual (..checksum block)]
+ (<>.lift
+ (exception.assert ..wrong_checksum [0 actual]
+ (n.= 0 actual))))))
+
+(exception: #export invalid_end_of_archive)
+
+(def: end_of_archive_parser
+ (Parser Any)
+ (do <>.monad
+ [_ (<>.at_most 2 end_of_archive_block_parser)
+ done? <b>.end?]
+ (<>.lift
+ (exception.assert ..invalid_end_of_archive []
+ done?))))
+
+(def: #export parser
+ (Parser Tar)
+ (|> (<>.some entry_parser)
+ (\ <>.monad map row.from_list)
+ (<>.before ..end_of_archive_parser)))
diff --git a/stdlib/source/library/lux/data/format/xml.lux b/stdlib/source/library/lux/data/format/xml.lux
new file mode 100644
index 000000000..56d394490
--- /dev/null
+++ b/stdlib/source/library/lux/data/format/xml.lux
@@ -0,0 +1,299 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]
+ [equivalence (#+ Equivalence)]
+ [codec (#+ Codec)]]
+ [control
+ [try (#+ Try)]
+ ["<>" parser ("#\." monad)
+ ["<.>" text (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." name ("#\." equivalence codec)]
+ ["." text ("#\." equivalence monoid)]
+ [collection
+ ["." list ("#\." functor)]
+ ["." dictionary (#+ Dictionary)]]]
+ [math
+ [number
+ ["n" nat]
+ ["." int]]]]])
+
+(type: #export Tag
+ Name)
+
+(type: #export Attribute
+ Name)
+
+(type: #export Attrs
+ (Dictionary Attribute Text))
+
+(def: #export attributes
+ Attrs
+ (dictionary.new name.hash))
+
+(type: #export #rec XML
+ (#Text Text)
+ (#Node Tag Attrs (List XML)))
+
+(def: namespace_separator
+ ":")
+
+(def: xml_standard_escape_char^
+ (Parser Text)
+ ($_ <>.either
+ (<>.after (<text>.this "&lt;") (<>\wrap "<"))
+ (<>.after (<text>.this "&gt;") (<>\wrap ">"))
+ (<>.after (<text>.this "&amp;") (<>\wrap "&"))
+ (<>.after (<text>.this "&apos;") (<>\wrap "'"))
+ (<>.after (<text>.this "&quot;") (<>\wrap text.double_quote))
+ ))
+
+(def: xml_unicode_escape_char^
+ (Parser Text)
+ (|> (do <>.monad
+ [hex? (<>.maybe (<text>.this "x"))
+ code (case hex?
+ #.None
+ (<>.codec int.decimal (<text>.many <text>.decimal))
+
+ (#.Some _)
+ (<>.codec int.decimal (<text>.many <text>.hexadecimal)))]
+ (wrap (|> code .nat text.from_code)))
+ (<>.before (<text>.this ";"))
+ (<>.after (<text>.this "&#"))))
+
+(def: xml_escape_char^
+ (Parser Text)
+ (<>.either xml_standard_escape_char^
+ xml_unicode_escape_char^))
+
+(def: xml_char^
+ (Parser Text)
+ (<>.either (<text>.none_of ($_ text\compose "<>&" text.double_quote))
+ xml_escape_char^))
+
+(def: xml_identifier
+ (Parser Text)
+ (do <>.monad
+ [head (<>.either (<text>.one_of "_")
+ <text>.alpha)
+ tail (<text>.some (<>.either (<text>.one_of "_.-")
+ <text>.alpha_num))]
+ (wrap ($_ text\compose head tail))))
+
+(def: namespaced_symbol^
+ (Parser Name)
+ (do <>.monad
+ [first_part xml_identifier
+ ?second_part (<| <>.maybe (<>.after (<text>.this ..namespace_separator)) xml_identifier)]
+ (case ?second_part
+ #.None
+ (wrap ["" first_part])
+
+ (#.Some second_part)
+ (wrap [first_part second_part]))))
+
+(def: tag^ namespaced_symbol^)
+(def: attr_name^ namespaced_symbol^)
+
+(def: spaced^
+ (All [a] (-> (Parser a) (Parser a)))
+ (let [white_space^ (<>.some <text>.space)]
+ (|>> (<>.before white_space^)
+ (<>.after white_space^))))
+
+(def: attr_value^
+ (Parser Text)
+ (let [value^ (<text>.some xml_char^)]
+ (<>.either (<text>.enclosed [text.double_quote text.double_quote] value^)
+ (<text>.enclosed ["'" "'"] value^))))
+
+(def: attrs^
+ (Parser Attrs)
+ (<| (\ <>.monad map (dictionary.from_list name.hash))
+ <>.some
+ (<>.and (..spaced^ attr_name^))
+ (<>.after (<text>.this "="))
+ (..spaced^ attr_value^)))
+
+(def: (close_tag^ expected)
+ (-> Tag (Parser []))
+ (do <>.monad
+ [actual (|> tag^
+ ..spaced^
+ (<>.after (<text>.this "/"))
+ (<text>.enclosed ["<" ">"]))]
+ (<>.assert ($_ text\compose "Close tag does not match open tag." text.new_line
+ "Expected: " (name\encode expected) text.new_line
+ " Actual: " (name\encode actual) text.new_line)
+ (name\= expected actual))))
+
+(def: comment^
+ (Parser Text)
+ (|> (<text>.not (<text>.this "--"))
+ <text>.some
+ (<text>.enclosed ["<!--" "-->"])
+ ..spaced^))
+
+(def: xml_header^
+ (Parser Attrs)
+ (|> (..spaced^ attrs^)
+ (<>.before (<text>.this "?>"))
+ (<>.after (<text>.this "<?xml"))
+ ..spaced^))
+
+(def: cdata^
+ (Parser Text)
+ (let [end (<text>.this "]]>")]
+ (|> (<text>.some (<text>.not end))
+ (<>.after end)
+ (<>.after (<text>.this "<![CDATA["))
+ ..spaced^)))
+
+(def: text^
+ (Parser XML)
+ (|> (..spaced^ (<text>.many xml_char^))
+ (<>.either cdata^)
+ (<>\map (|>> #Text))))
+
+(def: null^
+ (Parser Any)
+ (<text>.this (text.from_code 0)))
+
+(def: xml^
+ (Parser XML)
+ (|> (<>.rec
+ (function (_ node^)
+ (|> (do <>.monad
+ [_ (<text>.this "<")
+ tag (..spaced^ tag^)
+ attrs (..spaced^ attrs^)
+ #let [no_children^ ($_ <>.either
+ (do <>.monad
+ [_ (<text>.this "/>")]
+ (wrap (#Node tag attrs (list))))
+ (do <>.monad
+ [_ (<text>.this ">")
+ _ (<>.some (<>.either <text>.space
+ ..comment^))
+ _ (..close_tag^ tag)]
+ (wrap (#Node tag attrs (list)))))
+ with_children^ (do <>.monad
+ [_ (<text>.this ">")
+ children (<>.many node^)
+ _ (..close_tag^ tag)]
+ (wrap (#Node tag attrs children)))]]
+ ($_ <>.either
+ no_children^
+ with_children^))
+ ..spaced^
+ (<>.before (<>.some ..comment^))
+ (<>.after (<>.some ..comment^))
+ (<>.either ..text^))))
+ (<>.before (<>.some ..null^))
+ (<>.after (<>.maybe ..xml_header^))))
+
+(def: read
+ (-> Text (Try XML))
+ (<text>.run xml^))
+
+(def: (sanitize_value input)
+ (-> Text Text)
+ (|> input
+ (text.replace_all "&" "&amp;")
+ (text.replace_all "<" "&lt;")
+ (text.replace_all ">" "&gt;")
+ (text.replace_all "'" "&apos;")
+ (text.replace_all text.double_quote "&quot;")))
+
+(def: #export (tag [namespace name])
+ (-> Tag Text)
+ (case namespace
+ "" name
+ _ ($_ text\compose namespace ..namespace_separator name)))
+
+(def: #export attribute
+ (-> Attribute Text)
+ ..tag)
+
+(def: (write_attrs attrs)
+ (-> Attrs Text)
+ (|> attrs
+ dictionary.entries
+ (list\map (function (_ [key value])
+ ($_ text\compose (..attribute key) "=" text.double_quote (sanitize_value value) text.double_quote)))
+ (text.join_with " ")))
+
+(def: xml_header
+ Text
+ (let [quote (: (-> Text Text)
+ (function (_ value)
+ ($_ text\compose text.double_quote value text.double_quote)))]
+ ($_ text\compose
+ "<?xml"
+ " version=" (quote "1.0")
+ " encoding=" (quote "UTF-8")
+ "?>")))
+
+(def: (write input)
+ (-> XML Text)
+ ($_ text\compose
+ ..xml_header text.new_line
+ (loop [prefix ""
+ input input]
+ (case input
+ (#Text value)
+ (sanitize_value value)
+
+ (^ (#Node xml_tag xml_attrs (list (#Text value))))
+ (let [tag (..tag xml_tag)
+ attrs (if (dictionary.empty? xml_attrs)
+ ""
+ ($_ text\compose " " (..write_attrs xml_attrs)))]
+ ($_ text\compose
+ prefix "<" tag attrs ">"
+ (sanitize_value value)
+ "</" tag ">"))
+
+ (#Node xml_tag xml_attrs xml_children)
+ (let [tag (..tag xml_tag)
+ attrs (if (dictionary.empty? xml_attrs)
+ ""
+ ($_ text\compose " " (..write_attrs xml_attrs)))]
+ (if (list.empty? xml_children)
+ ($_ text\compose prefix "<" tag attrs "/>")
+ ($_ text\compose prefix "<" tag attrs ">"
+ (|> xml_children
+ (list\map (|>> (recur (text\compose prefix text.tab)) (text\compose text.new_line)))
+ (text.join_with ""))
+ text.new_line prefix "</" tag ">")))))
+ ))
+
+(implementation: #export codec
+ (Codec Text XML)
+
+ (def: encode ..write)
+ (def: decode ..read))
+
+(implementation: #export equivalence
+ (Equivalence XML)
+
+ (def: (= reference sample)
+ (case [reference sample]
+ [(#Text reference/value) (#Text sample/value)]
+ (text\= reference/value sample/value)
+
+ [(#Node reference/tag reference/attrs reference/children)
+ (#Node sample/tag sample/attrs sample/children)]
+ (and (name\= reference/tag sample/tag)
+ (\ (dictionary.equivalence text.equivalence) = reference/attrs sample/attrs)
+ (n.= (list.size reference/children)
+ (list.size sample/children))
+ (|> (list.zip/2 reference/children sample/children)
+ (list.every? (product.uncurry =))))
+
+ _
+ false)))
diff --git a/stdlib/source/library/lux/data/identity.lux b/stdlib/source/library/lux/data/identity.lux
new file mode 100644
index 000000000..c0a39ab5e
--- /dev/null
+++ b/stdlib/source/library/lux/data/identity.lux
@@ -0,0 +1,38 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ [monad (#+ Monad)]
+ [comonad (#+ CoMonad)]]
+ [control
+ ["." function]]]])
+
+(type: #export (Identity a)
+ a)
+
+(implementation: #export functor
+ (Functor Identity)
+
+ (def: map function.identity))
+
+(implementation: #export apply
+ (Apply Identity)
+
+ (def: &functor ..functor)
+ (def: (apply ff fa) (ff fa)))
+
+(implementation: #export monad
+ (Monad Identity)
+
+ (def: &functor ..functor)
+ (def: wrap function.identity)
+ (def: join function.identity))
+
+(implementation: #export comonad
+ (CoMonad Identity)
+
+ (def: &functor ..functor)
+ (def: unwrap function.identity)
+ (def: split function.identity))
diff --git a/stdlib/source/library/lux/data/lazy.lux b/stdlib/source/library/lux/data/lazy.lux
new file mode 100644
index 000000000..c9a6ae18c
--- /dev/null
+++ b/stdlib/source/library/lux/data/lazy.lux
@@ -0,0 +1,68 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ [monad (#+ Monad do)]
+ [equivalence (#+ Equivalence)]]
+ [control
+ ["." io]
+ [parser
+ ["s" code]]
+ [concurrency
+ ["." atom]]]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]]
+ [type
+ abstract]]])
+
+(abstract: #export (Lazy a)
+ (-> [] a)
+
+ (def: (freeze' generator)
+ (All [a] (-> (-> [] a) (Lazy a)))
+ (let [cache (atom.atom #.None)]
+ (:abstraction (function (_ _)
+ (case (io.run (atom.read cache))
+ (#.Some value)
+ value
+
+ _
+ (let [value (generator [])]
+ (exec (io.run (atom.compare_and_swap _ (#.Some value) cache))
+ value)))))))
+
+ (def: #export (thaw l_value)
+ (All [a] (-> (Lazy a) a))
+ ((:representation l_value) [])))
+
+(syntax: #export (freeze expr)
+ (with_gensyms [g!_]
+ (wrap (list (` ((~! freeze') (function ((~ g!_) (~ g!_)) (~ expr))))))))
+
+(implementation: #export (equivalence (^open "_\."))
+ (All [a] (-> (Equivalence a) (Equivalence (Lazy a))))
+
+ (def: (= left right)
+ (_\= (..thaw left) (..thaw right))))
+
+(implementation: #export functor
+ (Functor Lazy)
+
+ (def: (map f fa)
+ (freeze (f (thaw fa)))))
+
+(implementation: #export apply
+ (Apply Lazy)
+
+ (def: &functor ..functor)
+ (def: (apply ff fa)
+ (freeze ((thaw ff) (thaw fa)))))
+
+(implementation: #export monad
+ (Monad Lazy)
+
+ (def: &functor ..functor)
+ (def: wrap (|>> freeze))
+ (def: join thaw))
diff --git a/stdlib/source/library/lux/data/maybe.lux b/stdlib/source/library/lux/data/maybe.lux
new file mode 100644
index 000000000..d7f010f13
--- /dev/null
+++ b/stdlib/source/library/lux/data/maybe.lux
@@ -0,0 +1,151 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monoid (#+ Monoid)]
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]
+ [apply (#+ Apply)]
+ ["." functor (#+ Functor)]
+ ["." monad (#+ Monad do)]]
+ [meta
+ ["." location]]]])
+
+## (type: (Maybe a)
+## #.None
+## (#.Some a))
+
+(implementation: #export monoid
+ (All [a] (Monoid (Maybe a)))
+
+ (def: identity #.None)
+
+ (def: (compose mx my)
+ (case mx
+ #.None
+ my
+
+ (#.Some x)
+ (#.Some x))))
+
+(implementation: #export functor
+ (Functor Maybe)
+
+ (def: (map f ma)
+ (case ma
+ #.None #.None
+ (#.Some a) (#.Some (f a)))))
+
+(implementation: #export apply
+ (Apply Maybe)
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (case [ff fa]
+ [(#.Some f) (#.Some a)]
+ (#.Some (f a))
+
+ _
+ #.None)))
+
+(implementation: #export monad
+ (Monad Maybe)
+
+ (def: &functor ..functor)
+
+ (def: (wrap x)
+ (#.Some x))
+
+ (def: (join mma)
+ (case mma
+ #.None
+ #.None
+
+ (#.Some mx)
+ mx)))
+
+(implementation: #export (equivalence super)
+ (All [a] (-> (Equivalence a) (Equivalence (Maybe a))))
+
+ (def: (= mx my)
+ (case [mx my]
+ [#.None #.None]
+ #1
+
+ [(#.Some x) (#.Some y)]
+ (\ super = x y)
+
+ _
+ #0)))
+
+(implementation: #export (hash super)
+ (All [a] (-> (Hash a) (Hash (Maybe a))))
+
+ (def: &equivalence
+ (..equivalence (\ super &equivalence)))
+
+ (def: (hash value)
+ (case value
+ #.None
+ 0
+
+ (#.Some value)
+ (\ super hash value))))
+
+(implementation: #export (with monad)
+ (All [M] (-> (Monad M) (Monad (All [a] (M (Maybe a))))))
+
+ (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor))
+
+ (def: wrap (|>> (\ ..monad wrap) (\ monad wrap)))
+
+ (def: (join MmMma)
+ (do monad
+ [mMma MmMma]
+ (case mMma
+ #.None
+ (wrap #.None)
+
+ (#.Some Mma)
+ Mma))))
+
+(def: #export (lift monad)
+ (All [M a] (-> (Monad M) (-> (M a) (M (Maybe a)))))
+ (\ monad map (\ ..monad wrap)))
+
+(macro: #export (default tokens state)
+ {#.doc (doc "Allows you to provide a default value that will be used"
+ "if a (Maybe x) value turns out to be #.None."
+ "Note: the expression for the default value will not be computed if the base computation succeeds."
+ (default +20 (#.Some +10))
+ "=>"
+ +10
+ (default +20 #.None)
+ "=>"
+ +20)}
+ (case tokens
+ (^ (list else maybe))
+ (let [g!temp (: Code [location.dummy (#.Identifier ["" ""])])]
+ (#.Right [state (list (` (case (~ maybe)
+ (#.Some (~ g!temp))
+ (~ g!temp)
+
+ #.None
+ (~ else))))]))
+
+ _
+ (#.Left "Wrong syntax for default")))
+
+(def: #export assume
+ (All [a] (-> (Maybe a) a))
+ (|>> (..default (undefined))))
+
+(def: #export (to-list value)
+ (All [a] (-> (Maybe a) (List a)))
+ (case value
+ #.None
+ #.Nil
+
+ (#.Some value)
+ (#.Cons value #.Nil)))
diff --git a/stdlib/source/library/lux/data/name.lux b/stdlib/source/library/lux/data/name.lux
new file mode 100644
index 000000000..6a89a1aa6
--- /dev/null
+++ b/stdlib/source/library/lux/data/name.lux
@@ -0,0 +1,64 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]
+ [order (#+ Order)]
+ [codec (#+ Codec)]]
+ [data
+ ["." text ("#\." equivalence monoid)]
+ ["." product]]]])
+
+## (type: Name
+## [Text Text])
+
+(template [<name> <side>]
+ [(def: #export (<name> [module short])
+ (-> Name Text)
+ <side>)]
+
+ [module module]
+ [short short]
+ )
+
+(def: #export hash
+ (Hash Name)
+ (product.hash text.hash text.hash))
+
+(def: #export equivalence
+ (Equivalence Name)
+ (\ ..hash &equivalence))
+
+(implementation: #export order
+ (Order Name)
+
+ (def: &equivalence ..equivalence)
+ (def: (< [moduleP shortP] [moduleS shortS])
+ (if (text\= moduleP moduleS)
+ (\ text.order < shortP shortS)
+ (\ text.order < moduleP moduleS))))
+
+(def: separator
+ ".")
+
+(implementation: #export codec
+ (Codec Text Name)
+
+ (def: (encode [module short])
+ (case module
+ "" short
+ _ ($_ text\compose module ..separator short)))
+
+ (def: (decode input)
+ (if (text\= "" input)
+ (#.Left (text\compose "Invalid format for Name: " input))
+ (case (text.split_all_with ..separator input)
+ (^ (list short))
+ (#.Right ["" short])
+
+ (^ (list module short))
+ (#.Right [module short])
+
+ _
+ (#.Left (text\compose "Invalid format for Name: " input))))))
diff --git a/stdlib/source/library/lux/data/product.lux b/stdlib/source/library/lux/data/product.lux
new file mode 100644
index 000000000..6cf05ac83
--- /dev/null
+++ b/stdlib/source/library/lux/data/product.lux
@@ -0,0 +1,69 @@
+(.module:
+ {#.doc "Functionality for working with tuples (particularly 2-tuples)."}
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]]]])
+
+(template [<name> <type> <output>]
+ [(def: #export (<name> xy)
+ (All [a b] (-> (& a b) <type>))
+ (let [[x y] xy]
+ <output>))]
+
+ [left a x]
+ [right b y]
+ )
+
+(def: #export (curry f)
+ (All [a b c]
+ (-> (-> (& a b) c)
+ (-> a b c)))
+ (function (_ x y)
+ (f [x y])))
+
+(def: #export (uncurry f)
+ (All [a b c]
+ (-> (-> a b c)
+ (-> (& a b) c)))
+ (function (_ 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]))
+
+(def: #export (apply f g)
+ (All [a b c d]
+ (-> (-> a c) (-> b d)
+ (-> (& a b) (& c d))))
+ (function (_ [x y])
+ [(f x) (g y)]))
+
+(def: #export (fork f g)
+ (All [a l r]
+ (-> (-> a l) (-> a r)
+ (-> a (& l r))))
+ (function (_ x)
+ [(f x) (g x)]))
+
+(implementation: #export (equivalence left right)
+ (All [l r] (-> (Equivalence l) (Equivalence r) (Equivalence [l r])))
+
+ (def: (= [rl rr] [sl sr])
+ (and (\ left = rl sl)
+ (\ right = rr sr))))
+
+(def: #export (hash left right)
+ (All [l r] (-> (Hash l) (Hash r) (Hash (& l r))))
+ (implementation
+ (def: &equivalence
+ (..equivalence (\ left &equivalence)
+ (\ right &equivalence)))
+ (def: (hash [leftV rightV])
+ ("lux i64 +"
+ (\ left hash leftV)
+ (\ right hash rightV)))))
diff --git a/stdlib/source/library/lux/data/store.lux b/stdlib/source/library/lux/data/store.lux
new file mode 100644
index 000000000..3a6d73386
--- /dev/null
+++ b/stdlib/source/library/lux/data/store.lux
@@ -0,0 +1,50 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [functor (#+ Functor)]
+ comonad]
+ [type
+ implicit]]])
+
+(type: #export (Store s a)
+ {#cursor s
+ #peek (-> s a)})
+
+(def: (extend f wa)
+ (All [s a b] (-> (-> (Store s a) b) (Store s a) (Store s b)))
+ {#cursor (get@ #cursor wa)
+ #peek (function (_ s) (f (set@ #cursor s wa)))})
+
+(implementation: #export functor
+ (All [s] (Functor (Store s)))
+
+ (def: (map f fa)
+ (extend (function (_ store)
+ (f (\ store peek (\ store cursor))))
+ fa)))
+
+(implementation: #export comonad
+ (All [s] (CoMonad (Store s)))
+
+ (def: &functor ..functor)
+
+ (def: (unwrap wa) (\\ peek (\\ cursor)))
+
+ (def: split (extend id)))
+
+(def: #export (peeks trans store)
+ (All [s a] (-> (-> s s) (Store s a) a))
+ (|> (\\ cursor) trans (\\ peek)))
+
+(def: #export (seek cursor store)
+ (All [s a] (-> s (Store s a) (Store s a)))
+ (\ (\\ split store) peek cursor))
+
+(def: #export (seeks change store)
+ (All [s a] (-> (-> s s) (Store s a) (Store s a)))
+ (|> store (\\ split) (peeks change)))
+
+(def: #export (experiment Functor<f> change store)
+ (All [f s a] (-> (Functor f) (-> s (f s)) (Store s a) (f a)))
+ (\ Functor<f> map (\\ peek) (change (\\ cursor))))
diff --git a/stdlib/source/library/lux/data/sum.lux b/stdlib/source/library/lux/data/sum.lux
new file mode 100644
index 000000000..7a439fc54
--- /dev/null
+++ b/stdlib/source/library/lux/data/sum.lux
@@ -0,0 +1,90 @@
+(.module:
+ {#.doc "Functionality for working with variants (particularly 2-variants)."}
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]]]])
+
+(template [<name> <type> <right?>]
+ [(def: #export (<name> value)
+ (All [a b] (-> <type> (| a b)))
+ (0 <right?> value))]
+
+ [left a #0]
+ [right b #1])
+
+(def: #export (either fl fr)
+ (All [a b c]
+ (-> (-> a c) (-> b c)
+ (-> (| a b) c)))
+ (function (_ input)
+ (case input
+ (0 #0 l) (fl l)
+ (0 #1 r) (fr r))))
+
+(def: #export (apply fl fr)
+ (All [l l' r r']
+ (-> (-> l l') (-> r r')
+ (-> (| l r) (| l' r'))))
+ (function (_ input)
+ (case input
+ (0 #0 l) (0 #0 (fl l))
+ (0 #1 r) (0 #1 (fr r)))))
+
+(template [<name> <side> <right?>]
+ [(def: #export (<name> es)
+ (All [a b] (-> (List (| a b)) (List <side>)))
+ (case es
+ #.Nil
+ #.Nil
+
+ (#.Cons (0 <right?> x) es')
+ (#.Cons [x (<name> es')])
+
+ (#.Cons _ es')
+ (<name> 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 #0 x') [(#.Cons x' lefts) rights]
+ (0 #1 x') [lefts (#.Cons x' rights)]))))
+
+(def: #export (equivalence left right)
+ (All [l r] (-> (Equivalence l) (Equivalence r) (Equivalence (| l r))))
+ (implementation
+ (def: (= reference sample)
+ (case [reference sample]
+ [(#.Left reference) (#.Left sample)]
+ (\ left = reference sample)
+
+ [(#.Right reference) (#.Right sample)]
+ (\ right = reference sample)
+
+ _
+ false))))
+
+(def: #export (hash left right)
+ (All [l r] (-> (Hash l) (Hash r) (Hash (| l r))))
+ (implementation
+ (def: &equivalence
+ (..equivalence (\ left &equivalence)
+ (\ right &equivalence)))
+ (def: (hash value)
+ (case value
+ (#.Left value)
+ (\ left hash value)
+
+ (#.Right value)
+ (\ right hash value)))))
diff --git a/stdlib/source/library/lux/data/text.lux b/stdlib/source/library/lux/data/text.lux
new file mode 100644
index 000000000..6acc3233c
--- /dev/null
+++ b/stdlib/source/library/lux/data/text.lux
@@ -0,0 +1,380 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ [abstract
+ [hash (#+ Hash)]
+ [monoid (#+ Monoid)]
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]
+ [monad (#+ Monad do)]
+ [codec (#+ Codec)]]
+ [data
+ ["." maybe]
+ [collection
+ ["." list ("#\." fold)]]]
+ [math
+ [number
+ ["n" nat]
+ ["." i64]]]]])
+
+(type: #export Char
+ Nat)
+
+## TODO: Instead of ints, chars should be produced fron nats.
+## (The JVM specifies chars as 16-bit unsigned integers)
+(def: #export from_code
+ (-> Char Text)
+ (|>> .int "lux i64 char"))
+
+(template [<code> <short> <long>]
+ [(def: #export <long> (from_code <code>))
+ (def: #export <short> <long>)]
+
+ [00 \0 null]
+ [07 \a alarm]
+ [08 \b back_space]
+ [09 \t tab]
+ [10 \n new_line]
+ [11 \v vertical_tab]
+ [12 \f form_feed]
+ [13 \r carriage_return]
+ [34 \'' double_quote]
+ )
+
+(def: #export line_feed ..new_line)
+
+(def: #export size
+ (-> Text Nat)
+ (|>> "lux text size"))
+
+(def: #export (nth idx input)
+ (-> Nat Text (Maybe Char))
+ (if (n.< ("lux text size" input) idx)
+ (#.Some ("lux text char" idx input))
+ #.None))
+
+(def: #export (index_of' pattern from input)
+ (-> Text Nat Text (Maybe Nat))
+ ("lux text index" from pattern input))
+
+(def: #export (index_of pattern input)
+ (-> Text Text (Maybe Nat))
+ ("lux text index" 0 pattern input))
+
+(def: (last_index_of'' part since text)
+ (-> Text Nat Text (Maybe Nat))
+ (case ("lux text index" (inc since) part text)
+ #.None
+ (#.Some since)
+
+ (#.Some since')
+ (last_index_of'' part since' text)))
+
+(def: #export (last_index_of' part from text)
+ (-> Text Nat Text (Maybe Nat))
+ (case ("lux text index" from part text)
+ (#.Some since)
+ (last_index_of'' part since text)
+
+ #.None
+ #.None))
+
+(def: #export (last_index_of part text)
+ (-> Text Text (Maybe Nat))
+ (case ("lux text index" 0 part text)
+ (#.Some since)
+ (last_index_of'' part since text)
+
+ #.None
+ #.None))
+
+(def: #export (starts_with? prefix x)
+ (-> Text Text Bit)
+ (case (index_of prefix x)
+ (#.Some 0)
+ true
+
+ _
+ false))
+
+(def: #export (ends_with? postfix x)
+ (-> Text Text Bit)
+ (case (last_index_of postfix x)
+ (#.Some n)
+ (n.= (size x)
+ (n.+ (size postfix) n))
+
+ _
+ false))
+
+(def: #export (encloses? boundary value)
+ (-> Text Text Bit)
+ (and (starts_with? boundary value)
+ (ends_with? boundary value)))
+
+(def: #export (contains? sub text)
+ (-> Text Text Bit)
+ (case ("lux text index" 0 sub text)
+ (#.Some _)
+ true
+
+ _
+ false))
+
+(def: #export (prefix param subject)
+ (-> Text Text Text)
+ ("lux text concat" param subject))
+
+(def: #export (suffix param subject)
+ (-> Text Text Text)
+ ("lux text concat" subject param))
+
+(def: #export (enclose [left right] content)
+ {#.doc "Surrounds the given content text with left and right side additions."}
+ (-> [Text Text] Text Text)
+ ($_ "lux text concat" left content right))
+
+(def: #export (enclose' boundary content)
+ {#.doc "Surrounds the given content text with the same boundary text."}
+ (-> Text Text Text)
+ (enclose [boundary boundary] content))
+
+(def: #export format
+ (-> Text Text)
+ (..enclose' ..double_quote))
+
+(def: #export (clip offset characters input)
+ (-> Nat Nat Text (Maybe Text))
+ (if (|> characters (n.+ offset) (n.<= ("lux text size" input)))
+ (#.Some ("lux text clip" offset characters input))
+ #.None))
+
+(def: #export (clip' offset input)
+ (-> Nat Text (Maybe Text))
+ (let [size ("lux text size" input)]
+ (if (n.<= size offset)
+ (#.Some ("lux text clip" offset (n.- offset size) input))
+ #.None)))
+
+(def: #export (split at x)
+ (-> Nat Text (Maybe [Text Text]))
+ (case [(..clip 0 at x) (..clip' at x)]
+ [(#.Some pre) (#.Some post)]
+ (#.Some [pre post])
+
+ _
+ #.None))
+
+(def: #export (split_with token sample)
+ (-> Text Text (Maybe [Text Text]))
+ (do maybe.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))
+ (loop [input sample
+ output (: (List Text) (list))]
+ (case (..split_with token input)
+ (#.Some [pre post])
+ (|> output
+ (#.Cons pre)
+ (recur post))
+
+ #.None
+ (|> output
+ (#.Cons input)
+ list.reverse))))
+
+(def: #export (replace_once pattern replacement template)
+ (-> Text Text Text Text)
+ (<| (maybe.default template)
+ (do maybe.monad
+ [[pre post] (..split_with pattern template)]
+ (wrap ($_ "lux text concat" pre replacement post)))))
+
+(def: #export (replace_all pattern replacement template)
+ (-> Text Text Text Text)
+ (for {@.old
+ (:as Text
+ ("jvm invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"
+ (:as (primitive "java.lang.String") template)
+ (:as (primitive "java.lang.CharSequence") pattern)
+ (:as (primitive "java.lang.CharSequence") replacement)))
+ @.jvm
+ (:as Text
+ ("jvm member invoke virtual" [] "java.lang.String" "replace" []
+ (:as (primitive "java.lang.String") template)
+ ["Ljava/lang/CharSequence;" (:as (primitive "java.lang.CharSequence") pattern)]
+ ["Ljava/lang/CharSequence;" (:as (primitive "java.lang.CharSequence") replacement)]))
+ ## TODO: Comment/turn-off when generating a JS compiler using a JVM-based compiler because Nashorn's implementation of "replaceAll" is incorrect.
+ @.js
+ (:as Text
+ ("js object do" "replaceAll" template [pattern replacement]))
+ @.python
+ (:as Text
+ ("python object do" "replace" template pattern replacement))
+ ## TODO @.lua
+ @.ruby
+ (:as Text
+ ("ruby object do" "gsub" template pattern replacement))
+ @.php
+ (:as Text
+ ("php apply" (:assume ("php constant" "str_replace"))
+ pattern replacement template))
+ ## TODO @.scheme
+ ## TODO @.common_lisp
+ ## TODO @.r
+ }
+ ## Inefficient default
+ (loop [left ""
+ right template]
+ (case (..split_with pattern right)
+ (#.Some [pre post])
+ (recur ($_ "lux text concat" left pre replacement) post)
+
+ #.None
+ ("lux text concat" left right)))))
+
+(implementation: #export equivalence
+ (Equivalence Text)
+
+ (def: (= reference sample)
+ ("lux text =" reference sample)))
+
+(implementation: #export order
+ (Order Text)
+
+ (def: &equivalence ..equivalence)
+
+ (def: (< reference sample)
+ ("lux text <" reference sample)))
+
+(implementation: #export monoid
+ (Monoid Text)
+
+ (def: identity "")
+
+ (def: (compose left right)
+ ("lux text concat" left right)))
+
+(implementation: #export hash
+ (Hash Text)
+
+ (def: &equivalence ..equivalence)
+
+ (def: (hash input)
+ (for {@.old
+ (|> input
+ (: (primitive "java.lang.String"))
+ "jvm invokevirtual:java.lang.String:hashCode:"
+ "jvm convert int-to-long"
+ (:as Nat))
+
+ @.jvm
+ (|> input
+ (:as (primitive "java.lang.String"))
+ ("jvm member invoke virtual" [] "java.lang.String" "hashCode" [])
+ "jvm conversion int-to-long"
+ "jvm object cast"
+ (: (primitive "java.lang.Long"))
+ (:as Nat))}
+ ## Platform-independent default.
+ (let [length ("lux text size" input)]
+ (loop [idx 0
+ hash 0]
+ (if (n.< length idx)
+ (recur (inc idx)
+ (|> hash
+ (i64.left_shift 5)
+ (n.- hash)
+ (n.+ ("lux text char" idx input))))
+ hash))))))
+
+(def: #export concat
+ (-> (List Text) Text)
+ (let [(^open ".") ..monoid]
+ (|>> list.reverse (list\fold compose identity))))
+
+(def: #export (join_with sep texts)
+ (-> Text (List Text) Text)
+ (|> texts (list.interpose sep) concat))
+
+(def: #export (empty? text)
+ (-> Text Bit)
+ (case text
+ "" true
+ _ false))
+
+(def: #export space
+ Text
+ " ")
+
+(def: #export (space? char)
+ {#.doc "Checks whether the character is white-space."}
+ (-> Char Bit)
+ (with_expansions [<options> (template [<char>]
+ [(^ (char (~~ (static <char>))))]
+
+ [..tab]
+ [..vertical_tab]
+ [..space]
+ [..new_line]
+ [..carriage_return]
+ [..form_feed]
+ )]
+ (`` (case char
+ (^or <options>)
+ true
+
+ _
+ false))))
+
+(def: #export (lower_case value)
+ (-> Text Text)
+ (for {@.old
+ (:as Text
+ ("jvm invokevirtual:java.lang.String:toLowerCase:"
+ (:as (primitive "java.lang.String") value)))
+ @.jvm
+ (:as Text
+ ("jvm member invoke virtual" [] "java.lang.String" "toLowerCase" []
+ (:as (primitive "java.lang.String") value)))
+ @.js
+ (:as Text
+ ("js object do" "toLowerCase" value []))
+ @.python
+ (:as Text
+ ("python object do" "lower" value))
+ @.lua
+ (:as Text
+ ("lua apply" ("lua constant" "string.lower") value))
+ @.ruby
+ (:as Text
+ ("ruby object do" "downcase" value))}))
+
+(def: #export (upper_case value)
+ (-> Text Text)
+ (for {@.old
+ (:as Text
+ ("jvm invokevirtual:java.lang.String:toUpperCase:"
+ (:as (primitive "java.lang.String") value)))
+ @.jvm
+ (:as Text
+ ("jvm member invoke virtual" [] "java.lang.String" "toUpperCase" []
+ (:as (primitive "java.lang.String") value)))
+ @.js
+ (:as Text
+ ("js object do" "toUpperCase" value []))
+ @.python
+ (:as Text
+ ("python object do" "upper" value))
+ @.lua
+ (:as Text
+ ("lua apply" ("lua constant" "string.upper") value))
+ @.ruby
+ (:as Text
+ ("ruby object do" "upcase" value))}))
diff --git a/stdlib/source/library/lux/data/text/buffer.lux b/stdlib/source/library/lux/data/text/buffer.lux
new file mode 100644
index 000000000..5766d25ef
--- /dev/null
+++ b/stdlib/source/library/lux/data/text/buffer.lux
@@ -0,0 +1,115 @@
+(.module:
+ [library
+ [lux #*
+ [ffi (#+ import:)]
+ ["@" target]
+ [control
+ ["." function]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." array]
+ ["." row (#+ Row) ("#\." fold)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [type
+ abstract]]]
+ ["." //])
+
+(with_expansions [<jvm> (as_is (import: java/lang/CharSequence)
+
+ (import: java/lang/Appendable
+ ["#::."
+ (append [java/lang/CharSequence] java/lang/Appendable)])
+
+ (import: java/lang/String
+ ["#::."
+ (new [int])
+ (toString [] java/lang/String)])
+
+ (import: java/lang/StringBuilder
+ ["#::."
+ (new [int])
+ (toString [] java/lang/String)]))]
+ (`` (for {@.old (as_is <jvm>)
+ @.jvm (as_is <jvm>)
+ @.lua (as_is (import: (table/concat [(array.Array Text) Text] Text))
+ ##https://www.lua.org/manual/5.3/manual.html#pdf-table.concat
+ (import: (table/insert [(array.Array Text) Text] #? Nothing))
+ ## https://www.lua.org/manual/5.3/manual.html#pdf-table.insert
+ )}
+ (as_is))))
+
+(`` (abstract: #export Buffer
+ (for {@.old [Nat (-> java/lang/StringBuilder java/lang/StringBuilder)]
+ @.jvm [Nat (-> java/lang/StringBuilder java/lang/StringBuilder)]
+ @.lua [Nat (-> (array.Array Text) (array.Array Text))]}
+ ## default
+ (Row Text))
+
+ {#.doc "Immutable text buffer for efficient text concatenation."}
+
+ (def: #export empty
+ Buffer
+ (:abstraction (with_expansions [<jvm> [0 function.identity]]
+ (for {@.old <jvm>
+ @.jvm <jvm>
+ @.lua [0 function.identity]}
+ ## default
+ row.empty))))
+
+ (def: #export (append chunk buffer)
+ (-> Text Buffer Buffer)
+ (with_expansions [<jvm> (let [[capacity transform] (:representation buffer)
+ append! (: (-> Text java/lang/StringBuilder java/lang/StringBuilder)
+ (function (_ chunk builder)
+ (exec
+ (java/lang/Appendable::append (:as java/lang/CharSequence chunk)
+ builder)
+ builder)))]
+ (:abstraction [(n.+ (//.size chunk) capacity)
+ (|>> transform (append! chunk))]))]
+ (for {@.old <jvm>
+ @.jvm <jvm>
+ @.lua (let [[capacity transform] (:representation buffer)
+ append! (: (-> Text (array.Array Text) (array.Array Text))
+ (function (_ chunk array)
+ (exec
+ (table/insert [array chunk])
+ array)))]
+ (:abstraction [(n.+ (//.size chunk) capacity)
+ (|>> transform (append! chunk))]))}
+ ## default
+ (|> buffer :representation (row.add chunk) :abstraction))))
+
+ (def: #export size
+ (-> Buffer Nat)
+ (with_expansions [<jvm> (|>> :representation product.left)]
+ (for {@.old <jvm>
+ @.jvm <jvm>
+ @.lua <jvm>}
+ ## default
+ (|>> :representation
+ (row\fold (function (_ chunk total)
+ (n.+ (//.size chunk) total))
+ 0)))))
+
+ (def: #export (text buffer)
+ (-> Buffer Text)
+ (with_expansions [<jvm> (let [[capacity transform] (:representation buffer)]
+ (|> (java/lang/StringBuilder::new (.int capacity))
+ transform
+ java/lang/StringBuilder::toString))]
+ (for {@.old <jvm>
+ @.jvm <jvm>
+ @.lua (let [[capacity transform] (:representation buffer)]
+ (table/concat [(transform (array.new 0)) ""]))}
+ ## default
+ (row\fold (function (_ chunk total)
+ (format total chunk))
+ ""
+ (:representation buffer)))))
+ ))
diff --git a/stdlib/source/library/lux/data/text/encoding.lux b/stdlib/source/library/lux/data/text/encoding.lux
new file mode 100644
index 000000000..3ecb5b4e0
--- /dev/null
+++ b/stdlib/source/library/lux/data/text/encoding.lux
@@ -0,0 +1,163 @@
+(.module:
+ [library
+ [lux #*
+ [type
+ abstract]]])
+
+## https://docs.oracle.com/javase/8/docs/technotes/guides/intl/encoding.doc.html
+
+(abstract: #export Encoding
+ Text
+
+ (template [<name> <encoding>]
+ [(def: #export <name> Encoding (:abstraction <encoding>))]
+
+ [ascii "ASCII"]
+
+ [ibm_37 "IBM037"]
+ [ibm_273 "IBM273"]
+ [ibm_277 "IBM277"]
+ [ibm_278 "IBM278"]
+ [ibm_280 "IBM280"]
+ [ibm_284 "IBM284"]
+ [ibm_285 "IBM285"]
+ [ibm_290 "IBM290"]
+ [ibm_297 "IBM297"]
+ [ibm_300 "IBM300"]
+ [ibm_420 "IBM420"]
+ [ibm_424 "IBM424"]
+ [ibm_437 "IBM437"]
+ [ibm_500 "IBM500"]
+ [ibm_737 "IBM737"]
+ [ibm_775 "IBM775"]
+ [ibm_833 "IBM833"]
+ [ibm_834 "IBM834"]
+ [ibm_838 "IBM-Thai"]
+ [ibm_850 "IBM850"]
+ [ibm_852 "IBM852"]
+ [ibm_855 "IBM855"]
+ [ibm_856 "IBM856"]
+ [ibm_857 "IBM857"]
+ [ibm_858 "IBM00858"]
+ [ibm_860 "IBM860"]
+ [ibm_861 "IBM861"]
+ [ibm_862 "IBM862"]
+ [ibm_863 "IBM863"]
+ [ibm_864 "IBM864"]
+ [ibm_865 "IBM865"]
+ [ibm_866 "IBM866"]
+ [ibm_868 "IBM868"]
+ [ibm_869 "IBM869"]
+ [ibm_870 "IBM870"]
+ [ibm_871 "IBM871"]
+ [ibm_874 "IBM874"]
+ [ibm_875 "IBM875"]
+ [ibm_918 "IBM918"]
+ [ibm_921 "IBM921"]
+ [ibm_922 "IBM922"]
+ [ibm_930 "IBM930"]
+ [ibm_933 "IBM933"]
+ [ibm_935 "IBM935"]
+ [ibm_937 "IBM937"]
+ [ibm_939 "IBM939"]
+ [ibm_942 "IBM942"]
+ [ibm_942c "IBM942C"]
+ [ibm_943 "IBM943"]
+ [ibm_943c "IBM943C"]
+ [ibm_948 "IBM948"]
+ [ibm_949 "IBM949"]
+ [ibm_949c "IBM949C"]
+ [ibm_950 "IBM950"]
+ [ibm_964 "IBM964"]
+ [ibm_970 "IBM970"]
+ [ibm_1006 "IBM1006"]
+ [ibm_1025 "IBM1025"]
+ [ibm_1026 "IBM1026"]
+ [ibm_1046 "IBM1046"]
+ [ibm_1047 "IBM1047"]
+ [ibm_1097 "IBM1097"]
+ [ibm_1098 "IBM1098"]
+ [ibm_1112 "IBM1112"]
+ [ibm_1122 "IBM1122"]
+ [ibm_1123 "IBM1123"]
+ [ibm_1124 "IBM1124"]
+ [ibm_1140 "IBM01140"]
+ [ibm_1141 "IBM01141"]
+ [ibm_1142 "IBM01142"]
+ [ibm_1143 "IBM01143"]
+ [ibm_1144 "IBM01144"]
+ [ibm_1145 "IBM01145"]
+ [ibm_1146 "IBM01146"]
+ [ibm_1147 "IBM01147"]
+ [ibm_1148 "IBM01148"]
+ [ibm_1149 "IBM01149"]
+ [ibm_1166 "IBM1166"]
+ [ibm_1364 "IBM1364"]
+ [ibm_1381 "IBM1381"]
+ [ibm_1383 "IBM1383"]
+ [ibm_33722 "IBM33722"]
+
+ [iso_2022_cn "ISO-2022-CN"]
+ [iso2022_cn_cns "ISO2022-CN-CNS"]
+ [iso2022_cn_gb "ISO2022-CN-GB"]
+ [iso_2022_jp "ISO-2022-JP"]
+ [iso_2022_jp_2 "ISO-2022-JP-2"]
+ [iso_2022_kr "ISO-2022-KR"]
+ [iso_8859_1 "ISO-8859-1"]
+ [iso_8859_2 "ISO-8859-2"]
+ [iso_8859_3 "ISO-8859-3"]
+ [iso_8859_4 "ISO-8859-4"]
+ [iso_8859_5 "ISO-8859-5"]
+ [iso_8859_6 "ISO-8859-6"]
+ [iso_8859_7 "ISO-8859-7"]
+ [iso_8859_8 "ISO-8859-8"]
+ [iso_8859_9 "ISO-8859-9"]
+ [iso_8859_11 "iso-8859-11"]
+ [iso_8859_13 "ISO-8859-13"]
+ [iso_8859_15 "ISO-8859-15"]
+
+ [mac_arabic "MacArabic"]
+ [mac_central_europe "MacCentralEurope"]
+ [mac_croatian "MacCroatian"]
+ [mac_cyrillic "MacCyrillic"]
+ [mac_dingbat "MacDingbat"]
+ [mac_greek "MacGreek"]
+ [mac_hebrew "MacHebrew"]
+ [mac_iceland "MacIceland"]
+ [mac_roman "MacRoman"]
+ [mac_romania "MacRomania"]
+ [mac_symbol "MacSymbol"]
+ [mac_thai "MacThai"]
+ [mac_turkish "MacTurkish"]
+ [mac_ukraine "MacUkraine"]
+
+ [utf_8 "UTF-8"]
+ [utf_16 "UTF-16"]
+ [utf_32 "UTF-32"]
+
+ [windows_31j "windows-31j"]
+ [windows_874 "windows-874"]
+ [windows_949 "windows-949"]
+ [windows_950 "windows-950"]
+ [windows_1250 "windows-1250"]
+ [windows_1252 "windows-1252"]
+ [windows_1251 "windows-1251"]
+ [windows_1253 "windows-1253"]
+ [windows_1254 "windows-1254"]
+ [windows_1255 "windows-1255"]
+ [windows_1256 "windows-1256"]
+ [windows_1257 "windows-1257"]
+ [windows_1258 "windows-1258"]
+ [windows_iso2022jp "windows-iso2022jp"]
+ [windows_50220 "windows-50220"]
+ [windows_50221 "windows-50221"]
+
+ [cesu_8 "CESU-8"]
+ [koi8_r "KOI8-R"]
+ [koi8_u "KOI8-U"]
+ )
+
+ (def: #export name
+ (-> Encoding Text)
+ (|>> :representation))
+ )
diff --git a/stdlib/source/library/lux/data/text/encoding/utf8.lux b/stdlib/source/library/lux/data/text/encoding/utf8.lux
new file mode 100644
index 000000000..b24c88837
--- /dev/null
+++ b/stdlib/source/library/lux/data/text/encoding/utf8.lux
@@ -0,0 +1,164 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ ["." ffi]
+ [abstract
+ [codec (#+ Codec)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ ["." binary (#+ Binary)]]]]
+ ["." //])
+
+(with_expansions [<jvm> (as_is (ffi.import: java/lang/String
+ ["#::."
+ (new [[byte] java/lang/String])
+ (getBytes [java/lang/String] [byte])]))]
+ (for {@.old (as_is <jvm>)
+ @.jvm (as_is <jvm>)
+
+ @.js
+ (as_is (ffi.import: Uint8Array)
+
+ ## On Node
+ (ffi.import: Buffer
+ ["#::."
+ (#static from #as from|encode [ffi.String ffi.String] Buffer)
+ (#static from #as from|decode [Uint8Array] Buffer)
+ (toString [ffi.String] ffi.String)])
+
+ ## On the browser
+ (ffi.import: TextEncoder
+ ["#::."
+ (new [ffi.String])
+ (encode [ffi.String] Uint8Array)])
+
+ (ffi.import: TextDecoder
+ ["#::."
+ (new [ffi.String])
+ (decode [Uint8Array] ffi.String)]))
+
+ @.ruby
+ (as_is (ffi.import: String #as RubyString
+ ["#::."
+ (encode [Text] RubyString)
+ (force_encoding [Text] Text)
+ (bytes [] Binary)])
+
+ (ffi.import: Array #as RubyArray
+ ["#::."
+ (pack [Text] RubyString)]))
+
+ @.php
+ (as_is (ffi.import: Almost_Binary)
+ (ffi.import: (unpack [ffi.String ffi.String] Almost_Binary))
+ (ffi.import: (array_values [Almost_Binary] Binary))
+ (def: php_byte_array_format "C*"))
+
+ @.scheme
+ ## https://srfi.schemers.org/srfi-140/srfi-140.html
+ (as_is (ffi.import: (string->utf8 [Text] Binary))
+ (ffi.import: (utf8->string [Binary] Text)))}
+ (as_is)))
+
+(def: (encode value)
+ (-> Text Binary)
+ (for {@.old
+ (java/lang/String::getBytes (//.name //.utf_8)
+ ## TODO: Remove coercion below.
+ ## The coercion below may seem
+ ## gratuitous, but removing it
+ ## causes a grave compilation problem.
+ (:as java/lang/String value))
+
+ @.jvm
+ (java/lang/String::getBytes (//.name //.utf_8) value)
+
+ @.js
+ (cond ffi.on_nashorn?
+ (:as Binary ("js object do" "getBytes" value ["utf8"]))
+
+ ffi.on_node_js?
+ (|> (Buffer::from|encode [value "utf8"])
+ ## This coercion is valid as per NodeJS's documentation:
+ ## https://nodejs.org/api/buffer.html#buffer_buffers_and_typedarrays
+ (:as Uint8Array))
+
+ ## On the browser
+ (|> (TextEncoder::new [(//.name //.utf_8)])
+ (TextEncoder::encode [value]))
+ )
+
+ @.python
+ (:as Binary ("python apply" (:assume ("python constant" "bytearray")) value "utf-8"))
+
+ @.lua
+ ("lua utf8 encode" value)
+
+ @.ruby
+ (|> value
+ (:as RubyString)
+ (RubyString::encode ["UTF-8"])
+ (RubyString::bytes []))
+
+ @.php
+ (|> (..unpack [..php_byte_array_format value])
+ ..array_values
+ ("php object new" "ArrayObject")
+ (:as Binary))
+
+ @.scheme
+ (..string->utf8 value)}))
+
+(def: (decode value)
+ (-> Binary (Try Text))
+ (with_expansions [<jvm> (#try.Success (java/lang/String::new value (//.name //.utf_8)))]
+ (for {@.old <jvm>
+ @.jvm <jvm>
+
+ @.js
+ (cond ffi.on_nashorn?
+ (|> ("js object new" ("js constant" "java.lang.String") [value "utf8"])
+ (:as Text)
+ #try.Success)
+
+ ffi.on_node_js?
+ (|> (Buffer::from|decode [value])
+ (Buffer::toString ["utf8"])
+ #try.Success)
+
+ ## On the browser
+ (|> (TextDecoder::new [(//.name //.utf_8)])
+ (TextDecoder::decode [value])
+ #try.Success))
+
+ @.python
+ (try (:as Text ("python object do" "decode" (:assume value) "utf-8")))
+
+ @.lua
+ (#try.Success ("lua utf8 decode" value))
+
+ @.ruby
+ (|> value
+ (:as RubyArray)
+ (RubyArray::pack ["C*"])
+ (:as RubyString)
+ (RubyString::force_encoding ["UTF-8"])
+ #try.Success)
+
+ @.php
+ (|> value
+ ("php pack" ..php_byte_array_format)
+ #try.Success)
+
+ @.scheme
+ (|> value
+ ..utf8->string
+ #try.Success)})))
+
+(implementation: #export codec
+ (Codec Binary Text)
+
+ (def: encode ..encode)
+ (def: decode ..decode))
diff --git a/stdlib/source/library/lux/data/text/escape.lux b/stdlib/source/library/lux/data/text/escape.lux
new file mode 100644
index 000000000..2e9883c78
--- /dev/null
+++ b/stdlib/source/library/lux/data/text/escape.lux
@@ -0,0 +1,244 @@
+(.module:
+ [library
+ [lux #*
+ ["." meta]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<.>" code]]]
+ [data
+ ["." maybe]]
+ [math
+ [number (#+ hex)
+ ["n" nat]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]]]]
+ ["." // (#+ Char)
+ ["%" format (#+ format)]])
+
+(def: sigil "\")
+
+(template [<char> <sigil>]
+ [(def: <char>
+ (|> <sigil> (//.nth 0) maybe.assume))]
+
+ [sigil_char ..sigil]
+ [\u_sigil "u"]
+ )
+
+(template [<literal> <sigil> <escaped>]
+ [(def: <sigil>
+ (|> <literal> (//.nth 0) maybe.assume))
+
+ (def: <escaped>
+ (format ..sigil <literal>))]
+
+ ["0" \0_sigil escaped_\0]
+ ["a" \a_sigil escaped_\a]
+ ["b" \b_sigil escaped_\b]
+ ["t" \t_sigil escaped_\t]
+ ["n" \n_sigil escaped_\n]
+ ["v" \v_sigil escaped_\v]
+ ["f" \f_sigil escaped_\f]
+ ["r" \r_sigil escaped_\r]
+ [//.\'' \''_sigil escaped_\'']
+ [..sigil \\_sigil escaped_\\]
+ )
+
+(template [<char> <text>]
+ [(def: <char>
+ (|> <text> (//.nth 0) maybe.assume))]
+
+ [\0 //.\0]
+ [\a //.\a]
+ [\b //.\b]
+ [\t //.\t]
+ [\n //.\n]
+ [\v //.\v]
+ [\f //.\f]
+ [\r //.\r]
+ [\'' //.\'']
+ [\\ ..sigil]
+ )
+
+(def: ascii_bottom (hex "20"))
+(def: ascii_top (hex "7E"))
+
+(def: #export (escapable? char)
+ (-> Char Bit)
+ (case char
+ (^template [<char>]
+ [(^ (static <char>))
+ true])
+ ([..\0] [..\a] [..\b] [..\t]
+ [..\n] [..\v] [..\f] [..\r]
+ [..\''] [..\\])
+
+ _
+ (or (n.< ..ascii_bottom char)
+ (n.> ..ascii_top char))))
+
+(def: (ascii_escape replacement pre_offset pre_limit previous current)
+ (-> Text Nat Nat Text Text [Text Text Nat])
+ (let [post_offset (inc pre_offset)
+ post_limit (n.- post_offset pre_limit)]
+ [(format previous
+ ("lux text clip" 0 pre_offset current)
+ replacement)
+ ("lux text clip" post_offset post_limit current)
+ post_limit]))
+
+(def: (unicode_escape char pre_offset pre_limit previous current)
+ (-> Char Nat Nat Text Text [Text Text Nat])
+ (let [code (\ n.hex encode char)
+ replacement (format ..sigil "u"
+ (case ("lux text size" code)
+ 1 (format "000" code)
+ 2 (format "00" code)
+ 3 (format "0" code)
+ _ code))
+ post_offset (inc pre_offset)
+ post_limit (n.- post_offset pre_limit)]
+ [(format previous
+ ("lux text clip" 0 pre_offset current)
+ replacement)
+ ("lux text clip" post_offset post_limit current)
+ post_limit]))
+
+(def: #export (escape text)
+ (-> Text Text)
+ (loop [offset 0
+ previous ""
+ current text
+ limit ("lux text size" text)]
+ (if (n.< limit offset)
+ (case ("lux text char" offset current)
+ (^template [<char> <replacement>]
+ [(^ (static <char>))
+ (let [[previous' current' limit'] (ascii_escape <replacement> offset limit previous current)]
+ (recur 0 previous' current' limit'))])
+ ([..\0 ..escaped_\0]
+ [..\a ..escaped_\a]
+ [..\b ..escaped_\b]
+ [..\t ..escaped_\t]
+ [..\n ..escaped_\n]
+ [..\v ..escaped_\v]
+ [..\f ..escaped_\f]
+ [..\r ..escaped_\r]
+ [..\'' ..escaped_\'']
+ [..\\ ..escaped_\\])
+
+ char
+ (if (or (n.< ..ascii_bottom char)
+ (n.> ..ascii_top char))
+ (let [[previous' current' limit'] (unicode_escape char offset limit previous current)]
+ (recur 0 previous' current' limit'))
+ (recur (inc offset) previous current limit)))
+ (format previous current))))
+
+(exception: #export (dangling_escape {text Text})
+ (exception.report
+ ["In" (%.text text)]
+ ["At" (%.nat (dec (//.size text)))]))
+
+(exception: #export (invalid_escape {text Text} {offset Nat} {sigil Char})
+ (exception.report
+ ["In" (%.text text)]
+ ["At" (%.nat offset)]
+ ["Name" (%.text (//.from_code sigil))]))
+
+(exception: #export (invalid_unicode_escape {text Text} {offset Nat})
+ (exception.report
+ ["In" (%.text text)]
+ ["At" (%.nat offset)]))
+
+(def: code_size
+ 4)
+
+(def: ascii_escape_offset
+ 2)
+
+(def: unicode_escape_offset
+ (n.+ ..ascii_escape_offset ..code_size))
+
+(def: (ascii_un_escape replacement offset previous current limit)
+ (-> Text Nat Text Text Nat [Text Text Nat])
+ (let [limit' (|> limit (n.- offset) (n.- ..ascii_escape_offset))]
+ [(format previous
+ ("lux text clip" 0 offset current)
+ replacement)
+ ("lux text clip" (n.+ ..ascii_escape_offset offset) limit' current)
+ limit']))
+
+(def: (unicode_un_escape offset previous current limit)
+ (-> Nat Text Text Nat (Try [Text Text Nat]))
+ (case (|> current
+ ("lux text clip" (n.+ ..ascii_escape_offset offset) ..code_size)
+ (\ n.hex decode))
+ (#try.Success char)
+ (let [limit' (|> limit (n.- offset) (n.- ..unicode_escape_offset))]
+ (#try.Success [(format previous
+ ("lux text clip" 0 offset current)
+ (//.from_code char))
+ ("lux text clip" (n.+ ..unicode_escape_offset offset) limit' current)
+ limit']))
+
+ (#try.Failure error)
+ (exception.throw ..invalid_unicode_escape [current offset])))
+
+(def: #export (un_escape text)
+ (-> Text (Try Text))
+ (loop [offset 0
+ previous ""
+ current text
+ limit ("lux text size" text)]
+ (if (n.< limit offset)
+ (case ("lux text char" offset current)
+ (^ (static ..sigil_char))
+ (let [@sigil (inc offset)]
+ (if (n.< limit @sigil)
+ (case ("lux text char" @sigil current)
+ (^template [<sigil> <un_escaped>]
+ [(^ (static <sigil>))
+ (let [[previous' current' limit'] (..ascii_un_escape <un_escaped> offset previous current limit)]
+ (recur 0 previous' current' limit'))])
+ ([..\0_sigil //.\0]
+ [..\a_sigil //.\a]
+ [..\b_sigil //.\b]
+ [..\t_sigil //.\t]
+ [..\n_sigil //.\n]
+ [..\v_sigil //.\v]
+ [..\f_sigil //.\f]
+ [..\r_sigil //.\r]
+ [..\''_sigil //.\'']
+ [..\\_sigil ..sigil])
+
+ (^ (static ..\u_sigil))
+ (let [@unicode (n.+ code_size @sigil)]
+ (if (n.< limit @unicode)
+ (do try.monad
+ [[previous' current' limit'] (..unicode_un_escape offset previous current limit)]
+ (recur 0 previous' current' limit'))
+ (exception.throw ..invalid_unicode_escape [text offset])))
+
+ invalid_sigil
+ (exception.throw ..invalid_escape [text offset invalid_sigil]))
+ (exception.throw ..dangling_escape [text])))
+
+ _
+ (recur (inc offset) previous current limit))
+ (#try.Success (case previous
+ "" current
+ _ (format previous current))))))
+
+(syntax: #export (escaped {literal <code>.text})
+ (case (..un_escape literal)
+ (#try.Success un_escaped)
+ (wrap (list (code.text un_escaped)))
+
+ (#try.Failure error)
+ (meta.fail error)))
diff --git a/stdlib/source/library/lux/data/text/format.lux b/stdlib/source/library/lux/data/text/format.lux
new file mode 100644
index 000000000..a80503d36
--- /dev/null
+++ b/stdlib/source/library/lux/data/text/format.lux
@@ -0,0 +1,135 @@
+(.module:
+ [library
+ [lux (#- list nat int rev type)
+ [abstract
+ [monad (#+ do)]
+ [functor
+ ["." contravariant]]]
+ [control
+ ["<>" parser
+ ["<c>" code (#+ Parser)]]]
+ [data
+ ["." bit]
+ ["." name]
+ ["." text]
+ [format
+ ["." xml]
+ ["." json]]
+ [collection
+ ["." list ("#\." monad)]]]
+ ["." time
+ ["." instant]
+ ["." duration]
+ ["." date]
+ ["." day]
+ ["." month]]
+ [math
+ ["." modular]
+ [number
+ ["." nat]
+ ["." int]
+ ["." rev]
+ ["." frac]
+ ["." ratio]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]
+ ["." template]]
+ [meta
+ ["." location]]
+ ["." type]]])
+
+(type: #export (Format a)
+ {#.doc "A way to produce readable text from values."}
+ (-> a Text))
+
+(implementation: #export functor
+ (contravariant.Functor Format)
+
+ (def: (map f fb)
+ (|>> f fb)))
+
+(syntax: #export (format {fragments (<>.many <c>.any)})
+ {#.doc (doc "Text interpolation."
+ (format "Static part " (text static) " does not match URI: " uri))}
+ (wrap (.list (` ($_ "lux text concat" (~+ fragments))))))
+
+(template [<name> <type> <formatter>]
+ [(def: #export <name>
+ (Format <type>)
+ <formatter>)]
+
+ [bit Bit (\ bit.codec encode)]
+ [nat Nat (\ nat.decimal encode)]
+ [int Int (\ int.decimal encode)]
+ [rev Rev (\ rev.decimal encode)]
+ [frac Frac (\ frac.decimal encode)]
+ [text Text text.format]
+
+ [ratio ratio.Ratio (\ ratio.codec encode)]
+ [name Name (\ name.codec encode)]
+ [location Location location.format]
+ [code Code code.format]
+ [type Type type.format]
+
+ [instant instant.Instant (\ instant.codec encode)]
+ [duration duration.Duration (\ duration.codec encode)]
+ [date date.Date (\ date.codec encode)]
+ [time time.Time (\ time.codec encode)]
+ [day day.Day (\ day.codec encode)]
+ [month month.Month (\ month.codec encode)]
+
+ [xml xml.XML (\ xml.codec encode)]
+ [json json.JSON (\ json.codec encode)]
+ )
+
+(template [<type> <format>,<codec>]
+ [(`` (template [<format> <codec>]
+ [(def: #export <format>
+ (Format <type>)
+ (\ <codec> encode))]
+
+ (~~ (template.splice <format>,<codec>))))]
+
+ [Nat
+ [[nat/2 nat.binary]
+ [nat/8 nat.octal]
+ [nat/10 nat.decimal]
+ [nat/16 nat.hex]]]
+ [Int
+ [[int/2 int.binary]
+ [int/8 int.octal]
+ [int/10 int.decimal]
+ [int/16 int.hex]]]
+ [Rev
+ [[rev/2 rev.binary]
+ [rev/8 rev.octal]
+ [rev/10 rev.decimal]
+ [rev/16 rev.hex]]]
+ [Frac
+ [[frac/2 frac.binary]
+ [frac/8 frac.octal]
+ [frac/10 frac.decimal]
+ [frac/16 frac.hex]]]
+ )
+
+(def: #export (mod modular)
+ (All [m] (Format (modular.Mod m)))
+ (let [codec (modular.codec (modular.modulus modular))]
+ (\ codec encode modular)))
+
+(def: #export (list formatter)
+ (All [a] (-> (Format a) (Format (List a))))
+ (|>> (list\map (|>> formatter (format " ")))
+ (text.join_with "")
+ (text.enclose ["(list" ")"])))
+
+(def: #export (maybe format)
+ (All [a] (-> (Format a) (Format (Maybe a))))
+ (function (_ value)
+ (case value
+ #.None
+ "#.None"
+
+ (#.Some value)
+ (..format "(#.Some " (format value) ")"))))
diff --git a/stdlib/source/library/lux/data/text/regex.lux b/stdlib/source/library/lux/data/text/regex.lux
new file mode 100644
index 000000000..38f4155ab
--- /dev/null
+++ b/stdlib/source/library/lux/data/text/regex.lux
@@ -0,0 +1,495 @@
+(.module:
+ [library
+ [lux #*
+ ["." meta]
+ [abstract
+ monad]
+ [control
+ ["." try]
+ ["<>" parser ("#\." monad)
+ ["<t>" text (#+ Parser)]
+ ["<c>" code]]]
+ [data
+ ["." product]
+ ["." maybe]
+ [collection
+ ["." list ("#\." fold monad)]]]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number (#+ hex)
+ ["n" nat ("#\." decimal)]]]]]
+ ["." //
+ ["%" format (#+ format)]])
+
+(def: regex_char^
+ (Parser Text)
+ (<t>.none_of "\.|&()[]{}"))
+
+(def: escaped_char^
+ (Parser Text)
+ (do <>.monad
+ [? (<>.parses? (<t>.this "\"))]
+ (if ?
+ <t>.any
+ regex_char^)))
+
+(def: (refine^ refinement^ base^)
+ (All [a] (-> (Parser a) (Parser Text) (Parser Text)))
+ (do <>.monad
+ [output base^
+ _ (<t>.local output refinement^)]
+ (wrap output)))
+
+(def: word^
+ (Parser Text)
+ (<>.either <t>.alpha_num
+ (<t>.one_of "_")))
+
+(def: (copy reference)
+ (-> Text (Parser Text))
+ (<>.after (<t>.this reference) (<>\wrap reference)))
+
+(def: (join_text^ part^)
+ (-> (Parser (List Text)) (Parser Text))
+ (do <>.monad
+ [parts part^]
+ (wrap (//.join_with "" parts))))
+
+(def: name_char^
+ (Parser Text)
+ (<t>.none_of (format "[]{}()s#.<>" //.double_quote)))
+
+(def: name_part^
+ (Parser Text)
+ (do <>.monad
+ [head (refine^ (<t>.not <t>.decimal)
+ name_char^)
+ tail (<t>.some name_char^)]
+ (wrap (format head tail))))
+
+(def: (name^ current_module)
+ (-> Text (Parser Name))
+ ($_ <>.either
+ (<>.and (<>\wrap current_module) (<>.after (<t>.this "..") name_part^))
+ (<>.and name_part^ (<>.after (<t>.this ".") name_part^))
+ (<>.and (<>\wrap .prelude_module) (<>.after (<t>.this ".") name_part^))
+ (<>.and (<>\wrap "") name_part^)))
+
+(def: (re_var^ current_module)
+ (-> Text (Parser Code))
+ (do <>.monad
+ [name (<t>.enclosed ["\@<" ">"] (name^ current_module))]
+ (wrap (` (: (Parser Text) (~ (code.identifier name)))))))
+
+(def: re_range^
+ (Parser Code)
+ (do {! <>.monad}
+ [from (|> regex_char^ (\ ! map (|>> (//.nth 0) maybe.assume)))
+ _ (<t>.this "-")
+ to (|> regex_char^ (\ ! map (|>> (//.nth 0) maybe.assume)))]
+ (wrap (` (<t>.range (~ (code.nat from)) (~ (code.nat to)))))))
+
+(def: re_char^
+ (Parser Code)
+ (do <>.monad
+ [char escaped_char^]
+ (wrap (` ((~! ..copy) (~ (code.text char)))))))
+
+(def: re_options^
+ (Parser Code)
+ (do <>.monad
+ [options (<t>.many escaped_char^)]
+ (wrap (` (<t>.one_of (~ (code.text options)))))))
+
+(def: re_user_class^'
+ (Parser Code)
+ (do <>.monad
+ [negate? (<>.maybe (<t>.this "^"))
+ parts (<>.many ($_ <>.either
+ re_range^
+ re_options^))]
+ (wrap (case negate?
+ (#.Some _) (` (<t>.not ($_ <>.either (~+ parts))))
+ #.None (` ($_ <>.either (~+ parts)))))))
+
+(def: re_user_class^
+ (Parser Code)
+ (do <>.monad
+ [_ (wrap [])
+ init re_user_class^'
+ rest (<>.some (<>.after (<t>.this "&&") (<t>.enclosed ["[" "]"] re_user_class^')))]
+ (wrap (list\fold (function (_ refinement base)
+ (` ((~! refine^) (~ refinement) (~ base))))
+ init
+ rest))))
+
+(def: blank^
+ (Parser Text)
+ (<t>.one_of (format " " //.tab)))
+
+(def: ascii^
+ (Parser Text)
+ (<t>.range (hex "0") (hex "7F")))
+
+(def: control^
+ (Parser Text)
+ (<>.either (<t>.range (hex "0") (hex "1F"))
+ (<t>.one_of (//.from_code (hex "7F")))))
+
+(def: punct^
+ (Parser Text)
+ (<t>.one_of (format "!#$%&'()*+,-./:;<=>?@[\]^_`{|}~"
+ //.double_quote)))
+
+(def: graph^
+ (Parser Text)
+ (<>.either punct^ <t>.alpha_num))
+
+(def: print^
+ (Parser Text)
+ (<>.either graph^
+ (<t>.one_of (//.from_code (hex "20")))))
+
+(def: re_system_class^
+ (Parser Code)
+ (do <>.monad
+ []
+ ($_ <>.either
+ (<>.after (<t>.this ".") (wrap (` <t>.any)))
+ (<>.after (<t>.this "\d") (wrap (` <t>.decimal)))
+ (<>.after (<t>.this "\D") (wrap (` (<t>.not <t>.decimal))))
+ (<>.after (<t>.this "\s") (wrap (` <t>.space)))
+ (<>.after (<t>.this "\S") (wrap (` (<t>.not <t>.space))))
+ (<>.after (<t>.this "\w") (wrap (` (~! word^))))
+ (<>.after (<t>.this "\W") (wrap (` (<t>.not (~! word^)))))
+
+ (<>.after (<t>.this "\p{Lower}") (wrap (` <t>.lower)))
+ (<>.after (<t>.this "\p{Upper}") (wrap (` <t>.upper)))
+ (<>.after (<t>.this "\p{Alpha}") (wrap (` <t>.alpha)))
+ (<>.after (<t>.this "\p{Digit}") (wrap (` <t>.decimal)))
+ (<>.after (<t>.this "\p{Alnum}") (wrap (` <t>.alpha_num)))
+ (<>.after (<t>.this "\p{Space}") (wrap (` <t>.space)))
+ (<>.after (<t>.this "\p{HexDigit}") (wrap (` <t>.hexadecimal)))
+ (<>.after (<t>.this "\p{OctDigit}") (wrap (` <t>.octal)))
+ (<>.after (<t>.this "\p{Blank}") (wrap (` (~! blank^))))
+ (<>.after (<t>.this "\p{ASCII}") (wrap (` (~! ascii^))))
+ (<>.after (<t>.this "\p{Contrl}") (wrap (` (~! control^))))
+ (<>.after (<t>.this "\p{Punct}") (wrap (` (~! punct^))))
+ (<>.after (<t>.this "\p{Graph}") (wrap (` (~! graph^))))
+ (<>.after (<t>.this "\p{Print}") (wrap (` (~! print^))))
+ )))
+
+(def: re_class^
+ (Parser Code)
+ (<>.either re_system_class^
+ (<t>.enclosed ["[" "]"] re_user_class^)))
+
+(def: number^
+ (Parser Nat)
+ (|> (<t>.many <t>.decimal)
+ (<>.codec n.decimal)))
+
+(def: re_back_reference^
+ (Parser Code)
+ (<>.either (do <>.monad
+ [_ (<t>.this "\")
+ id number^]
+ (wrap (` ((~! ..copy) (~ (code.identifier ["" (n\encode id)]))))))
+ (do <>.monad
+ [_ (<t>.this "\k<")
+ captured_name name_part^
+ _ (<t>.this ">")]
+ (wrap (` ((~! ..copy) (~ (code.identifier ["" captured_name]))))))))
+
+(def: (re_simple^ current_module)
+ (-> Text (Parser Code))
+ ($_ <>.either
+ re_class^
+ (re_var^ current_module)
+ re_back_reference^
+ re_char^
+ ))
+
+(def: (re_simple_quantified^ current_module)
+ (-> Text (Parser Code))
+ (do <>.monad
+ [base (re_simple^ current_module)
+ quantifier (<t>.one_of "?*+")]
+ (case quantifier
+ "?"
+ (wrap (` (<>.default "" (~ base))))
+
+ "*"
+ (wrap (` ((~! join_text^) (<>.some (~ base)))))
+
+ ## "+"
+ _
+ (wrap (` ((~! join_text^) (<>.many (~ base)))))
+ )))
+
+(def: (re_counted_quantified^ current_module)
+ (-> Text (Parser Code))
+ (do {! <>.monad}
+ [base (re_simple^ current_module)]
+ (<t>.enclosed ["{" "}"]
+ ($_ <>.either
+ (do !
+ [[from to] (<>.and number^ (<>.after (<t>.this ",") number^))]
+ (wrap (` ((~! join_text^) (<>.between (~ (code.nat from))
+ (~ (code.nat to))
+ (~ base))))))
+ (do !
+ [limit (<>.after (<t>.this ",") number^)]
+ (wrap (` ((~! join_text^) (<>.at_most (~ (code.nat limit)) (~ base))))))
+ (do !
+ [limit (<>.before (<t>.this ",") number^)]
+ (wrap (` ((~! join_text^) (<>.at_least (~ (code.nat limit)) (~ base))))))
+ (do !
+ [limit number^]
+ (wrap (` ((~! join_text^) (<>.exactly (~ (code.nat limit)) (~ base))))))))))
+
+(def: (re_quantified^ current_module)
+ (-> Text (Parser Code))
+ (<>.either (re_simple_quantified^ current_module)
+ (re_counted_quantified^ current_module)))
+
+(def: (re_complex^ current_module)
+ (-> Text (Parser Code))
+ ($_ <>.either
+ (re_quantified^ current_module)
+ (re_simple^ current_module)))
+
+(type: Re_Group
+ #Non_Capturing
+ (#Capturing [(Maybe Text) Nat]))
+
+(def: (re_sequential^ capturing? re_scoped^ current_module)
+ (-> Bit
+ (-> Text (Parser [Re_Group Code]))
+ Text
+ (Parser [Nat Code]))
+ (do <>.monad
+ [parts (<>.many (<>.or (re_complex^ current_module)
+ (re_scoped^ current_module)))
+ #let [g!total (code.identifier ["" "0total"])
+ g!temp (code.identifier ["" "0temp"])
+ [_ names steps] (list\fold (: (-> (Either Code [Re_Group Code])
+ [Nat (List Code) (List (List Code))]
+ [Nat (List Code) (List (List Code))])
+ (function (_ part [idx names steps])
+ (case part
+ (^or (#.Left complex) (#.Right [#Non_Capturing complex]))
+ [idx
+ names
+ (list& (list g!temp complex
+ (' #let) (` [(~ g!total) (\ (~! //.monoid) (~' compose) (~ g!total) (~ g!temp))]))
+ steps)]
+
+ (#.Right [(#Capturing [?name num_captures]) scoped])
+ (let [[idx! name!] (case ?name
+ (#.Some _name)
+ [idx (code.identifier ["" _name])]
+
+ #.None
+ [(inc idx) (code.identifier ["" (n\encode idx)])])
+ access (if (n.> 0 num_captures)
+ (` ((~! product.left) (~ name!)))
+ name!)]
+ [idx!
+ (list& name! names)
+ (list& (list name! scoped
+ (' #let) (` [(~ g!total) (\ (~! //.monoid) (~' compose) (~ g!total) (~ access))]))
+ steps)])
+ )))
+ [0
+ (: (List Code) (list))
+ (: (List (List Code)) (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: (unflatten^ lexer)
+ (-> (Parser Text) (Parser [Text Any]))
+ (<>.and lexer (\ <>.monad wrap [])))
+
+(def: (|||^ left right)
+ (All [l r] (-> (Parser [Text l]) (Parser [Text r]) (Parser [Text (| l r)])))
+ (function (_ input)
+ (case (left input)
+ (#try.Success [input' [lt lv]])
+ (#try.Success [input' [lt (0 #0 lv)]])
+
+ (#try.Failure _)
+ (case (right input)
+ (#try.Success [input' [rt rv]])
+ (#try.Success [input' [rt (0 #1 rv)]])
+
+ (#try.Failure error)
+ (#try.Failure error)))))
+
+(def: (|||_^ left right)
+ (All [l r] (-> (Parser [Text l]) (Parser [Text r]) (Parser Text)))
+ (function (_ input)
+ (case (left input)
+ (#try.Success [input' [lt lv]])
+ (#try.Success [input' lt])
+
+ (#try.Failure _)
+ (case (right input)
+ (#try.Success [input' [rt rv]])
+ (#try.Success [input' rt])
+
+ (#try.Failure error)
+ (#try.Failure error)))))
+
+(def: (prep_alternative [num_captures alt])
+ (-> [Nat Code] Code)
+ (if (n.> 0 num_captures)
+ alt
+ (` ((~! unflatten^) (~ alt)))))
+
+(def: (re_alternative^ capturing? re_scoped^ current_module)
+ (-> Bit
+ (-> Text (Parser [Re_Group Code]))
+ Text
+ (Parser [Nat Code]))
+ (do <>.monad
+ [#let [sub^ (re_sequential^ capturing? re_scoped^ current_module)]
+ head sub^
+ tail (<>.some (<>.after (<t>.this "|") sub^))]
+ (if (list.empty? tail)
+ (wrap head)
+ (wrap [(list\fold n.max (product.left head) (list\map product.left tail))
+ (` ($_ ((~ (if capturing?
+ (` (~! |||^))
+ (` (~! |||_^)))))
+ (~ (prep_alternative head))
+ (~+ (list\map prep_alternative tail))))]))))
+
+(def: (re_scoped^ current_module)
+ (-> Text (Parser [Re_Group Code]))
+ ($_ <>.either
+ (do <>.monad
+ [_ (<t>.this "(?:")
+ [_ scoped] (re_alternative^ #0 re_scoped^ current_module)
+ _ (<t>.this ")")]
+ (wrap [#Non_Capturing scoped]))
+ (do <>.monad
+ [complex (re_complex^ current_module)]
+ (wrap [#Non_Capturing complex]))
+ (do <>.monad
+ [_ (<t>.this "(?<")
+ captured_name name_part^
+ _ (<t>.this ">")
+ [num_captures pattern] (re_alternative^ #1 re_scoped^ current_module)
+ _ (<t>.this ")")]
+ (wrap [(#Capturing [(#.Some captured_name) num_captures]) pattern]))
+ (do <>.monad
+ [_ (<t>.this "(")
+ [num_captures pattern] (re_alternative^ #1 re_scoped^ current_module)
+ _ (<t>.this ")")]
+ (wrap [(#Capturing [#.None num_captures]) pattern]))))
+
+(def: (regex^ current_module)
+ (-> Text (Parser Code))
+ (\ <>.monad map product.right (re_alternative^ #1 re_scoped^ current_module)))
+
+(syntax: #export (regex {pattern <c>.text})
+ {#.doc (doc "Create lexers using regular-expression syntax."
+ "For example:"
+
+ "Literals"
+ (regex "a")
+
+ "Wildcards"
+ (regex ".")
+
+ "Escaping"
+ (regex "\.")
+
+ "Character classes"
+ (regex "\d")
+ (regex "\p{Lower}")
+ (regex "[abc]")
+ (regex "[a-z]")
+ (regex "[a-zA-Z]")
+ (regex "[a-z&&[def]]")
+
+ "Negation"
+ (regex "[^abc]")
+ (regex "[^a-z]")
+ (regex "[^a-zA-Z]")
+ (regex "[a-z&&[^bc]]")
+ (regex "[a-z&&[^m-p]]")
+
+ "Combinations"
+ (regex "aa")
+ (regex "a?")
+ (regex "a*")
+ (regex "a+")
+
+ "Specific amounts"
+ (regex "a{2}")
+
+ "At least"
+ (regex "a{1,}")
+
+ "At most"
+ (regex "a{,1}")
+
+ "Between"
+ (regex "a{1,2}")
+
+ "Groups"
+ (regex "a(.)c")
+ (regex "a(b+)c")
+ (regex "(\d{3})-(\d{3})-(\d{4})")
+ (regex "(\d{3})-(?:\d{3})-(\d{4})")
+ (regex "(?<code>\d{3})-\k<code>-(\d{4})")
+ (regex "(?<code>\d{3})-\k<code>-(\d{4})-\0")
+ (regex "(\d{3})-((\d{3})-(\d{4}))")
+
+ "Alternation"
+ (regex "a|b")
+ (regex "a(.)(.)|b(.)(.)")
+ )}
+ (do meta.monad
+ [current_module meta.current_module_name]
+ (case (<t>.run (regex^ current_module)
+ pattern)
+ (#try.Failure error)
+ (meta.fail (format "Error while parsing regular-expression:" //.new_line
+ error))
+
+ (#try.Success regex)
+ (wrap (list regex))
+ )))
+
+(syntax: #export (^regex {[pattern bindings] (<c>.form (<>.and <c>.text (<>.maybe <c>.any)))}
+ body
+ {branches (<>.many <c>.any)})
+ {#.doc (doc "Allows you to test text against regular expressions."
+ (case some_text
+ (^regex "(\d{3})-(\d{3})-(\d{4})"
+ [_ country_code area_code place_code])
+ do_some_thing_when_number
+
+ (^regex "\w+")
+ do_some_thing_when_word
+
+ _
+ do_something_else))}
+ (with_gensyms [g!temp]
+ (wrap (list& (` (^multi (~ g!temp)
+ [((~! <t>.run) (..regex (~ (code.text pattern))) (~ g!temp))
+ (#try.Success (~ (maybe.default g!temp bindings)))]))
+ body
+ branches))))
diff --git a/stdlib/source/library/lux/data/text/unicode/block.lux b/stdlib/source/library/lux/data/text/unicode/block.lux
new file mode 100644
index 000000000..24ddb34e2
--- /dev/null
+++ b/stdlib/source/library/lux/data/text/unicode/block.lux
@@ -0,0 +1,205 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]
+ [monoid (#+ Monoid)]
+ ["." interval (#+ Interval)]]
+ [math
+ [number (#+ hex)
+ ["n" nat ("#\." interval)]
+ ["." i64]]]
+ [type
+ abstract]]]
+ [/// (#+ Char)])
+
+(abstract: #export Block
+ (Interval Char)
+
+ (implementation: #export monoid
+ (Monoid Block)
+
+ (def: identity
+ (:abstraction (interval.between n.enum n\top n\bottom)))
+ (def: (compose left right)
+ (let [left (:representation left)
+ right (:representation right)]
+ (:abstraction
+ (interval.between n.enum
+ (n.min (\ left bottom)
+ (\ right bottom))
+ (n.max (\ left top)
+ (\ right top)))))))
+
+ (def: #export (block start end)
+ (-> Char Char Block)
+ (:abstraction (interval.between n.enum (n.min start end) (n.max start end))))
+
+ (template [<name> <slot>]
+ [(def: #export <name>
+ (-> Block Char)
+ (|>> :representation (get@ <slot>)))]
+
+ [start #interval.bottom]
+ [end #interval.top]
+ )
+
+ (def: #export (size block)
+ (-> Block Nat)
+ (let [start (get@ #interval.bottom (:representation block))
+ end (get@ #interval.top (:representation block))]
+ (|> end (n.- start) inc)))
+
+ (def: #export (within? block char)
+ (All [a] (-> Block Char Bit))
+ (interval.within? (:representation block) char))
+ )
+
+(implementation: #export equivalence
+ (Equivalence Block)
+
+ (def: (= reference subject)
+ (and (n.= (..start reference) (..start subject))
+ (n.= (..end reference) (..end subject)))))
+
+(implementation: #export hash
+ (Hash Block)
+
+ (def: &equivalence ..equivalence)
+ (def: (hash value)
+ (i64.or (i64.left_shift 32 (..start value))
+ (..end value))))
+
+(template [<name> <start> <end>]
+ [(def: #export <name> Block (..block (hex <start>) (hex <end>)))]
+
+ ## Normal blocks
+ [basic_latin "0000" "007F"]
+ [latin_1_supplement "00A0" "00FF"]
+ [latin_extended_a "0100" "017F"]
+ [latin_extended_b "0180" "024F"]
+ [ipa_extensions "0250" "02AF"]
+ [spacing_modifier_letters "02B0" "02FF"]
+ [combining_diacritical_marks "0300" "036F"]
+ [greek_and_coptic "0370" "03FF"]
+ [cyrillic "0400" "04FF"]
+ [cyrillic_supplementary "0500" "052F"]
+ [armenian "0530" "058F"]
+ [hebrew "0590" "05FF"]
+ [arabic "0600" "06FF"]
+ [syriac "0700" "074F"]
+ [thaana "0780" "07BF"]
+ [devanagari "0900" "097F"]
+ [bengali "0980" "09FF"]
+ [gurmukhi "0A00" "0A7F"]
+ [gujarati "0A80" "0AFF"]
+ [oriya "0B00" "0B7F"]
+ [tamil "0B80" "0BFF"]
+ [telugu "0C00" "0C7F"]
+ [kannada "0C80" "0CFF"]
+ [malayalam "0D00" "0D7F"]
+ [sinhala "0D80" "0DFF"]
+ [thai "0E00" "0E7F"]
+ [lao "0E80" "0EFF"]
+ [tibetan "0F00" "0FFF"]
+ [myanmar "1000" "109F"]
+ [georgian "10A0" "10FF"]
+ [hangul_jamo "1100" "11FF"]
+ [ethiopic "1200" "137F"]
+ [cherokee "13A0" "13FF"]
+ [unified_canadian_aboriginal_syllabics "1400" "167F"]
+ [ogham "1680" "169F"]
+ [runic "16A0" "16FF"]
+ [tagalog "1700" "171F"]
+ [hanunoo "1720" "173F"]
+ [buhid "1740" "175F"]
+ [tagbanwa "1760" "177F"]
+ [khmer "1780" "17FF"]
+ [mongolian "1800" "18AF"]
+ [limbu "1900" "194F"]
+ [tai_le "1950" "197F"]
+ [khmer_symbols "19E0" "19FF"]
+ [phonetic_extensions "1D00" "1D7F"]
+ [latin_extended_additional "1E00" "1EFF"]
+ [greek_extended "1F00" "1FFF"]
+ [general_punctuation "2000" "206F"]
+ [superscripts_and_subscripts "2070" "209F"]
+ [currency_symbols "20A0" "20CF"]
+ [combining_diacritical_marks_for_symbols "20D0" "20FF"]
+ [letterlike_symbols "2100" "214F"]
+ [number_forms "2150" "218F"]
+ [arrows "2190" "21FF"]
+ [mathematical_operators "2200" "22FF"]
+ [miscellaneous_technical "2300" "23FF"]
+ [control_pictures "2400" "243F"]
+ [optical_character_recognition "2440" "245F"]
+ [enclosed_alphanumerics "2460" "24FF"]
+ [box_drawing "2500" "257F"]
+ [block_elements "2580" "259F"]
+ [geometric_shapes "25A0" "25FF"]
+ [miscellaneous_symbols "2600" "26FF"]
+ [dingbats "2700" "27BF"]
+ [miscellaneous_mathematical_symbols_a "27C0" "27EF"]
+ [supplemental_arrows_a "27F0" "27FF"]
+ [braille_patterns "2800" "28FF"]
+ [supplemental_arrows_b "2900" "297F"]
+ [miscellaneous_mathematical_symbols_b "2980" "29FF"]
+ [supplemental_mathematical_operators "2A00" "2AFF"]
+ [miscellaneous_symbols_and_arrows "2B00" "2BFF"]
+ [cjk_radicals_supplement "2E80" "2EFF"]
+ [kangxi_radicals "2F00" "2FDF"]
+ [ideographic_description_characters "2FF0" "2FFF"]
+ [cjk_symbols_and_punctuation "3000" "303F"]
+ [hiragana "3040" "309F"]
+ [katakana "30A0" "30FF"]
+ [bopomofo "3100" "312F"]
+ [hangul_compatibility_jamo "3130" "318F"]
+ [kanbun "3190" "319F"]
+ [bopomofo_extended "31A0" "31BF"]
+ [katakana_phonetic_extensions "31F0" "31FF"]
+ [enclosed_cjk_letters_and_months "3200" "32FF"]
+ [cjk_compatibility "3300" "33FF"]
+ [cjk_unified_ideographs_extension_a "3400" "4DBF"]
+ [yijing_hexagram_symbols "4DC0" "4DFF"]
+ [cjk_unified_ideographs "4E00" "9FFF"]
+ [yi_syllables "A000" "A48F"]
+ [yi_radicals "A490" "A4CF"]
+ [hangul_syllables "AC00" "D7AF"]
+ [high_surrogates "D800" "DB7F"]
+ [high_private_use_surrogates "DB80" "DBFF"]
+ [low_surrogates "DC00" "DFFF"]
+ [private_use_area "E000" "F8FF"]
+ [cjk_compatibility_ideographs "F900" "FAFF"]
+ [alphabetic_presentation_forms "FB00" "FB4F"]
+ [arabic_presentation_forms_a "FB50" "FDFF"]
+ [variation_selectors "FE00" "FE0F"]
+ [combining_half_marks "FE20" "FE2F"]
+ [cjk_compatibility_forms "FE30" "FE4F"]
+ [small_form_variants "FE50" "FE6F"]
+ [arabic_presentation_forms_b "FE70" "FEFF"]
+ [halfwidth_and_fullwidth_forms "FF00" "FFEF"]
+ [specials "FFF0" "FFFF"]
+ ## [linear_b_syllabary "10000" "1007F"]
+ ## [linear_b_ideograms "10080" "100FF"]
+ ## [aegean_numbers "10100" "1013F"]
+ ## [old_italic "10300" "1032F"]
+ ## [gothic "10330" "1034F"]
+ ## [ugaritic "10380" "1039F"]
+ ## [deseret "10400" "1044F"]
+ ## [shavian "10450" "1047F"]
+ ## [osmanya "10480" "104AF"]
+ ## [cypriot_syllabary "10800" "1083F"]
+ ## [byzantine_musical_symbols "1D000" "1D0FF"]
+ ## [musical_symbols "1D100" "1D1FF"]
+ ## [tai_xuan_jing_symbols "1D300" "1D35F"]
+ ## [mathematical_alphanumeric_symbols "1D400" "1D7FF"]
+ ## [cjk_unified_ideographs_extension_b "20000" "2A6DF"]
+ ## [cjk_compatibility_ideographs_supplement "2F800" "2FA1F"]
+ ## [tags "E0000" "E007F"]
+
+ ## Specialized blocks
+ [basic_latin/decimal "0030" "0039"]
+ [basic_latin/upper "0041" "005A"]
+ [basic_latin/lower "0061" "007A"]
+ )
diff --git a/stdlib/source/library/lux/data/text/unicode/set.lux b/stdlib/source/library/lux/data/text/unicode/set.lux
new file mode 100644
index 000000000..2c48aed41
--- /dev/null
+++ b/stdlib/source/library/lux/data/text/unicode/set.lux
@@ -0,0 +1,240 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ [collection
+ ["." list ("#\." fold functor)]
+ ["." set ("#\." equivalence)]
+ ["." tree #_
+ ["#" finger (#+ Tree)]]]]
+ [type (#+ :by_example)
+ abstract]]]
+ ["." / #_
+ ["/#" // #_
+ [// (#+ Char)]
+ ["#." block (#+ Block)]]])
+
+(def: builder
+ (tree.builder //block.monoid))
+
+(def: :@:
+ (:by_example [@]
+ (tree.Builder @ Block)
+ ..builder
+
+ @))
+
+(abstract: #export Set
+ (Tree :@: Block [])
+
+ (def: #export (compose left right)
+ (-> Set Set Set)
+ (:abstraction
+ (\ builder branch
+ (:representation left)
+ (:representation right))))
+
+ (def: (singleton block)
+ (-> Block Set)
+ (:abstraction
+ (\ builder leaf block [])))
+
+ (def: #export (set [head tail])
+ (-> [Block (List Block)] Set)
+ (list\fold (: (-> Block Set Set)
+ (function (_ block set)
+ (..compose (..singleton block) set)))
+ (..singleton head)
+ tail))
+
+ (def: character/0
+ Set
+ (..set [//block.basic_latin
+ (list //block.latin_1_supplement
+ //block.latin_extended_a
+ //block.latin_extended_b
+ //block.ipa_extensions
+ //block.spacing_modifier_letters
+ //block.combining_diacritical_marks
+ //block.greek_and_coptic
+ //block.cyrillic
+ //block.cyrillic_supplementary
+ //block.armenian
+ //block.hebrew
+ //block.arabic
+ //block.syriac
+ //block.thaana
+ //block.devanagari
+ //block.bengali
+ //block.gurmukhi
+ //block.gujarati
+ //block.oriya
+ //block.tamil
+ //block.telugu
+ //block.kannada
+ //block.malayalam
+ //block.sinhala
+ //block.thai
+ //block.lao
+ //block.tibetan
+ //block.myanmar
+ //block.georgian)]))
+
+ (def: character/1
+ Set
+ (..set [//block.hangul_jamo
+ (list //block.ethiopic
+ //block.cherokee
+ //block.unified_canadian_aboriginal_syllabics
+ //block.ogham
+ //block.runic
+ //block.tagalog
+ //block.hanunoo
+ //block.buhid
+ //block.tagbanwa
+ //block.khmer
+ //block.mongolian
+ //block.limbu
+ //block.tai_le
+ //block.khmer_symbols
+ //block.phonetic_extensions
+ //block.latin_extended_additional
+ //block.greek_extended
+ //block.general_punctuation
+ //block.superscripts_and_subscripts
+ //block.currency_symbols
+ //block.combining_diacritical_marks_for_symbols
+ //block.letterlike_symbols
+ //block.number_forms
+ //block.arrows
+ //block.mathematical_operators
+ //block.miscellaneous_technical
+ //block.control_pictures
+ //block.optical_character_recognition
+ //block.enclosed_alphanumerics
+ //block.box_drawing)]))
+
+ (def: character/2
+ Set
+ (..set [//block.block_elements
+ (list //block.geometric_shapes
+ //block.miscellaneous_symbols
+ //block.dingbats
+ //block.miscellaneous_mathematical_symbols_a
+ //block.supplemental_arrows_a
+ //block.braille_patterns
+ //block.supplemental_arrows_b
+ //block.miscellaneous_mathematical_symbols_b
+ //block.supplemental_mathematical_operators
+ //block.miscellaneous_symbols_and_arrows
+ //block.cjk_radicals_supplement
+ //block.kangxi_radicals
+ //block.ideographic_description_characters
+ //block.cjk_symbols_and_punctuation
+ //block.hiragana
+ //block.katakana
+ //block.bopomofo
+ //block.hangul_compatibility_jamo
+ //block.kanbun
+ //block.bopomofo_extended
+ //block.katakana_phonetic_extensions
+ //block.enclosed_cjk_letters_and_months
+ //block.cjk_compatibility
+ //block.cjk_unified_ideographs_extension_a
+ //block.yijing_hexagram_symbols
+ //block.cjk_unified_ideographs
+ //block.yi_syllables
+ //block.yi_radicals
+ //block.hangul_syllables
+ )]))
+
+ (def: #export character
+ Set
+ ($_ ..compose
+ ..character/0
+ ..character/1
+ ..character/2
+ ))
+
+ (def: #export non_character
+ Set
+ (..set [//block.high_surrogates
+ (list //block.high_private_use_surrogates
+ //block.low_surrogates
+ //block.private_use_area
+ //block.cjk_compatibility_ideographs
+ //block.alphabetic_presentation_forms
+ //block.arabic_presentation_forms_a
+ //block.variation_selectors
+ //block.combining_half_marks
+ //block.cjk_compatibility_forms
+ //block.small_form_variants
+ //block.arabic_presentation_forms_b
+ //block.halfwidth_and_fullwidth_forms
+ //block.specials
+ ## //block.linear_b_syllabary
+ ## //block.linear_b_ideograms
+ ## //block.aegean_numbers
+ ## //block.old_italic
+ ## //block.gothic
+ ## //block.ugaritic
+ ## //block.deseret
+ ## //block.shavian
+ ## //block.osmanya
+ ## //block.cypriot_syllabary
+ ## //block.byzantine_musical_symbols
+ ## //block.musical_symbols
+ ## //block.tai_xuan_jing_symbols
+ ## //block.mathematical_alphanumeric_symbols
+ ## //block.cjk_unified_ideographs_extension_b
+ ## //block.cjk_compatibility_ideographs_supplement
+ ## //block.tags
+ )]))
+
+ (def: #export full
+ Set
+ ($_ ..compose
+ ..character
+ ..non_character
+ ))
+
+ (def: #export (range set)
+ (-> Set [Char Char])
+ (let [tag (tree.tag (:representation set))]
+ [(//block.start tag)
+ (//block.end tag)]))
+
+ (def: #export (member? set character)
+ (-> Set Char Bit)
+ (loop [tree (:representation set)]
+ (if (//block.within? (tree.tag tree) character)
+ (case (tree.root tree)
+ (0 #0 _)
+ true
+
+ (0 #1 left right)
+ (or (recur left)
+ (recur right)))
+ false)))
+
+ (implementation: #export equivalence
+ (Equivalence Set)
+
+ (def: (= reference subject)
+ (set\= (set.from_list //block.hash (tree.tags (:representation reference)))
+ (set.from_list //block.hash (tree.tags (:representation subject))))))
+ )
+
+(template [<name> <blocks>]
+ [(def: #export <name>
+ (..set <blocks>))]
+
+ [ascii [//block.basic_latin (list)]]
+ [ascii/alpha [//block.basic_latin/upper (list //block.basic_latin/lower)]]
+ [ascii/alpha_num [//block.basic_latin/upper (list //block.basic_latin/lower //block.basic_latin/decimal)]]
+ [ascii/numeric [//block.basic_latin/decimal (list)]]
+ [ascii/upper [//block.basic_latin/upper (list)]]
+ [ascii/lower [//block.basic_latin/lower (list)]]
+ )
diff --git a/stdlib/source/library/lux/data/trace.lux b/stdlib/source/library/lux/data/trace.lux
new file mode 100644
index 000000000..0edcff430
--- /dev/null
+++ b/stdlib/source/library/lux/data/trace.lux
@@ -0,0 +1,36 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monoid (#+ Monoid)]
+ [functor (#+ Functor)]
+ comonad]
+ function]])
+
+(type: #export (Trace t a)
+ {#monoid (Monoid t)
+ #trace (-> t a)})
+
+(implementation: #export functor (All [t] (Functor (Trace t)))
+ (def: (map f fa)
+ (update@ #trace (compose f) fa)))
+
+(implementation: #export comonad (All [t] (CoMonad (Trace t)))
+ (def: &functor ..functor)
+
+ (def: (unwrap wa)
+ ((get@ #trace wa)
+ (get@ [#monoid #monoid.identity] wa)))
+
+ (def: (split wa)
+ (let [monoid (get@ #monoid wa)]
+ {#monoid monoid
+ #trace (function (_ t1)
+ {#monoid monoid
+ #trace (function (_ t2)
+ ((get@ #trace wa)
+ (\ monoid compose t1 t2)))})})))
+
+(def: #export (run context tracer)
+ (All [t a] (-> t (Trace t a) a))
+ (\ tracer trace context))
diff --git a/stdlib/source/library/lux/debug.lux b/stdlib/source/library/lux/debug.lux
new file mode 100644
index 000000000..b73b92035
--- /dev/null
+++ b/stdlib/source/library/lux/debug.lux
@@ -0,0 +1,598 @@
+(.module:
+ [library
+ [lux (#- type)
+ ["@" target]
+ ["." type]
+ ["." ffi (#+ import:)]
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ [pipe (#+ new>)]
+ ["." function]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<.>" type (#+ Parser)]
+ ["<.>" code]]]
+ [data
+ ["." text
+ ["%" format (#+ Format)]]
+ [format
+ [xml (#+ XML)]
+ ["." json]]
+ [collection
+ ["." array]
+ ["." list ("#\." functor)]
+ ["." dictionary]]]
+ [macro
+ ["." template]
+ ["." syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number
+ [ratio (#+ Ratio)]
+ ["n" nat]
+ ["i" int]]]
+ [time (#+ Time)
+ [instant (#+ Instant)]
+ [duration (#+ Duration)]
+ [date (#+ Date)]
+ [month (#+ Month)]
+ [day (#+ Day)]]]])
+
+(with_expansions [<jvm> (as_is (import: java/lang/String)
+
+ (import: (java/lang/Class a)
+ ["#::."
+ (getCanonicalName [] java/lang/String)])
+
+ (import: java/lang/Object
+ ["#::."
+ (new [])
+ (toString [] java/lang/String)
+ (getClass [] (java/lang/Class java/lang/Object))])
+
+ (import: java/lang/Integer
+ ["#::."
+ (longValue [] long)])
+
+ (import: java/lang/Long
+ ["#::."
+ (intValue [] int)])
+
+ (import: java/lang/Number
+ ["#::."
+ (intValue [] int)
+ (longValue [] long)
+ (doubleValue [] double)]))]
+ (for {@.old (as_is <jvm>)
+ @.jvm (as_is <jvm>)
+
+ @.js
+ (as_is (import: JSON
+ ["#::."
+ (#static stringify [.Any] ffi.String)])
+ (import: Array
+ ["#::."
+ (#static isArray [.Any] ffi.Boolean)]))
+
+ @.python
+ (as_is (type: PyType
+ (primitive "python_type"))
+
+ (import: (type [.Any] PyType))
+ (import: (str [.Any] ffi.String)))
+
+ @.lua
+ (as_is (import: (type [.Any] ffi.String))
+ (import: (tostring [.Any] ffi.String))
+
+ (import: math
+ ["#::."
+ (#static type [.Any] #? ffi.String)]))
+
+ @.ruby
+ (as_is (import: Class)
+
+ (import: Object
+ ["#::."
+ (class [] Class)
+ (to_s [] ffi.String)]))
+
+ @.php
+ (as_is (import: (gettype [.Any] ffi.String))
+ (import: (strval [.Any] ffi.String)))
+
+ @.scheme
+ (as_is (import: (boolean? [.Any] Bit))
+ (import: (integer? [.Any] Bit))
+ (import: (real? [.Any] Bit))
+ (import: (string? [.Any] Bit))
+ (import: (vector? [.Any] Bit))
+ (import: (pair? [.Any] Bit))
+ (import: (car [.Any] .Any))
+ (import: (cdr [.Any] .Any))
+ (import: (format [Text .Any] Text)))
+ }))
+
+(def: Inspector
+ (.type (Format Any)))
+
+(for {@.lua (def: (tuple_array tuple)
+ (-> (array.Array Any) (array.Array Any))
+ (array.from_list
+ (loop [idx 0]
+ (let [member ("lua array read" idx tuple)]
+ (if ("lua object nil?" member)
+ #.Nil
+ (#.Cons member (recur (inc idx))))))))}
+ (as_is))
+
+(def: (inspect_tuple inspect)
+ (-> Inspector Inspector)
+ (with_expansions [<adaption> (for {@.lua (~~ (as_is ..tuple_array))}
+ (~~ (as_is)))]
+ (`` (|>> (:as (array.Array Any))
+ <adaption>
+ array.to_list
+ (list\map inspect)
+ (text.join_with " ")
+ (text.enclose ["[" "]"])))))
+
+(def: #export (inspect value)
+ Inspector
+ (with_expansions [<jvm> (let [object (:as java/lang/Object value)]
+ (`` (<| (~~ (template [<class> <processing>]
+ [(case (ffi.check <class> object)
+ (#.Some value)
+ (`` (|> value (~~ (template.splice <processing>))))
+ #.None)]
+
+ [java/lang/Boolean [(:as .Bit) %.bit]]
+ [java/lang/Long [(:as .Int) %.int]]
+ [java/lang/Number [java/lang/Number::doubleValue %.frac]]
+ [java/lang/String [(:as .Text) %.text]]
+ ))
+ (case (ffi.check [java/lang/Object] object)
+ (#.Some value)
+ (let [value (:as (array.Array java/lang/Object) value)]
+ (case (array.read 0 value)
+ (^multi (#.Some tag)
+ [(ffi.check java/lang/Integer tag)
+ (#.Some tag)]
+ [[(array.read 1 value)
+ (array.read 2 value)]
+ [last?
+ (#.Some choice)]])
+ (let [last? (case last?
+ (#.Some _) #1
+ #.None #0)]
+ (|> (%.format (%.nat (.nat (java/lang/Integer::longValue tag)))
+ " " (%.bit last?)
+ " " (inspect choice))
+ (text.enclose ["(" ")"])))
+
+ _
+ (inspect_tuple inspect value)))
+ #.None)
+ (java/lang/Object::toString object))))]
+ (for {@.old <jvm>
+ @.jvm <jvm>
+
+ @.js
+ (case (ffi.type_of value)
+ (^template [<type_of> <then>]
+ [<type_of>
+ (`` (|> value (~~ (template.splice <then>))))])
+ (["boolean" [(:as .Bit) %.bit]]
+ ["number" [(:as .Frac) %.frac]]
+ ["string" [(:as .Text) %.text]]
+ ["undefined" [JSON::stringify]])
+
+ "object"
+ (let [variant_tag ("js object get" "_lux_tag" value)
+ variant_flag ("js object get" "_lux_flag" value)
+ variant_value ("js object get" "_lux_value" value)]
+ (cond (not (or ("js object undefined?" variant_tag)
+ ("js object undefined?" variant_flag)
+ ("js object undefined?" variant_value)))
+ (|> (%.format (JSON::stringify variant_tag)
+ " " (%.bit (not ("js object null?" variant_flag)))
+ " " (inspect variant_value))
+ (text.enclose ["(" ")"]))
+
+ (not (or ("js object undefined?" ("js object get" "_lux_low" value))
+ ("js object undefined?" ("js object get" "_lux_high" value))))
+ (|> value (:as .Int) %.int)
+
+ (Array::isArray value)
+ (inspect_tuple inspect value)
+
+ ## else
+ (JSON::stringify value)))
+
+ _
+ (JSON::stringify value))
+
+ @.python
+ (case (..str (..type value))
+ (^template [<type_of> <class_of> <then>]
+ [(^or <type_of> <class_of>)
+ (`` (|> value (~~ (template.splice <then>))))])
+ (["<type 'bool'>" "<class 'bool'>" [(:as .Bit) %.bit]]
+ ["<type 'int'>" "<class 'int'>" [(:as .Int) %.int]]
+ ["<type 'float'>" "<class 'float'>" [(:as .Frac) %.frac]]
+ ["<type 'str'>" "<class 'str'>" [(:as .Text) %.text]]
+ ["<type 'unicode'>" "<class 'unicode'>" [(:as .Text) %.text]])
+
+ (^or "<type 'list'>" "<class 'list'>")
+ (inspect_tuple inspect value)
+
+ (^or "<type 'tuple'>" "<type 'tuple'>")
+ (let [variant (:as (array.Array Any) value)]
+ (case (array.size variant)
+ 3 (let [variant_tag ("python array read" 0 variant)
+ variant_flag ("python array read" 1 variant)
+ variant_value ("python array read" 2 variant)]
+ (if (or ("python object none?" variant_tag)
+ ("python object none?" variant_value))
+ (..str value)
+ (|> (%.format (|> variant_tag (:as .Nat) %.nat)
+ " " (|> variant_flag "python object none?" not %.bit)
+ " " (inspect variant_value))
+ (text.enclose ["(" ")"]))))
+ _ (..str value)))
+
+ _
+ (..str value))
+
+ @.lua
+ (case (..type value)
+ (^template [<type_of> <then>]
+ [<type_of>
+ (`` (|> value (~~ (template.splice <then>))))])
+ (["boolean" [(:as .Bit) %.bit]]
+ ["string" [(:as .Text) %.text]]
+ ["nil" [(new> "nil" [])]])
+
+ "number"
+ (case (math::type [value])
+ (#.Some "integer") (|> value (:as .Int) %.int)
+ (#.Some "float") (|> value (:as .Frac) %.frac)
+
+ _
+ (..tostring value))
+
+ "table"
+ (let [variant_tag ("lua object get" "_lux_tag" value)
+ variant_flag ("lua object get" "_lux_flag" value)
+ variant_value ("lua object get" "_lux_value" value)]
+ (if (or ("lua object nil?" variant_tag)
+ ("lua object nil?" variant_value))
+ (inspect_tuple inspect value)
+ (|> (%.format (|> variant_tag (:as .Nat) %.nat)
+ " " (%.bit (not ("lua object nil?" variant_flag)))
+ " " (inspect variant_value))
+ (text.enclose ["(" ")"]))))
+
+ _
+ (..tostring value))
+
+ @.ruby
+ (template.let [(class_of <literal>)
+ [(|> <literal>
+ (:as ..Object)
+ (Object::class []))]
+
+ (to_s <object>)
+ [(|> <object>
+ (:as ..Object)
+ (Object::to_s []))]]
+ (let [value_class (class_of value)]
+ (`` (cond (~~ (template [<literal> <type> <format>]
+ [(is? (class_of <literal>) value_class)
+ (|> value (:as <type>) <format>)]
+
+ [#0 Bit %.bit]
+ [#1 Bit %.bit]
+ [+1 Int %.int]
+ [+1.0 Frac %.frac]
+ ["" Text %.text]
+ [("ruby object nil") Any (new> "nil" [])]
+ ))
+
+ (is? (class_of #.None) value_class)
+ (let [variant_tag ("ruby object get" "_lux_tag" value)
+ variant_flag ("ruby object get" "_lux_flag" value)
+ variant_value ("ruby object get" "_lux_value" value)]
+ (if (or ("ruby object nil?" variant_tag)
+ ("ruby object nil?" variant_value))
+ (inspect_tuple inspect value)
+ (|> (%.format (|> variant_tag (:as .Nat) %.nat)
+ " " (%.bit (not ("ruby object nil?" variant_flag)))
+ " " (inspect variant_value))
+ (text.enclose ["(" ")"]))))
+
+ (is? (class_of [[] []]) value_class)
+ (inspect_tuple inspect value)
+
+ ## else
+ (to_s value)))))
+
+ @.php
+ (case (..gettype value)
+ (^template [<type_of> <then>]
+ [<type_of>
+ (`` (|> value (~~ (template.splice <then>))))])
+ (["boolean" [(:as .Bit) %.bit]]
+ ["integer" [(:as .Int) %.int]]
+ ["double" [(:as .Frac) %.frac]]
+ ["string" [(:as .Text) %.text]]
+ ["NULL" [(new> "null" [])]]
+ ["array" [(inspect_tuple inspect)]])
+
+ "object"
+ (let [variant_tag ("php object get" "_lux_tag" value)
+ variant_flag ("php object get" "_lux_flag" value)
+ variant_value ("php object get" "_lux_value" value)]
+ (if (or ("php object null?" variant_tag)
+ ("php object null?" variant_value))
+ (..strval value)
+ (|> (%.format (|> variant_tag (:as .Nat) %.nat)
+ " " (%.bit (not ("php object null?" variant_flag)))
+ " " (inspect variant_value))
+ (text.enclose ["(" ")"]))))
+
+ _
+ (..strval value))
+
+ @.scheme
+ (`` (cond (~~ (template [<when> <then>]
+ [(<when> value)
+ (`` (|> value (~~ (template.splice <then>))))]
+
+ [..boolean? [(:as .Bit) %.bit]]
+ [..integer? [(:as .Int) %.int]]
+ [..real? [(:as .Frac) %.frac]]
+ [..string? [(:as .Text) %.text]]
+ ["scheme object nil?" [(new> "()" [])]]
+ [..vector? [(inspect_tuple inspect)]]))
+
+ (..pair? value)
+ (let [variant_tag (..car value)
+ variant_rest (..cdr value)]
+ (if (and (..integer? variant_tag)
+ (i.> +0 (:as Int variant_tag))
+ (..pair? variant_rest))
+ (let [variant_flag (..car variant_rest)
+ variant_value (..cdr variant_rest)]
+ (|> (%.format (|> variant_tag (:as .Nat) %.nat)
+ " " (%.bit (not ("scheme object nil?" variant_flag)))
+ " " (inspect variant_value))
+ (text.enclose ["(" ")"])))
+ (..format ["~s" value])))
+
+ ## else
+ (..format ["~s" value])
+ ))
+ })))
+
+(exception: #export (cannot_represent_value {type Type})
+ (exception.report
+ ["Type" (%.type type)]))
+
+(type: Representation
+ (-> Any Text))
+
+(def: primitive_representation
+ (Parser Representation)
+ (`` ($_ <>.either
+ (do <>.monad
+ [_ (<type>.exactly Any)]
+ (wrap (function.constant "[]")))
+
+ (~~ (template [<type> <formatter>]
+ [(do <>.monad
+ [_ (<type>.sub <type>)]
+ (wrap (|>> (:as <type>) <formatter>)))]
+
+ [Bit %.bit]
+ [Nat %.nat]
+ [Int %.int]
+ [Rev %.rev]
+ [Frac %.frac]
+ [Text %.text]))
+ )))
+
+(def: (special_representation representation)
+ (-> (Parser Representation) (Parser Representation))
+ (`` ($_ <>.either
+ (~~ (template [<type> <formatter>]
+ [(do <>.monad
+ [_ (<type>.sub <type>)]
+ (wrap (|>> (:as <type>) <formatter>)))]
+
+ [Ratio %.ratio]
+ [Name %.name]
+ [Location %.location]
+ [Type %.type]
+ [Code %.code]
+
+ [Instant %.instant]
+ [Duration %.duration]
+ [Date %.date]
+ [Time %.time]
+ [Month %.month]
+ [Day %.day]
+
+ [json.JSON %.json]
+ [XML %.xml]))
+
+ (do <>.monad
+ [[_ elemT] (<type>.apply (<>.and (<type>.exactly List) <type>.any))
+ elemR (<type>.local (list elemT) representation)]
+ (wrap (|>> (:as (List Any)) (%.list elemR))))
+
+ (do <>.monad
+ [[_ elemT] (<type>.apply (<>.and (<type>.exactly Maybe) <type>.any))
+ elemR (<type>.local (list elemT) representation)]
+ (wrap (|>> (:as (Maybe Any))
+ (%.maybe elemR)))))))
+
+(def: (variant_representation representation)
+ (-> (Parser Representation) (Parser Representation))
+ (do <>.monad
+ [membersR+ (<type>.variant (<>.many representation))]
+ (wrap (function (_ variantV)
+ (let [[lefts right? sub_repr] (loop [lefts 0
+ representations membersR+
+ variantV variantV]
+ (case representations
+ (#.Cons leftR (#.Cons rightR extraR+))
+ (case (:as (| Any Any) variantV)
+ (#.Left left)
+ [lefts #0 (leftR left)]
+
+ (#.Right right)
+ (case extraR+
+ #.Nil
+ [lefts #1 (rightR right)]
+
+ _
+ (recur (inc lefts) (#.Cons rightR extraR+) right)))
+
+ _
+ (undefined)))]
+ (%.format "(" (%.nat lefts) " " (%.bit right?) " " sub_repr ")"))))))
+
+(def: (tuple_representation representation)
+ (-> (Parser Representation) (Parser Representation))
+ (do <>.monad
+ [membersR+ (<type>.tuple (<>.many representation))]
+ (wrap (function (_ tupleV)
+ (let [tuple_body (loop [representations membersR+
+ tupleV tupleV]
+ (case representations
+ #.Nil
+ ""
+
+ (#.Cons lastR #.Nil)
+ (lastR tupleV)
+
+ (#.Cons headR tailR)
+ (let [[leftV rightV] (:as [Any Any] tupleV)]
+ (%.format (headR leftV) " " (recur tailR rightV)))))]
+ (%.format "[" tuple_body "]"))))))
+
+(def: representation
+ (Parser Representation)
+ (<>.rec
+ (function (_ representation)
+ ($_ <>.either
+ ..primitive_representation
+ (..special_representation representation)
+ (..variant_representation representation)
+ (..tuple_representation representation)
+
+ (do <>.monad
+ [[funcT inputsT+] (<type>.apply (<>.and <type>.any (<>.many <type>.any)))]
+ (case (type.apply inputsT+ funcT)
+ (#.Some outputT)
+ (<type>.local (list outputT) representation)
+
+ #.None
+ (<>.fail "")))
+
+ (do <>.monad
+ [[name anonymous] <type>.named]
+ (<type>.local (list anonymous) representation))
+
+ (<>.fail "")
+ ))))
+
+(def: #export (represent type value)
+ (-> Type Any (Try Text))
+ (case (<type>.run ..representation type)
+ (#try.Success representation)
+ (#try.Success (representation value))
+
+ (#try.Failure _)
+ (exception.throw ..cannot_represent_value type)))
+
+(syntax: #export (private {definition <code>.identifier})
+ (let [[module _] definition]
+ (wrap (list (` ("lux in-module"
+ (~ (code.text module))
+ (~ (code.identifier definition))))))))
+
+(def: #export (log! message)
+ {#.doc "Logs message to standard output."}
+ (-> Text Any)
+ ("lux io log" message))
+
+(exception: #export (type_hole {location Location} {type Type})
+ (exception.report
+ ["Location" (%.location location)]
+ ["Type" (%.type type)]))
+
+(syntax: #export (:hole)
+ (do meta.monad
+ [location meta.location
+ expectedT meta.expected_type]
+ (function.constant (exception.throw ..type_hole [location expectedT]))))
+
+(type: Target
+ [Text (Maybe Code)])
+
+(def: target
+ (<code>.Parser Target)
+ (<>.either (<>.and <code>.local_identifier
+ (\ <>.monad wrap #.None))
+ (<code>.record (<>.and <code>.local_identifier
+ (\ <>.monad map (|>> #.Some) <code>.any)))))
+
+(exception: #export (unknown_local_binding {name Text})
+ (exception.report
+ ["Name" (%.text name)]))
+
+(syntax: #export (here {targets (: (<code>.Parser (List Target))
+ (|> ..target
+ <>.some
+ (<>.default (list))))})
+ (do {! meta.monad}
+ [location meta.location
+ locals meta.locals
+ #let [environment (|> locals
+ list.concat
+ ## The list is reversed to make sure that, when building the dictionary,
+ ## later bindings overshadow earlier ones if they have the same name.
+ list.reverse
+ (dictionary.from_list text.hash))]
+ targets (: (Meta (List Target))
+ (case targets
+ #.Nil
+ (|> environment
+ dictionary.keys
+ (list\map (function (_ local) [local #.None]))
+ wrap)
+
+ _
+ (monad.map ! (function (_ [name format])
+ (if (dictionary.key? environment name)
+ (wrap [name format])
+ (function.constant (exception.throw ..unknown_local_binding [name]))))
+ targets)))]
+ (wrap (list (` (..log! ("lux text concat"
+ (~ (code.text (%.format (%.location location) text.new_line)))
+ ((~! exception.report)
+ (~+ (list\map (function (_ [name format])
+ (let [format (case format
+ #.None
+ (` (~! ..inspect))
+
+ (#.Some format)
+ format)]
+ (` [(~ (code.text name))
+ ((~ format) (~ (code.local_identifier name)))])))
+ targets))))))))))
diff --git a/stdlib/source/library/lux/extension.lux b/stdlib/source/library/lux/extension.lux
new file mode 100644
index 000000000..5cad0158c
--- /dev/null
+++ b/stdlib/source/library/lux/extension.lux
@@ -0,0 +1,89 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad]]
+ [control
+ ["<>" parser ("#\." monad)
+ ["<c>" code (#+ Parser)]
+ ["<a>" analysis]
+ ["<s>" synthesis]]]
+ [data
+ ["." product]
+ [collection
+ ["." list ("#\." functor)]]]
+ [macro (#+ with_gensyms)
+ ["." code]
+ [syntax (#+ syntax:)]]
+ [tool
+ [compiler
+ ["." phase]]]]])
+
+(type: Input
+ {#variable Text
+ #parser Code})
+
+(def: (simple default)
+ (-> Code (Parser Input))
+ ($_ <>.and
+ <c>.local_identifier
+ (<>\wrap default)))
+
+(def: complex
+ (Parser Input)
+ (<c>.record ($_ <>.and
+ <c>.local_identifier
+ <c>.any)))
+
+(def: (input default)
+ (-> Code (Parser Input))
+ (<>.either (..simple default)
+ ..complex))
+
+(type: Declaration
+ {#name Code
+ #label Text
+ #phase Text
+ #archive Text
+ #inputs (List Input)})
+
+(def: (declaration default)
+ (-> Code (Parser Declaration))
+ (<c>.form ($_ <>.and
+ <c>.any
+ <c>.local_identifier
+ <c>.local_identifier
+ <c>.local_identifier
+ (<>.some (..input default)))))
+
+(template [<any> <end> <and> <run> <extension> <name>]
+ [(syntax: #export (<name>
+ {[name extension phase archive inputs] (..declaration (` <any>))}
+ body)
+ (let [g!parser (case (list\map product.right inputs)
+ #.Nil
+ (` <end>)
+
+ parsers
+ (` (.$_ <and> (~+ parsers))))
+ g!name (code.local_identifier extension)
+ g!phase (code.local_identifier phase)
+ g!archive (code.local_identifier archive)]
+ (with_gensyms [g!handler g!inputs g!error]
+ (wrap (list (` (<extension> (~ name)
+ (.function ((~ g!handler) (~ g!name) (~ g!phase) (~ g!archive) (~ g!inputs))
+ (.case ((~! <run>) (~ g!parser) (~ g!inputs))
+ (#.Right [(~+ (list\map (|>> product.left
+ code.local_identifier)
+ inputs))])
+ (~ body)
+
+ (#.Left (~ g!error))
+ ((~! phase.fail) (~ g!error)))
+ ))))))))]
+
+ [<c>.any <c>.end! <c>.and <c>.run "lux def analysis" analysis:]
+ [<a>.any <a>.end! <a>.and <a>.run "lux def synthesis" synthesis:]
+ [<s>.any <s>.end! <s>.and <s>.run "lux def generation" generation:]
+ [<c>.any <c>.end! <c>.and <c>.run "lux def directive" directive:]
+ )
diff --git a/stdlib/source/library/lux/ffi.js.lux b/stdlib/source/library/lux/ffi.js.lux
new file mode 100644
index 000000000..aae11fc1d
--- /dev/null
+++ b/stdlib/source/library/lux/ffi.js.lux
@@ -0,0 +1,364 @@
+(.module:
+ [library
+ [lux #*
+ ["." meta]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io]
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text
+ ["%" format]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [type
+ abstract]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]
+ ["." template]]]])
+
+(abstract: #export (Object brand)
+ Any)
+
+(template [<name>]
+ [(with_expansions [<brand> (template.identifier [<name> "'"])]
+ (abstract: <brand>
+ Any
+
+ (type: #export <name>
+ (Object <brand>))))]
+
+ [Function]
+ [Symbol]
+ [Null]
+ [Undefined]
+ )
+
+(template [<name> <type>]
+ [(type: #export <name>
+ <type>)]
+
+ [Boolean Bit]
+ [Number Frac]
+ [String Text]
+ )
+
+(type: Nullable
+ [Bit Code])
+
+(def: nullable
+ (Parser Nullable)
+ (let [token (' #?)]
+ (<| (<>.and (<>.parses? (<code>.this! token)))
+ (<>.after (<>.not (<code>.this! token)))
+ <code>.any)))
+
+(type: Constructor
+ (List Nullable))
+
+(def: constructor
+ (Parser Constructor)
+ (<code>.form (<>.after (<code>.this! (' new))
+ (<code>.tuple (<>.some ..nullable)))))
+
+(type: Field
+ [Bit Text Nullable])
+
+(def: static!
+ (Parser Any)
+ (<code>.this! (' #static)))
+
+(def: field
+ (Parser Field)
+ (<code>.form ($_ <>.and
+ (<>.parses? ..static!)
+ <code>.local_identifier
+ ..nullable)))
+
+(type: Common_Method
+ {#name Text
+ #alias (Maybe Text)
+ #inputs (List Nullable)
+ #io? Bit
+ #try? Bit
+ #output Nullable})
+
+(type: Static_Method Common_Method)
+(type: Virtual_Method Common_Method)
+
+(type: Method
+ (#Static Static_Method)
+ (#Virtual Virtual_Method))
+
+(def: common_method
+ (Parser Common_Method)
+ ($_ <>.and
+ <code>.local_identifier
+ (<>.maybe (<>.after (<code>.this! (' #as)) <code>.local_identifier))
+ (<code>.tuple (<>.some ..nullable))
+ (<>.parses? (<code>.this! (' #io)))
+ (<>.parses? (<code>.this! (' #try)))
+ ..nullable))
+
+(def: static_method
+ (<>.after ..static! ..common_method))
+
+(def: method
+ (Parser Method)
+ (<code>.form (<>.or ..static_method
+ ..common_method)))
+
+(type: Member
+ (#Constructor Constructor)
+ (#Field Field)
+ (#Method Method))
+
+(def: member
+ (Parser Member)
+ ($_ <>.or
+ ..constructor
+ ..field
+ ..method
+ ))
+
+(def: input_variables
+ (-> (List Nullable) (List [Bit Code]))
+ (|>> list.enumeration
+ (list\map (function (_ [idx [nullable? type]])
+ [nullable? (|> idx %.nat code.local_identifier)]))))
+
+(def: (nullable_type [nullable? type])
+ (-> Nullable Code)
+ (if nullable?
+ (` (.Maybe (~ type)))
+ type))
+
+(def: (with_null g!temp [nullable? input])
+ (-> Code [Bit Code] Code)
+ (if nullable?
+ (` (case (~ input)
+ (#.Some (~ g!temp))
+ (~ g!temp)
+
+ #.None
+ ("js object null")))
+ input))
+
+(def: (without_null g!temp [nullable? outputT] output)
+ (-> Code Nullable Code Code)
+ (if nullable?
+ (` (let [(~ g!temp) (~ output)]
+ (if ("js object null?" (~ g!temp))
+ #.None
+ (#.Some (~ g!temp)))))
+ (` (let [(~ g!temp) (~ output)]
+ (if (not ("js object null?" (~ g!temp)))
+ (~ g!temp)
+ (.error! "Null is an invalid value."))))))
+
+(type: Import
+ (#Class [Text Text (List Member)])
+ (#Function Static_Method))
+
+(def: import
+ (Parser Import)
+ (<>.or (<>.and <code>.local_identifier
+ (<>.default ["" (list)]
+ (<code>.tuple (<>.and <code>.text
+ (<>.some member)))))
+ (<code>.form ..common_method)))
+
+(def: (with_io with? without)
+ (-> Bit Code Code)
+ (if with?
+ (` (io.io (~ without)))
+ without))
+
+(def: (io_type io? rawT)
+ (-> Bit Code Code)
+ (if io?
+ (` (io.IO (~ rawT)))
+ rawT))
+
+(def: (with_try with? without_try)
+ (-> Bit Code Code)
+ (if with?
+ (` (.try (~ without_try)))
+ without_try))
+
+(def: (try_type try? rawT)
+ (-> Bit Code Code)
+ (if try?
+ (` (.Either .Text (~ rawT)))
+ rawT))
+
+(def: (make_function g!method g!temp source inputsT io? try? outputT)
+ (-> Code Code Text (List Nullable) Bit Bit Nullable Code)
+ (let [g!inputs (input_variables inputsT)]
+ (` (def: ((~ g!method)
+ [(~+ (list\map product.right g!inputs))])
+ (-> [(~+ (list\map nullable_type inputsT))]
+ (~ (|> (nullable_type outputT)
+ (try_type try?)
+ (io_type io?))))
+ (:assume
+ (~ (<| (with_io io?)
+ (with_try try?)
+ (without_null g!temp outputT)
+ (` ("js apply"
+ ("js constant" (~ (code.text source)))
+ (~+ (list\map (with_null g!temp) g!inputs)))))))))))
+
+(syntax: #export (import: {import ..import})
+ (with_gensyms [g!temp]
+ (case import
+ (#Class [class format members])
+ (with_gensyms [g!object]
+ (let [qualify (: (-> Text Code)
+ (function (_ member_name)
+ (|> format
+ (text.replace_all "#" class)
+ (text.replace_all "." member_name)
+ code.local_identifier)))
+ g!type (code.local_identifier class)
+ real_class (text.replace_all "/" "." class)]
+ (wrap (list& (` (type: (~ g!type)
+ (..Object (primitive (~ (code.text real_class))))))
+ (list\map (function (_ member)
+ (case member
+ (#Constructor inputsT)
+ (let [g!inputs (input_variables inputsT)]
+ (` (def: ((~ (qualify "new"))
+ [(~+ (list\map product.right g!inputs))])
+ (-> [(~+ (list\map nullable_type inputsT))]
+ (~ g!type))
+ (:assume
+ ("js object new"
+ ("js constant" (~ (code.text real_class)))
+ [(~+ (list\map (with_null g!temp) g!inputs))])))))
+
+ (#Field [static? field fieldT])
+ (if static?
+ (` ((~! syntax:) ((~ (qualify field)))
+ (\ (~! meta.monad) (~' wrap)
+ (list (` (.:as (~ (nullable_type fieldT))
+ ("js constant" (~ (code.text (%.format real_class "." field))))))))))
+ (` (def: ((~ (qualify field))
+ (~ g!object))
+ (-> (~ g!type)
+ (~ (nullable_type fieldT)))
+ (:assume
+ (~ (without_null g!temp fieldT (` ("js object get" (~ (code.text field)) (~ g!object)))))))))
+
+ (#Method method)
+ (case method
+ (#Static [method alias inputsT io? try? outputT])
+ (..make_function (qualify (maybe.default method alias))
+ g!temp
+ (%.format real_class "." method)
+ inputsT
+ io?
+ try?
+ outputT)
+
+ (#Virtual [method alias inputsT io? try? outputT])
+ (let [g!inputs (input_variables inputsT)]
+ (` (def: ((~ (qualify (maybe.default method alias)))
+ [(~+ (list\map product.right g!inputs))]
+ (~ g!object))
+ (-> [(~+ (list\map nullable_type inputsT))]
+ (~ g!type)
+ (~ (|> (nullable_type outputT)
+ (try_type try?)
+ (io_type io?))))
+ (:assume
+ (~ (<| (with_io io?)
+ (with_try try?)
+ (without_null g!temp outputT)
+ (` ("js object do"
+ (~ (code.text method))
+ (~ g!object)
+ [(~+ (list\map (with_null g!temp) g!inputs))])))))))))))
+ members)))))
+
+ (#Function [name alias inputsT io? try? outputT])
+ (wrap (list (..make_function (code.local_identifier (maybe.default name alias))
+ g!temp
+ name
+ inputsT
+ io?
+ try?
+ outputT)))
+ )))
+
+(template: #export (type_of object)
+ ("js type-of" object))
+
+(syntax: #export (constant type
+ {[head tail] (<code>.tuple (<>.and <code>.local_identifier (<>.some <code>.local_identifier)))})
+ (with_gensyms [g!_]
+ (let [constant (` ("js constant" (~ (code.text head))))]
+ (case tail
+ #.Nil
+ (wrap (list (` (: (.Maybe (~ type))
+ (case (..type_of (~ constant))
+ "undefined"
+ #.None
+
+ (~ g!_)
+ (#.Some (:as (~ type) (~ constant))))))))
+
+ (#.Cons [next tail])
+ (let [separator "."]
+ (wrap (list (` (: (.Maybe (~ type))
+ (case (..type_of (~ constant))
+ "undefined"
+ #.None
+
+ (~ g!_)
+ (..constant (~ type) [(~ (code.local_identifier (%.format head "." next)))
+ (~+ (list\map code.local_identifier tail))])))))))))))
+
+(template: (!defined? <constant>)
+ (.case (..constant Any <constant>)
+ #.None
+ .false
+
+ (#.Some _)
+ .true))
+
+(template [<name> <constant>]
+ [(def: #export <name>
+ Bit
+ (!defined? <constant>))]
+
+ [on_browser? [window]]
+ [on_nashorn? [java lang Object]]
+ )
+
+(def: #export on_node_js?
+ Bit
+ (case (..constant (Object Any) [process])
+ (#.Some process)
+ (case (:as Text
+ ("js apply" ("js constant" "Object.prototype.toString.call") process))
+ "[object process]"
+ true
+
+ _
+ false)
+
+ #.None
+ false))
+
+(template: #export (closure <inputs> <output>)
+ (.:as ..Function
+ (`` ("js function"
+ (~~ (template.count <inputs>))
+ (.function (_ [<inputs>])
+ <output>)))))
diff --git a/stdlib/source/library/lux/ffi.jvm.lux b/stdlib/source/library/lux/ffi.jvm.lux
new file mode 100644
index 000000000..881c3f79d
--- /dev/null
+++ b/stdlib/source/library/lux/ffi.jvm.lux
@@ -0,0 +1,2048 @@
+(.module:
+ [library
+ ["." lux (#- Type type int char interface:)
+ ["#_." type ("#\." equivalence)]
+ [abstract
+ ["." monad (#+ Monad do)]
+ ["." enum]]
+ [control
+ ["." function]
+ ["." io]
+ ["." try (#+ Try)]
+ ["." exception (#+ Exception exception:)]
+ ["<>" parser ("#\." monad)
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." maybe]
+ ["." product]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." array]
+ ["." list ("#\." monad fold monoid)]
+ ["." dictionary (#+ Dictionary)]]]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]
+ ["." template]]
+ ["." meta
+ ["." annotation]]
+ [target
+ [jvm
+ [encoding
+ ["." name (#+ External)]]
+ ["." type (#+ Type Argument Typed)
+ ["." category (#+ Void Value' Value Return' Return Method Primitive Object Class Array Var Parameter Declaration)]
+ ["." box]
+ ["." descriptor]
+ ["." signature]
+ ["." reflection]
+ ["." parser]]]]]])
+
+(def: internal
+ (-> External Text)
+ (|>> name.internal
+ name.read))
+
+(def: signature
+ (All [category]
+ (-> (Type category) Text))
+ (|>> type.signature signature.signature))
+
+(def: reflection
+ (All [category]
+ (-> (Type (<| Return' Value' category)) Text))
+ (|>> type.reflection reflection.reflection))
+
+(template [<name> <class>]
+ [(def: #export <name>
+ .Type
+ (#.Primitive <class> #.Nil))]
+
+ [Boolean box.boolean]
+ [Byte box.byte]
+ [Short box.short]
+ [Integer box.int]
+ [Long box.long]
+ [Float box.float]
+ [Double box.double]
+ [Character box.char]
+ )
+
+(template [<name> <class>]
+ [(def: #export <name>
+ .Type
+ (#.Primitive (reflection.reflection <class>) #.Nil))]
+
+ ## Primitives
+ [boolean reflection.boolean]
+ [byte reflection.byte]
+ [short reflection.short]
+ [int reflection.int]
+ [long reflection.long]
+ [float reflection.float]
+ [double reflection.double]
+ [char reflection.char]
+ )
+
+(def: (get_static_field class field)
+ (-> Text Text Code)
+ (` ("jvm member get static"
+ (~ (code.text class))
+ (~ (code.text field)))))
+
+(def: (get_virtual_field class field object)
+ (-> Text Text Code Code)
+ (` ("jvm member get virtual"
+ (~ (code.text class))
+ (~ (code.text field))
+ (~ object))))
+
+(def: boxes
+ (Dictionary (Type Value) Text)
+ (|> (list [type.boolean box.boolean]
+ [type.byte box.byte]
+ [type.short box.short]
+ [type.int box.int]
+ [type.long box.long]
+ [type.float box.float]
+ [type.double box.double]
+ [type.char box.char])
+ (dictionary.from_list type.hash)))
+
+(template [<name> <pre> <post>]
+ [(def: (<name> unboxed boxed raw)
+ (-> (Type Value) Text Code Code)
+ (let [unboxed (..reflection unboxed)]
+ (` (|> (~ raw)
+ (: (primitive (~ (code.text <pre>))))
+ "jvm object cast"
+ (: (primitive (~ (code.text <post>))))))))]
+
+ [unbox boxed unboxed]
+ [box unboxed boxed]
+ )
+
+(template [<name> <op> <from> <to>]
+ [(template: #export (<name> value)
+ {#.doc (doc "Type converter."
+ (: <to>
+ (<name> (: <from> foo))))}
+ (|> value
+ (: <from>)
+ "jvm object cast"
+ <op>
+ "jvm object cast"
+ (: <to>)))]
+
+ [byte_to_long "jvm conversion byte-to-long" ..Byte ..Long]
+
+ [short_to_long "jvm conversion short-to-long" ..Short ..Long]
+
+ [double_to_int "jvm conversion double-to-int" ..Double ..Integer]
+ [double_to_long "jvm conversion double-to-long" ..Double ..Long]
+ [double_to_float "jvm conversion double-to-float" ..Double ..Float]
+
+ [float_to_int "jvm conversion float-to-int" ..Float ..Integer]
+ [float_to_long "jvm conversion float-to-long" ..Float ..Long]
+ [float_to_double "jvm conversion float-to-double" ..Float ..Double]
+
+ [int_to_byte "jvm conversion int-to-byte" ..Integer ..Byte]
+ [int_to_short "jvm conversion int-to-short" ..Integer ..Short]
+ [int_to_long "jvm conversion int-to-long" ..Integer ..Long]
+ [int_to_float "jvm conversion int-to-float" ..Integer ..Float]
+ [int_to_double "jvm conversion int-to-double" ..Integer ..Double]
+ [int_to_char "jvm conversion int-to-char" ..Integer ..Character]
+
+ [long_to_byte "jvm conversion long-to-byte" ..Long ..Byte]
+ [long_to_short "jvm conversion long-to-short" ..Long ..Short]
+ [long_to_int "jvm conversion long-to-int" ..Long ..Integer]
+ [long_to_float "jvm conversion long-to-float" ..Long ..Float]
+ [long_to_double "jvm conversion long-to-double" ..Long ..Double]
+
+ [char_to_byte "jvm conversion char-to-byte" ..Character ..Byte]
+ [char_to_short "jvm conversion char-to-short" ..Character ..Short]
+ [char_to_int "jvm conversion char-to-int" ..Character ..Integer]
+ [char_to_long "jvm conversion char-to-long" ..Character ..Long]
+ )
+
+(template [<name> <from> <to> <0> <1>]
+ [(template: #export (<name> value)
+ {#.doc (doc "Type converter."
+ (: <to>
+ (<name> (: <from> foo))))}
+ (|> value <0> <1>))]
+
+ [long_to_char ..Long ..Character ..long_to_int ..int_to_char]
+ [byte_to_int ..Byte ..Integer ..byte_to_long ..long_to_int]
+ [short_to_int ..Short ..Integer ..short_to_long ..long_to_int]
+ [byte_to_char ..Byte ..Character ..byte_to_int ..int_to_char]
+ [short_to_char ..Short ..Character ..short_to_int ..int_to_char]
+ )
+
+(def: constructor_method_name
+ "<init>")
+
+(type: Primitive_Mode
+ #ManualPrM
+ #AutoPrM)
+
+(type: Privacy
+ #PublicP
+ #PrivateP
+ #ProtectedP
+ #DefaultP)
+
+(type: StateModifier
+ #VolatileSM
+ #FinalSM
+ #DefaultSM)
+
+(type: InheritanceModifier
+ #FinalIM
+ #AbstractIM
+ #DefaultIM)
+
+(type: Class_Kind
+ #Class
+ #Interface)
+
+(type: StackFrame (primitive "java/lang/StackTraceElement"))
+(type: StackTrace (array.Array StackFrame))
+
+(type: Annotation_Parameter
+ [Text Code])
+
+(type: Annotation
+ {#ann_name Text
+ #ann_params (List Annotation_Parameter)})
+
+(type: Member_Declaration
+ {#member_name Text
+ #member_privacy Privacy
+ #member_anns (List Annotation)})
+
+(type: FieldDecl
+ (#ConstantField (Type Value) Code)
+ (#VariableField StateModifier (Type Value)))
+
+(type: MethodDecl
+ {#method_tvars (List (Type Var))
+ #method_inputs (List (Type Value))
+ #method_output (Type Return)
+ #method_exs (List (Type Class))})
+
+(type: Method_Definition
+ (#ConstructorMethod [Bit
+ (List (Type Var))
+ Text
+ (List Argument)
+ (List (Typed Code))
+ Code
+ (List (Type Class))])
+ (#VirtualMethod [Bit
+ Bit
+ (List (Type Var))
+ Text
+ (List Argument)
+ (Type Return)
+ Code
+ (List (Type Class))])
+ (#OverridenMethod [Bit
+ (Type Declaration)
+ (List (Type Var))
+ Text
+ (List Argument)
+ (Type Return)
+ Code
+ (List (Type Class))])
+ (#StaticMethod [Bit
+ (List (Type Var))
+ (List Argument)
+ (Type Return)
+ Code
+ (List (Type Class))])
+ (#AbstractMethod [(List (Type Var))
+ (List Argument)
+ (Type Return)
+ (List (Type Class))])
+ (#NativeMethod [(List (Type Var))
+ (List Argument)
+ (Type Return)
+ (List (Type Class))]))
+
+(type: Partial_Call
+ {#pc_method Name
+ #pc_args (List Code)})
+
+(type: ImportMethodKind
+ #StaticIMK
+ #VirtualIMK)
+
+(type: ImportMethodCommons
+ {#import_member_mode Primitive_Mode
+ #import_member_alias Text
+ #import_member_kind ImportMethodKind
+ #import_member_tvars (List (Type Var))
+ #import_member_args (List [Bit (Type Value)])
+ #import_member_maybe? Bit
+ #import_member_try? Bit
+ #import_member_io? Bit})
+
+(type: ImportConstructorDecl
+ {})
+
+(type: ImportMethodDecl
+ {#import_method_name Text
+ #import_method_return (Type Return)})
+
+(type: ImportFieldDecl
+ {#import_field_mode Primitive_Mode
+ #import_field_name Text
+ #import_field_static? Bit
+ #import_field_maybe? Bit
+ #import_field_setter? Bit
+ #import_field_type (Type Value)})
+
+(type: Import_Member_Declaration
+ (#EnumDecl (List Text))
+ (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl])
+ (#MethodDecl [ImportMethodCommons ImportMethodDecl])
+ (#FieldAccessDecl ImportFieldDecl))
+
+(def: (primitive_type mode type)
+ (-> Primitive_Mode (Type Primitive) Code)
+ (case mode
+ #ManualPrM
+ (cond (\ type.equivalence = type.boolean type) (` ..Boolean)
+ (\ type.equivalence = type.byte type) (` ..Byte)
+ (\ type.equivalence = type.short type) (` ..Short)
+ (\ type.equivalence = type.int type) (` ..Integer)
+ (\ type.equivalence = type.long type) (` ..Long)
+ (\ type.equivalence = type.float type) (` ..Float)
+ (\ type.equivalence = type.double type) (` ..Double)
+ (\ type.equivalence = type.char type) (` ..Character)
+ ## else
+ (undefined))
+
+ #AutoPrM
+ (cond (\ type.equivalence = type.boolean type)
+ (` .Bit)
+
+ (or (\ type.equivalence = type.short type)
+ (\ type.equivalence = type.byte type)
+ (\ type.equivalence = type.int type)
+ (\ type.equivalence = type.long type))
+ (` .Int)
+
+ (or (\ type.equivalence = type.float type)
+ (\ type.equivalence = type.double type))
+ (` .Frac)
+
+ (\ type.equivalence = type.char type)
+ (` .Nat)
+
+ ## else
+ (undefined))))
+
+(def: (parameter_type type)
+ (-> (Type Parameter) Code)
+ (`` (<| (~~ (template [<when> <binding> <then>]
+ [(case (<when> type)
+ (#.Some <binding>)
+ <then>
+
+ #.None)]
+
+ [parser.var? name (code.identifier ["" name])]
+ [parser.wildcard? _ (` .Any)]
+ [parser.lower? _ (` .Any)]
+ [parser.upper? limit (parameter_type limit)]
+ [parser.class? [name parameters]
+ (` (.primitive (~ (code.text name))
+ [(~+ (list\map parameter_type parameters))]))]))
+ ## else
+ (undefined)
+ )))
+
+(def: (value_type mode type)
+ (-> Primitive_Mode (Type Value) Code)
+ (`` (<| (~~ (template [<when> <binding> <then>]
+ [(case (<when> type)
+ (#.Some <binding>)
+ <then>
+
+ #.None)]
+
+ [parser.parameter? type (parameter_type type)]
+ [parser.primitive? type (primitive_type mode type)]
+ [parser.array? elementT (case (parser.primitive? elementT)
+ (#.Some elementT)
+ (` (#.Primitive (~ (code.text (..reflection (type.array elementT)))) #.Nil))
+
+ #.None
+ (` (#.Primitive (~ (code.text array.type_name))
+ (#.Cons (~ (value_type mode elementT)) #.Nil))))]))
+ (undefined)
+ )))
+
+(def: declaration_type$
+ (-> (Type Declaration) Code)
+ (|>> ..signature code.text))
+
+(def: (make_get_const_parser class_name field_name)
+ (-> Text Text (Parser Code))
+ (do <>.monad
+ [#let [dotted_name (format "::" field_name)]
+ _ (<code>.this! (code.identifier ["" dotted_name]))]
+ (wrap (get_static_field class_name field_name))))
+
+(def: (make_get_var_parser class_name field_name)
+ (-> Text Text (Parser Code))
+ (do <>.monad
+ [#let [dotted_name (format "::" field_name)]
+ _ (<code>.this! (code.identifier ["" dotted_name]))]
+ (wrap (get_virtual_field class_name field_name (' _jvm_this)))))
+
+(def: (make_put_var_parser class_name field_name)
+ (-> Text Text (Parser Code))
+ (do <>.monad
+ [#let [dotted_name (format "::" field_name)]
+ [_ _ value] (: (Parser [Any Any Code])
+ (<code>.form ($_ <>.and (<code>.this! (' :=)) (<code>.this! (code.identifier ["" dotted_name])) <code>.any)))]
+ (wrap (`' ((~ (code.text (format "jvm putfield" ":" class_name ":" field_name))) _jvm_this (~ value))))))
+
+(def: (pre_walk_replace f input)
+ (-> (-> Code Code) Code Code)
+ (case (f input)
+ (^template [<tag>]
+ [[meta (<tag> parts)]
+ [meta (<tag> (list\map (pre_walk_replace f) parts))]])
+ ([#.Form]
+ [#.Tuple])
+
+ [meta (#.Record pairs)]
+ [meta (#.Record (list\map (: (-> [Code Code] [Code Code])
+ (function (_ [key val])
+ [(pre_walk_replace f key) (pre_walk_replace f val)]))
+ pairs))]
+
+ ast'
+ ast'))
+
+(def: (parser->replacer p ast)
+ (-> (Parser Code) (-> Code Code))
+ (case (<>.run p (list ast))
+ (#.Right [#.Nil ast'])
+ ast'
+
+ _
+ ast
+ ))
+
+(def: (field->parser class_name [[field_name _ _] field])
+ (-> Text [Member_Declaration FieldDecl] (Parser Code))
+ (case field
+ (#ConstantField _)
+ (make_get_const_parser class_name field_name)
+
+ (#VariableField _)
+ (<>.either (make_get_var_parser class_name field_name)
+ (make_put_var_parser class_name field_name))))
+
+(def: (decorate_input [class value])
+ (-> [(Type Value) Code] Code)
+ (` [(~ (code.text (..signature class))) (~ value)]))
+
+(def: (make_constructor_parser class_name arguments)
+ (-> Text (List Argument) (Parser Code))
+ (do <>.monad
+ [args (: (Parser (List Code))
+ (<code>.form (<>.after (<code>.this! (' ::new!))
+ (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))]
+ (wrap (` ("jvm member invoke constructor" (~ (code.text class_name))
+ (~+ (|> args
+ (list.zip/2 (list\map product.right arguments))
+ (list\map ..decorate_input))))))))
+
+(def: (make_static_method_parser class_name method_name arguments)
+ (-> Text Text (List Argument) (Parser Code))
+ (do <>.monad
+ [#let [dotted_name (format "::" method_name "!")]
+ args (: (Parser (List Code))
+ (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name]))
+ (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))]
+ (wrap (` ("jvm member invoke static" (~ (code.text class_name)) (~ (code.text method_name))
+ (~+ (|> args
+ (list.zip/2 (list\map product.right arguments))
+ (list\map ..decorate_input))))))))
+
+(template [<name> <jvm_op>]
+ [(def: (<name> class_name method_name arguments)
+ (-> Text Text (List Argument) (Parser Code))
+ (do <>.monad
+ [#let [dotted_name (format "::" method_name "!")]
+ args (: (Parser (List Code))
+ (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name]))
+ (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))]
+ (wrap (` (<jvm_op> (~ (code.text class_name)) (~ (code.text method_name))
+ (~' _jvm_this)
+ (~+ (|> args
+ (list.zip/2 (list\map product.right arguments))
+ (list\map ..decorate_input))))))))]
+
+ [make_special_method_parser "jvm member invoke special"]
+ [make_virtual_method_parser "jvm member invoke virtual"]
+ )
+
+(def: (method->parser class_name [[method_name _ _] meth_def])
+ (-> Text [Member_Declaration Method_Definition] (Parser Code))
+ (case meth_def
+ (#ConstructorMethod strict? type_vars self_name args constructor_args return_expr exs)
+ (make_constructor_parser class_name args)
+
+ (#StaticMethod strict? type_vars args return_type return_expr exs)
+ (make_static_method_parser class_name method_name args)
+
+ (^or (#VirtualMethod final? strict? type_vars self_name args return_type return_expr exs)
+ (#OverridenMethod strict? owner_class type_vars self_name args return_type return_expr exs))
+ (make_special_method_parser class_name method_name args)
+
+ (#AbstractMethod type_vars args return_type exs)
+ (make_virtual_method_parser class_name method_name args)
+
+ (#NativeMethod type_vars args return_type exs)
+ (make_virtual_method_parser class_name method_name args)))
+
+(def: privacy_modifier^
+ (Parser Privacy)
+ (let [(^open ".") <>.monad]
+ ($_ <>.or
+ (<code>.this! (' #public))
+ (<code>.this! (' #private))
+ (<code>.this! (' #protected))
+ (wrap []))))
+
+(def: inheritance_modifier^
+ (Parser InheritanceModifier)
+ (let [(^open ".") <>.monad]
+ ($_ <>.or
+ (<code>.this! (' #final))
+ (<code>.this! (' #abstract))
+ (wrap []))))
+
+(exception: #export (class_names_cannot_contain_periods {name Text})
+ (exception.report
+ ["Name" (%.text name)]))
+
+(exception: #export (class_name_cannot_be_a_type_variable {name Text}
+ {type_vars (List (Type Var))})
+ (exception.report
+ ["Name" (%.text name)]
+ ["Type Variables" (exception.enumerate parser.name type_vars)]))
+
+(def: (assert exception payload test)
+ (All [e] (-> (Exception e) e Bit (Parser Any)))
+ (<>.assert (exception.construct exception payload)
+ test))
+
+(def: (valid_class_name type_vars)
+ (-> (List (Type Var)) (Parser External))
+ (do <>.monad
+ [name <code>.local_identifier
+ _ (..assert ..class_names_cannot_contain_periods [name]
+ (not (text.contains? name.external_separator name)))
+ _ (..assert ..class_name_cannot_be_a_type_variable [name type_vars]
+ (not (list.member? text.equivalence
+ (list\map parser.name type_vars)
+ name)))]
+ (wrap name)))
+
+(def: (class^' parameter^ type_vars)
+ (-> (-> (List (Type Var)) (Parser (Type Parameter)))
+ (-> (List (Type Var)) (Parser (Type Class))))
+ (do <>.monad
+ [[name parameters] (: (Parser [External (List (Type Parameter))])
+ ($_ <>.either
+ (<>.and (valid_class_name type_vars)
+ (<>\wrap (list)))
+ (<code>.form (<>.and <code>.local_identifier
+ (<>.some (parameter^ type_vars))))))]
+ (wrap (type.class (name.sanitize name) parameters))))
+
+(exception: #export (unexpected_type_variable {name Text}
+ {type_vars (List (Type Var))})
+ (exception.report
+ ["Unexpected Type Variable" (%.text name)]
+ ["Expected Type Variables" (exception.enumerate parser.name type_vars)]))
+
+(def: (variable^ type_vars)
+ (-> (List (Type Var)) (Parser (Type Parameter)))
+ (do <>.monad
+ [name <code>.local_identifier
+ _ (..assert ..unexpected_type_variable [name type_vars]
+ (list.member? text.equivalence (list\map parser.name type_vars) name))]
+ (wrap (type.var name))))
+
+(def: wildcard^
+ (Parser (Type Parameter))
+ (do <>.monad
+ [_ (<code>.this! (' ?))]
+ (wrap type.wildcard)))
+
+(template [<name> <comparison> <constructor>]
+ [(def: <name>
+ (-> (Parser (Type Class)) (Parser (Type Parameter)))
+ (|>> (<>.after (<code>.this! (' <comparison>)))
+ (<>.after ..wildcard^)
+ <code>.tuple
+ (\ <>.monad map <constructor>)))]
+
+ [upper^ < type.upper]
+ [lower^ > type.lower]
+ )
+
+(def: (parameter^ type_vars)
+ (-> (List (Type Var)) (Parser (Type Parameter)))
+ (<>.rec
+ (function (_ recur^)
+ (let [class^ (..class^' parameter^ type_vars)]
+ ($_ <>.either
+ (..variable^ type_vars)
+ ..wildcard^
+ (upper^ class^)
+ (lower^ class^)
+ class^
+ )))))
+
+(def: (itself^ type)
+ (All [category]
+ (-> (Type (<| Return' Value' category))
+ (Parser (Type (<| Return' Value' category)))))
+ (do <>.monad
+ [_ (<code>.identifier! ["" (..reflection type)])]
+ (wrap type)))
+
+(def: primitive^
+ (Parser (Type Primitive))
+ ($_ <>.either
+ (itself^ type.boolean)
+ (itself^ type.byte)
+ (itself^ type.short)
+ (itself^ type.int)
+ (itself^ type.long)
+ (itself^ type.float)
+ (itself^ type.double)
+ (itself^ type.char)
+ ))
+
+(def: array^
+ (-> (Parser (Type Value)) (Parser (Type Array)))
+ (|>> <code>.tuple
+ (\ <>.monad map type.array)))
+
+(def: (type^ type_vars)
+ (-> (List (Type Var)) (Parser (Type Value)))
+ (<>.rec
+ (function (_ type^)
+ ($_ <>.either
+ ..primitive^
+ (..parameter^ type_vars)
+ (..array^ type^)
+ ))))
+
+(def: void^
+ (Parser (Type Void))
+ (do <>.monad
+ [_ (<code>.identifier! ["" (reflection.reflection reflection.void)])]
+ (wrap type.void)))
+
+(def: (return^ type_vars)
+ (-> (List (Type Var)) (Parser (Type Return)))
+ (<>.either ..void^
+ (..type^ type_vars)))
+
+(def: var^
+ (Parser (Type Var))
+ (\ <>.monad map type.var <code>.local_identifier))
+
+(def: vars^
+ (Parser (List (Type Var)))
+ (<code>.tuple (<>.some var^)))
+
+(def: declaration^
+ (Parser (Type Declaration))
+ (do <>.monad
+ [[name variables] (: (Parser [External (List (Type Var))])
+ (<>.either (<>.and (..valid_class_name (list))
+ (<>\wrap (list)))
+ (<code>.form (<>.and (..valid_class_name (list))
+ (<>.some var^)))
+ ))]
+ (wrap (type.declaration name variables))))
+
+(def: (class^ type_vars)
+ (-> (List (Type Var)) (Parser (Type Class)))
+ (class^' parameter^ type_vars))
+
+(def: annotation_parameters^
+ (Parser (List Annotation_Parameter))
+ (<code>.record (<>.some (<>.and <code>.local_tag <code>.any))))
+
+(def: annotation^
+ (Parser Annotation)
+ (<>.either (do <>.monad
+ [ann_name <code>.local_identifier]
+ (wrap [ann_name (list)]))
+ (<code>.form (<>.and <code>.local_identifier
+ annotation_parameters^))))
+
+(def: annotations^'
+ (Parser (List Annotation))
+ (do <>.monad
+ [_ (<code>.this! (' #ann))]
+ (<code>.tuple (<>.some ..annotation^))))
+
+(def: annotations^
+ (Parser (List Annotation))
+ (do <>.monad
+ [anns?? (<>.maybe ..annotations^')]
+ (wrap (maybe.default (list) anns??))))
+
+(def: (throws_decl^ type_vars)
+ (-> (List (Type Var)) (Parser (List (Type Class))))
+ (<| (<>.default (list))
+ (do <>.monad
+ [_ (<code>.this! (' #throws))]
+ (<code>.tuple (<>.some (..class^ type_vars))))))
+
+(def: (method_decl^ type_vars)
+ (-> (List (Type Var)) (Parser [Member_Declaration MethodDecl]))
+ (<code>.form (do <>.monad
+ [tvars (<>.default (list) ..vars^)
+ name <code>.local_identifier
+ anns ..annotations^
+ inputs (<code>.tuple (<>.some (..type^ type_vars)))
+ output (..return^ type_vars)
+ exs (throws_decl^ type_vars)]
+ (wrap [[name #PublicP anns] {#method_tvars tvars
+ #method_inputs inputs
+ #method_output output
+ #method_exs exs}]))))
+
+(def: state_modifier^
+ (Parser StateModifier)
+ ($_ <>.or
+ (<code>.this! (' #volatile))
+ (<code>.this! (' #final))
+ (\ <>.monad wrap [])))
+
+(def: (field_decl^ type_vars)
+ (-> (List (Type Var)) (Parser [Member_Declaration FieldDecl]))
+ (<>.either (<code>.form (do <>.monad
+ [_ (<code>.this! (' #const))
+ name <code>.local_identifier
+ anns ..annotations^
+ type (..type^ type_vars)
+ body <code>.any]
+ (wrap [[name #PublicP anns] (#ConstantField [type body])])))
+ (<code>.form (do <>.monad
+ [pm privacy_modifier^
+ sm state_modifier^
+ name <code>.local_identifier
+ anns ..annotations^
+ type (..type^ type_vars)]
+ (wrap [[name pm anns] (#VariableField [sm type])])))))
+
+(def: (argument^ type_vars)
+ (-> (List (Type Var)) (Parser Argument))
+ (<code>.record (<>.and <code>.local_identifier
+ (..type^ type_vars))))
+
+(def: (arguments^ type_vars)
+ (-> (List (Type Var)) (Parser (List Argument)))
+ (<>.some (..argument^ type_vars)))
+
+(def: (constructor_arg^ type_vars)
+ (-> (List (Type Var)) (Parser (Typed Code)))
+ (<code>.record (<>.and (..type^ type_vars) <code>.any)))
+
+(def: (constructor_args^ type_vars)
+ (-> (List (Type Var)) (Parser (List (Typed Code))))
+ (<code>.tuple (<>.some (..constructor_arg^ type_vars))))
+
+(def: (constructor_method^ class_vars)
+ (-> (List (Type Var)) (Parser [Member_Declaration Method_Definition]))
+ (<code>.form (do <>.monad
+ [pm privacy_modifier^
+ strict_fp? (<>.parses? (<code>.this! (' #strict)))
+ method_vars (<>.default (list) ..vars^)
+ #let [total_vars (list\compose class_vars method_vars)]
+ [_ self_name arguments] (<code>.form ($_ <>.and
+ (<code>.this! (' new))
+ <code>.local_identifier
+ (..arguments^ total_vars)))
+ constructor_args (..constructor_args^ total_vars)
+ exs (throws_decl^ total_vars)
+ annotations ..annotations^
+ body <code>.any]
+ (wrap [{#member_name constructor_method_name
+ #member_privacy pm
+ #member_anns annotations}
+ (#ConstructorMethod strict_fp? method_vars self_name arguments constructor_args body exs)]))))
+
+(def: (virtual_method_def^ class_vars)
+ (-> (List (Type Var)) (Parser [Member_Declaration Method_Definition]))
+ (<code>.form (do <>.monad
+ [pm privacy_modifier^
+ strict_fp? (<>.parses? (<code>.this! (' #strict)))
+ final? (<>.parses? (<code>.this! (' #final)))
+ method_vars (<>.default (list) ..vars^)
+ #let [total_vars (list\compose class_vars method_vars)]
+ [name self_name arguments] (<code>.form ($_ <>.and
+ <code>.local_identifier
+ <code>.local_identifier
+ (..arguments^ total_vars)))
+ return_type (..return^ total_vars)
+ exs (throws_decl^ total_vars)
+ annotations ..annotations^
+ body <code>.any]
+ (wrap [{#member_name name
+ #member_privacy pm
+ #member_anns annotations}
+ (#VirtualMethod final? strict_fp? method_vars self_name arguments return_type body exs)]))))
+
+(def: overriden_method_def^
+ (Parser [Member_Declaration Method_Definition])
+ (<code>.form (do <>.monad
+ [strict_fp? (<>.parses? (<code>.this! (' #strict)))
+ owner_class ..declaration^
+ method_vars (<>.default (list) ..vars^)
+ #let [total_vars (list\compose (product.right (parser.declaration owner_class))
+ method_vars)]
+ [name self_name arguments] (<code>.form ($_ <>.and
+ <code>.local_identifier
+ <code>.local_identifier
+ (..arguments^ total_vars)))
+ return_type (..return^ total_vars)
+ exs (throws_decl^ total_vars)
+ annotations ..annotations^
+ body <code>.any]
+ (wrap [{#member_name name
+ #member_privacy #PublicP
+ #member_anns annotations}
+ (#OverridenMethod strict_fp? owner_class method_vars self_name arguments return_type body exs)]))))
+
+(def: static_method_def^
+ (Parser [Member_Declaration Method_Definition])
+ (<code>.form (do <>.monad
+ [pm privacy_modifier^
+ strict_fp? (<>.parses? (<code>.this! (' #strict)))
+ _ (<code>.this! (' #static))
+ method_vars (<>.default (list) ..vars^)
+ #let [total_vars method_vars]
+ [name arguments] (<code>.form (<>.and <code>.local_identifier
+ (..arguments^ total_vars)))
+ return_type (..return^ total_vars)
+ exs (throws_decl^ total_vars)
+ annotations ..annotations^
+ body <code>.any]
+ (wrap [{#member_name name
+ #member_privacy pm
+ #member_anns annotations}
+ (#StaticMethod strict_fp? method_vars arguments return_type body exs)]))))
+
+(def: abstract_method_def^
+ (Parser [Member_Declaration Method_Definition])
+ (<code>.form (do <>.monad
+ [pm privacy_modifier^
+ _ (<code>.this! (' #abstract))
+ method_vars (<>.default (list) ..vars^)
+ #let [total_vars method_vars]
+ [name arguments] (<code>.form (<>.and <code>.local_identifier
+ (..arguments^ total_vars)))
+ return_type (..return^ total_vars)
+ exs (throws_decl^ total_vars)
+ annotations ..annotations^]
+ (wrap [{#member_name name
+ #member_privacy pm
+ #member_anns annotations}
+ (#AbstractMethod method_vars arguments return_type exs)]))))
+
+(def: native_method_def^
+ (Parser [Member_Declaration Method_Definition])
+ (<code>.form (do <>.monad
+ [pm privacy_modifier^
+ _ (<code>.this! (' #native))
+ method_vars (<>.default (list) ..vars^)
+ #let [total_vars method_vars]
+ [name arguments] (<code>.form (<>.and <code>.local_identifier
+ (..arguments^ total_vars)))
+ return_type (..return^ total_vars)
+ exs (throws_decl^ total_vars)
+ annotations ..annotations^]
+ (wrap [{#member_name name
+ #member_privacy pm
+ #member_anns annotations}
+ (#NativeMethod method_vars arguments return_type exs)]))))
+
+(def: (method_def^ class_vars)
+ (-> (List (Type Var)) (Parser [Member_Declaration Method_Definition]))
+ ($_ <>.either
+ (..constructor_method^ class_vars)
+ (..virtual_method_def^ class_vars)
+ ..overriden_method_def^
+ ..static_method_def^
+ ..abstract_method_def^
+ ..native_method_def^))
+
+(def: partial_call^
+ (Parser Partial_Call)
+ (<code>.form (<>.and <code>.identifier (<>.some <code>.any))))
+
+(def: class_kind^
+ (Parser Class_Kind)
+ (<>.either (do <>.monad
+ [_ (<code>.this! (' #class))]
+ (wrap #Class))
+ (do <>.monad
+ [_ (<code>.this! (' #interface))]
+ (wrap #Interface))
+ ))
+
+(def: import_member_alias^
+ (Parser (Maybe Text))
+ (<>.maybe (do <>.monad
+ [_ (<code>.this! (' #as))]
+ <code>.local_identifier)))
+
+(def: (import_member_args^ type_vars)
+ (-> (List (Type Var)) (Parser (List [Bit (Type Value)])))
+ (<code>.tuple (<>.some (<>.and (<>.parses? (<code>.tag! ["" "?"]))
+ (..type^ type_vars)))))
+
+(def: import_member_return_flags^
+ (Parser [Bit Bit Bit])
+ ($_ <>.and
+ (<>.parses? (<code>.this! (' #io)))
+ (<>.parses? (<code>.this! (' #try)))
+ (<>.parses? (<code>.this! (' #?)))))
+
+(def: primitive_mode^
+ (Parser Primitive_Mode)
+ (<>.or (<code>.tag! ["" "manual"])
+ (<code>.tag! ["" "auto"])))
+
+(def: (import_member_decl^ owner_vars)
+ (-> (List (Type Var)) (Parser Import_Member_Declaration))
+ ($_ <>.either
+ (<code>.form (do <>.monad
+ [_ (<code>.this! (' #enum))
+ enum_members (<>.some <code>.local_identifier)]
+ (wrap (#EnumDecl enum_members))))
+ (<code>.form (do <>.monad
+ [tvars (<>.default (list) ..vars^)
+ _ (<code>.identifier! ["" "new"])
+ ?alias import_member_alias^
+ #let [total_vars (list\compose owner_vars tvars)]
+ ?prim_mode (<>.maybe primitive_mode^)
+ args (..import_member_args^ total_vars)
+ [io? try? maybe?] import_member_return_flags^]
+ (wrap (#ConstructorDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode)
+ #import_member_alias (maybe.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?}
+ {}]))
+ ))
+ (<code>.form (do <>.monad
+ [kind (: (Parser ImportMethodKind)
+ (<>.or (<code>.tag! ["" "static"])
+ (wrap [])))
+ tvars (<>.default (list) ..vars^)
+ name <code>.local_identifier
+ ?alias import_member_alias^
+ #let [total_vars (list\compose owner_vars tvars)]
+ ?prim_mode (<>.maybe primitive_mode^)
+ args (..import_member_args^ total_vars)
+ [io? try? maybe?] import_member_return_flags^
+ return (..return^ total_vars)]
+ (wrap (#MethodDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode)
+ #import_member_alias (maybe.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}]))))
+ (<code>.form (do <>.monad
+ [static? (<>.parses? (<code>.this! (' #static)))
+ name <code>.local_identifier
+ ?prim_mode (<>.maybe primitive_mode^)
+ gtype (..type^ owner_vars)
+ maybe? (<>.parses? (<code>.this! (' #?)))
+ setter? (<>.parses? (<code>.this! (' #!)))]
+ (wrap (#FieldAccessDecl {#import_field_mode (maybe.default #AutoPrM ?prim_mode)
+ #import_field_name name
+ #import_field_static? static?
+ #import_field_maybe? maybe?
+ #import_field_setter? setter?
+ #import_field_type gtype}))))
+ ))
+
+(def: bundle
+ (-> (List (Type Var)) (Parser [Text (List Import_Member_Declaration)]))
+ (|>> ..import_member_decl^
+ <>.some
+ (<>.and <code>.text)
+ <code>.tuple))
+
+(def: (privacy_modifier$ pm)
+ (-> Privacy Code)
+ (case pm
+ #PublicP (code.text "public")
+ #PrivateP (code.text "private")
+ #ProtectedP (code.text "protected")
+ #DefaultP (code.text "default")))
+
+(def: (inheritance_modifier$ im)
+ (-> InheritanceModifier Code)
+ (case im
+ #FinalIM (code.text "final")
+ #AbstractIM (code.text "abstract")
+ #DefaultIM (code.text "default")))
+
+(def: (annotation_parameter$ [name value])
+ (-> Annotation_Parameter Code)
+ (` [(~ (code.text name)) (~ value)]))
+
+(def: (annotation$ [name params])
+ (-> Annotation Code)
+ (` ((~ (code.text name)) (~+ (list\map annotation_parameter$ params)))))
+
+(template [<name> <category>]
+ [(def: <name>
+ (-> (Type <category>) Code)
+ (|>> ..signature code.text))]
+
+ [var$ Var]
+ [parameter$ Parameter]
+ [value$ Value]
+ [return$ Return]
+ [declaration$ Declaration]
+ [class$ Class]
+ )
+
+(def: var$'
+ (-> (Type Var) Code)
+ (|>> ..signature code.local_identifier))
+
+(def: (method_decl$ [[name pm anns] method_decl])
+ (-> [Member_Declaration MethodDecl] Code)
+ (let [(^slots [#method_tvars #method_inputs #method_output #method_exs]) method_decl]
+ (` ((~ (code.text name))
+ [(~+ (list\map annotation$ anns))]
+ [(~+ (list\map var$ method_tvars))]
+ [(~+ (list\map class$ method_exs))]
+ [(~+ (list\map value$ method_inputs))]
+ (~ (return$ method_output))))))
+
+(def: (state_modifier$ sm)
+ (-> StateModifier Code)
+ (case sm
+ #VolatileSM (' "volatile")
+ #FinalSM (' "final")
+ #DefaultSM (' "default")))
+
+(def: (field_decl$ [[name pm anns] field])
+ (-> [Member_Declaration FieldDecl] Code)
+ (case field
+ (#ConstantField class value)
+ (` ("constant" (~ (code.text name))
+ [(~+ (list\map annotation$ anns))]
+ (~ (value$ class))
+ (~ value)
+ ))
+
+ (#VariableField sm class)
+ (` ("variable" (~ (code.text name))
+ (~ (privacy_modifier$ pm))
+ (~ (state_modifier$ sm))
+ [(~+ (list\map annotation$ anns))]
+ (~ (value$ class))
+ ))
+ ))
+
+(def: (argument$ [name type])
+ (-> Argument Code)
+ (` [(~ (code.text name)) (~ (value$ type))]))
+
+(def: (constructor_arg$ [class term])
+ (-> (Typed Code) Code)
+ (` [(~ (value$ class)) (~ term)]))
+
+(def: (method_def$ replacer super_class [[name pm anns] method_def])
+ (-> (-> Code Code) (Type Class) [Member_Declaration Method_Definition] Code)
+ (case method_def
+ (#ConstructorMethod strict_fp? type_vars self_name arguments constructor_args body exs)
+ (` ("init"
+ (~ (privacy_modifier$ pm))
+ (~ (code.bit strict_fp?))
+ [(~+ (list\map annotation$ anns))]
+ [(~+ (list\map var$ type_vars))]
+ [(~+ (list\map class$ exs))]
+ (~ (code.text self_name))
+ [(~+ (list\map argument$ arguments))]
+ [(~+ (list\map constructor_arg$ constructor_args))]
+ (~ (pre_walk_replace replacer body))
+ ))
+
+ (#VirtualMethod final? strict_fp? type_vars self_name arguments return_type body exs)
+ (` ("virtual"
+ (~ (code.text name))
+ (~ (privacy_modifier$ pm))
+ (~ (code.bit final?))
+ (~ (code.bit strict_fp?))
+ [(~+ (list\map annotation$ anns))]
+ [(~+ (list\map var$ type_vars))]
+ (~ (code.text self_name))
+ [(~+ (list\map argument$ arguments))]
+ (~ (return$ return_type))
+ [(~+ (list\map class$ exs))]
+ (~ (pre_walk_replace replacer body))))
+
+ (#OverridenMethod strict_fp? declaration type_vars self_name arguments return_type body exs)
+ (let [super_replacer (parser->replacer (<code>.form (do <>.monad
+ [_ (<code>.this! (' ::super!))
+ args (<code>.tuple (<>.exactly (list.size arguments) <code>.any))]
+ (wrap (` ("jvm member invoke special"
+ (~ (code.text (product.left (parser.read_class super_class))))
+ (~ (code.text name))
+ (~' _jvm_this)
+ (~+ (|> args
+ (list.zip/2 (list\map product.right arguments))
+ (list\map ..decorate_input)))))))))]
+ (` ("override"
+ (~ (declaration$ declaration))
+ (~ (code.text name))
+ (~ (code.bit strict_fp?))
+ [(~+ (list\map annotation$ anns))]
+ [(~+ (list\map var$ type_vars))]
+ (~ (code.text self_name))
+ [(~+ (list\map argument$ arguments))]
+ (~ (return$ return_type))
+ [(~+ (list\map class$ exs))]
+ (~ (|> body
+ (pre_walk_replace replacer)
+ (pre_walk_replace super_replacer)))
+ )))
+
+ (#StaticMethod strict_fp? type_vars arguments return_type body exs)
+ (` ("static"
+ (~ (code.text name))
+ (~ (privacy_modifier$ pm))
+ (~ (code.bit strict_fp?))
+ [(~+ (list\map annotation$ anns))]
+ [(~+ (list\map var$ type_vars))]
+ [(~+ (list\map class$ exs))]
+ [(~+ (list\map argument$ arguments))]
+ (~ (return$ return_type))
+ (~ (pre_walk_replace replacer body))))
+
+ (#AbstractMethod type_vars arguments return_type exs)
+ (` ("abstract"
+ (~ (code.text name))
+ (~ (privacy_modifier$ pm))
+ [(~+ (list\map annotation$ anns))]
+ [(~+ (list\map var$ type_vars))]
+ [(~+ (list\map class$ exs))]
+ [(~+ (list\map argument$ arguments))]
+ (~ (return$ return_type))))
+
+ (#NativeMethod type_vars arguments return_type exs)
+ (` ("native"
+ (~ (code.text name))
+ (~ (privacy_modifier$ pm))
+ [(~+ (list\map annotation$ anns))]
+ [(~+ (list\map var$ type_vars))]
+ [(~+ (list\map class$ exs))]
+ [(~+ (list\map argument$ arguments))]
+ (~ (return$ return_type))))
+ ))
+
+(def: (complete_call$ g!obj [method args])
+ (-> Code Partial_Call Code)
+ (` ((~ (code.identifier method)) (~+ args) (~ g!obj))))
+
+(def: $Object
+ (Type Class)
+ (type.class "java.lang.Object" (list)))
+
+(syntax: #export (class:
+ {#let [! <>.monad]}
+ {im inheritance_modifier^}
+ {[full_class_name class_vars] (\ ! map parser.declaration ..declaration^)}
+ {super (<>.default $Object
+ (class^ class_vars))}
+ {interfaces (<>.default (list)
+ (<code>.tuple (<>.some (class^ class_vars))))}
+ {annotations ..annotations^}
+ {fields (<>.some (..field_decl^ class_vars))}
+ {methods (<>.some (..method_def^ class_vars))})
+ {#.doc (doc "Allows defining JVM classes in Lux code."
+ "For example:"
+ (class: #final (TestClass A) [Runnable]
+ ## Fields
+ (#private foo boolean)
+ (#private bar A)
+ (#private baz java/lang/Object)
+ ## Methods
+ (#public [] (new [value A]) []
+ (exec (:= ::foo #1)
+ (:= ::bar value)
+ (:= ::baz "")
+ []))
+ (#public (virtual) java/lang/Object
+ "")
+ (#public #static (static) java/lang/Object
+ "")
+ (Runnable [] (run) void
+ [])
+ )
+
+ "The tuple corresponds to parent interfaces."
+ "An optional super-class can be specified before the tuple. 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 #1) for modifying it."
+ "(::new! []) for calling the class's constructor."
+ "(::resolve! container [value]) for calling the 'resolve' method."
+ )}
+ (do meta.monad
+ [current_module meta.current_module_name
+ #let [fully_qualified_class_name (name.qualify current_module full_class_name)
+ field_parsers (list\map (field->parser fully_qualified_class_name) fields)
+ method_parsers (list\map (method->parser fully_qualified_class_name) methods)
+ replacer (parser->replacer (list\fold <>.either
+ (<>.fail "")
+ (list\compose field_parsers method_parsers)))]]
+ (wrap (list (` ("jvm class"
+ (~ (declaration$ (type.declaration (name.qualify current_module full_class_name) class_vars)))
+ (~ (class$ super))
+ [(~+ (list\map class$ interfaces))]
+ (~ (inheritance_modifier$ im))
+ [(~+ (list\map annotation$ annotations))]
+ [(~+ (list\map field_decl$ fields))]
+ [(~+ (list\map (method_def$ replacer super) methods))]))))))
+
+(syntax: #export (interface:
+ {#let [! <>.monad]}
+ {[full_class_name class_vars] (\ ! map parser.declaration ..declaration^)}
+ {supers (<>.default (list)
+ (<code>.tuple (<>.some (class^ class_vars))))}
+ {annotations ..annotations^}
+ {members (<>.some (..method_decl^ class_vars))})
+ {#.doc (doc "Allows defining JVM interfaces."
+ (interface: TestInterface
+ ([] foo [boolean String] void #throws [Exception])))}
+ (do meta.monad
+ [current_module meta.current_module_name]
+ (wrap (list (` ("jvm class interface"
+ (~ (declaration$ (type.declaration (name.qualify current_module full_class_name) class_vars)))
+ [(~+ (list\map class$ supers))]
+ [(~+ (list\map annotation$ annotations))]
+ (~+ (list\map method_decl$ members))))))))
+
+(syntax: #export (object
+ {class_vars ..vars^}
+ {super (<>.default $Object
+ (class^ class_vars))}
+ {interfaces (<>.default (list)
+ (<code>.tuple (<>.some (class^ class_vars))))}
+ {constructor_args (..constructor_args^ class_vars)}
+ {methods (<>.some ..overriden_method_def^)})
+ {#.doc (doc "Allows defining anonymous classes."
+ "The 1st tuple corresponds to class-level type-variables."
+ "The 2nd tuple corresponds to parent interfaces."
+ "The 3rd tuple corresponds to arguments to the super class constructor."
+ "An optional super-class can be specified before the 1st tuple. If not specified, java.lang.Object will be assumed."
+ (object [] [Runnable]
+ []
+ (Runnable [] (run self) void
+ (exec (do_something some_value)
+ [])))
+ )}
+ (wrap (list (` ("jvm class anonymous"
+ [(~+ (list\map var$ class_vars))]
+ (~ (class$ super))
+ [(~+ (list\map class$ interfaces))]
+ [(~+ (list\map constructor_arg$ constructor_args))]
+ [(~+ (list\map (method_def$ function.identity super) methods))])))))
+
+(syntax: #export (null)
+ {#.doc (doc "Null object reference."
+ (null))}
+ (wrap (list (` ("jvm object null")))))
+
+(def: #export (null? obj)
+ {#.doc (doc "Test for null object reference."
+ (= (null? (null))
+ true)
+ (= (null? "YOLO")
+ false))}
+ (-> (primitive "java.lang.Object") Bit)
+ ("jvm object null?" obj))
+
+(syntax: #export (??? expr)
+ {#.doc (doc "Takes a (potentially null) ObjectType reference and creates a (Maybe ObjectType) for it."
+ (= (??? (: java/lang/String (null)))
+ #.None)
+ (= (??? "YOLO")
+ (#.Some "YOLO")))}
+ (with_gensyms [g!temp]
+ (wrap (list (` (let [(~ g!temp) (~ expr)]
+ (if ("jvm object null?" (~ g!temp))
+ #.None
+ (#.Some (~ g!temp)))))))))
+
+(syntax: #export (!!! expr)
+ {#.doc (doc "Takes a (Maybe ObjectType) and returns a ObjectType."
+ "A #.None would get translated into a (null)."
+ (= (null)
+ (!!! (??? (: java/lang/Thread (null)))))
+ (= "foo"
+ (!!! (??? "foo"))))}
+ (with_gensyms [g!value]
+ (wrap (list (` ({(#.Some (~ g!value))
+ (~ g!value)
+
+ #.None
+ ("jvm object null")}
+ (~ expr)))))))
+
+(syntax: #export (check {class (..type^ (list))}
+ {unchecked (<>.maybe <code>.any)})
+ {#.doc (doc "Checks whether an object is an instance of a particular class."
+ "Caveat emptor: Cannot check for polymorphism, so avoid using parameterized classes."
+ (case (check String "YOLO")
+ (#.Some value_as_string)
+ #.None))}
+ (with_gensyms [g!_ g!unchecked]
+ (let [class_name (..reflection class)
+ class_type (` (.primitive (~ (code.text class_name))))
+ check_type (` (.Maybe (~ class_type)))
+ check_code (` (if ("jvm object instance?" (~ (code.text class_name)) (~ g!unchecked))
+ (#.Some (.:as (~ class_type)
+ (~ g!unchecked)))
+ #.None))]
+ (case unchecked
+ (#.Some unchecked)
+ (wrap (list (` (: (~ check_type)
+ (let [(~ g!unchecked) (~ unchecked)]
+ (~ check_code))))))
+
+ #.None
+ (wrap (list (` (: (-> (primitive "java.lang.Object") (~ check_type))
+ (function ((~ g!_) (~ g!unchecked))
+ (~ check_code))))))
+ ))))
+
+(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 (` ("jvm object synchronized" (~ lock) (~ body))))))
+
+(syntax: #export (do_to obj {methods (<>.some partial_call^)})
+ {#.doc (doc "Call a variety of methods on an object. Then, return the object."
+ (do_to object
+ (ClassName::method1 arg0 arg1 arg2)
+ (ClassName::method2 arg3 arg4 arg5)))}
+ (with_gensyms [g!obj]
+ (wrap (list (` (let [(~ g!obj) (~ obj)]
+ (exec (~+ (list\map (complete_call$ g!obj) methods))
+ (~ g!obj))))))))
+
+(def: (class_import$ declaration)
+ (-> (Type Declaration) Code)
+ (let [[full_name params] (parser.declaration declaration)
+ def_name (..internal full_name)
+ params' (list\map ..var$' params)]
+ (` (def: (~ (code.identifier ["" def_name]))
+ {#..jvm_class (~ (code.text (..internal full_name)))}
+ .Type
+ (All [(~+ params')]
+ (primitive (~ (code.text full_name))
+ [(~+ params')]))))))
+
+(def: (member_type_vars class_tvars member)
+ (-> (List (Type Var)) Import_Member_Declaration (List (Type Var)))
+ (case member
+ (#ConstructorDecl [commons _])
+ (list\compose class_tvars (get@ #import_member_tvars commons))
+
+ (#MethodDecl [commons _])
+ (case (get@ #import_member_kind commons)
+ #StaticIMK
+ (get@ #import_member_tvars commons)
+
+ _
+ (list\compose class_tvars (get@ #import_member_tvars commons)))
+
+ _
+ class_tvars))
+
+(def: (member_def_arg_bindings vars member)
+ (-> (List (Type Var)) Import_Member_Declaration (Meta [(List [Bit Code]) (List (Type Value)) (List Code)]))
+ (case member
+ (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
+ (let [(^slots [#import_member_tvars #import_member_args]) commons]
+ (do {! meta.monad}
+ [arg_inputs (monad.map !
+ (: (-> [Bit (Type Value)] (Meta [Bit Code]))
+ (function (_ [maybe? _])
+ (with_gensyms [arg_name]
+ (wrap [maybe? arg_name]))))
+ import_member_args)
+ #let [input_jvm_types (list\map product.right import_member_args)
+ arg_types (list\map (: (-> [Bit (Type Value)] Code)
+ (function (_ [maybe? arg])
+ (let [arg_type (value_type (get@ #import_member_mode commons) arg)]
+ (if maybe?
+ (` (Maybe (~ arg_type)))
+ arg_type))))
+ import_member_args)]]
+ (wrap [arg_inputs input_jvm_types arg_types])))
+
+ _
+ (\ meta.monad wrap [(list) (list) (list)])))
+
+(def: (decorate_return_maybe member never_null? unboxed return_term)
+ (-> Import_Member_Declaration Bit (Type Value) Code Code)
+ (case member
+ (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
+ (cond (or never_null?
+ (dictionary.key? ..boxes unboxed))
+ return_term
+
+ (get@ #import_member_maybe? commons)
+ (` (??? (~ return_term)))
+
+ ## else
+ (let [g!temp (` ((~' ~') (~ (code.identifier ["" " Ω "]))))]
+ (` (let [(~ g!temp) (~ return_term)]
+ (if (not (..null? (:as (primitive "java.lang.Object")
+ (~ g!temp))))
+ (~ g!temp)
+ (error! "Cannot produce null references from method calls."))))))
+
+ _
+ return_term))
+
+(template [<name> <tag> <term_trans>]
+ [(def: (<name> member return_term)
+ (-> Import_Member_Declaration Code Code)
+ (case member
+ (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
+ (if (get@ <tag> commons)
+ <term_trans>
+ return_term)
+
+ _
+ return_term))]
+
+ [decorate_return_try #import_member_try? (` (.try (~ return_term)))]
+ [decorate_return_io #import_member_io? (` ((~! io.io) (~ return_term)))]
+ )
+
+(def: $String
+ (type.class "java.lang.String" (list)))
+
+(template [<input?> <name> <unbox/box> <special+>]
+ [(def: (<name> mode [unboxed raw])
+ (-> Primitive_Mode [(Type Value) Code] Code)
+ (let [[unboxed refined post] (: [(Type Value) Code (List Code)]
+ (case mode
+ #ManualPrM
+ [unboxed raw (list)]
+
+ #AutoPrM
+ (with_expansions [<special+>' (template.splice <special+>)
+ <cond_cases> (template [<old> <new> <pre> <post>]
+ [(\ type.equivalence = <old> unboxed)
+ (with_expansions [<post>' (template.splice <post>)]
+ [<new>
+ (` (.|> (~ raw) (~+ <pre>)))
+ (list <post>')])]
+
+ <special+>')]
+ (cond <cond_cases>
+ ## else
+ [unboxed
+ (if <input?>
+ (` ("jvm object cast" (~ raw)))
+ raw)
+ (list)]))))
+ unboxed/boxed (case (dictionary.get unboxed ..boxes)
+ (#.Some boxed)
+ (<unbox/box> unboxed boxed refined)
+
+ #.None
+ refined)]
+ (case post
+ #.Nil
+ unboxed/boxed
+
+ _
+ (` (.|> (~ unboxed/boxed) (~+ post))))))]
+
+ [#1 auto_convert_input ..unbox
+ [[type.boolean type.boolean (list (` (.: .Bit)) (` (.:as (.primitive (~ (code.text box.boolean)))))) []]
+ [type.byte type.byte (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long))))) (` ..long_to_byte)) []]
+ [type.short type.short (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long))))) (` ..long_to_short)) []]
+ [type.int type.int (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long))))) (` ..long_to_int)) []]
+ [type.long type.long (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long)))))) []]
+ [type.float type.float (list (` (.: .Frac)) (` (.:as (.primitive (~ (code.text box.double))))) (` ..double_to_float)) []]
+ [type.double type.double (list (` (.: .Frac)) (` (.:as (.primitive (~ (code.text box.double)))))) []]
+ [..$String ..$String (list (` (.: .Text)) (` (.:as (.primitive (~ (code.text (..reflection ..$String))))))) []]
+ [(type.class box.boolean (list)) (type.class box.boolean (list)) (list (` (.: .Bit)) (` (.:as (.primitive (~ (code.text box.boolean)))))) []]
+ [(type.class box.long (list)) (type.class box.long (list)) (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long)))))) []]
+ [(type.class box.double (list)) (type.class box.double (list)) (list (` (.: .Frac)) (` (.:as (.primitive (~ (code.text box.double)))))) []]]]
+ [#0 auto_convert_output ..box
+ [[type.boolean type.boolean (list) [(` (.: (.primitive (~ (code.text box.boolean))))) (` (.:as .Bit))]]
+ [type.byte type.long (list (` "jvm conversion byte-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]]
+ [type.short type.long (list (` "jvm conversion short-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]]
+ [type.int type.long (list (` "jvm conversion int-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]]
+ [type.long type.long (list) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]]
+ [type.float type.double (list (` "jvm conversion float-to-double")) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:as .Frac))]]
+ [type.double type.double (list) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:as .Frac))]]
+ [..$String ..$String (list) [(` (.: (.primitive (~ (code.text (..reflection ..$String)))))) (` (.:as .Text))]]
+ [(type.class box.boolean (list)) (type.class box.boolean (list)) (list) [(` (.: (.primitive (~ (code.text box.boolean))))) (` (.:as .Bit))]]
+ [(type.class box.long (list)) (type.class box.long (list)) (list) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]]
+ [(type.class box.double (list)) (type.class box.double (list)) (list) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:as .Frac))]]]]
+ )
+
+(def: (un_quote quoted)
+ (-> Code Code)
+ (` ((~' ~) (~ quoted))))
+
+(def: (jvm_invoke_inputs mode classes inputs)
+ (-> Primitive_Mode (List (Type Value)) (List [Bit Code]) (List Code))
+ (|> inputs
+ (list.zip/2 classes)
+ (list\map (function (_ [class [maybe? input]])
+ (|> (if maybe?
+ (` (: (.primitive (~ (code.text (..reflection class))))
+ ((~! !!!) (~ (un_quote input)))))
+ (un_quote input))
+ [class]
+ (auto_convert_input mode))))))
+
+(def: (import_name format class member)
+ (-> Text Text Text Text)
+ (|> format
+ (text.replace_all "#" class)
+ (text.replace_all "." member)))
+
+(def: (member_def_interop vars kind class [arg_function_inputs input_jvm_types arg_types] member method_prefix import_format)
+ (-> (List (Type Var)) Class_Kind (Type Declaration) [(List [Bit Code]) (List (Type Value)) (List Code)] Import_Member_Declaration Text Text (Meta (List Code)))
+ (let [[full_name class_tvars] (parser.declaration class)]
+ (case member
+ (#EnumDecl enum_members)
+ (do meta.monad
+ [#let [enum_type (: Code
+ (case class_tvars
+ #.Nil
+ (` (primitive (~ (code.text full_name))))
+
+ _
+ (let [=class_tvars (list\map ..var$' class_tvars)]
+ (` (All [(~+ =class_tvars)] (primitive (~ (code.text full_name)) [(~+ =class_tvars)]))))))
+ getter_interop (: (-> Text Code)
+ (function (_ name)
+ (let [getter_name (code.identifier ["" (..import_name import_format method_prefix name)])]
+ (` (def: (~ getter_name)
+ (~ enum_type)
+ (~ (get_static_field full_name name)))))))]]
+ (wrap (list\map getter_interop enum_members)))
+
+ (#ConstructorDecl [commons _])
+ (do meta.monad
+ [#let [classT (type.class full_name (list))
+ def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))])
+ jvm_interop (|> [classT
+ (` ("jvm member invoke constructor"
+ [(~+ (list\map ..var$ class_tvars))]
+ (~ (code.text full_name))
+ [(~+ (list\map ..var$ (get@ #import_member_tvars commons)))]
+ (~+ (|> (jvm_invoke_inputs (get@ #import_member_mode commons) input_jvm_types arg_function_inputs)
+ (list.zip/2 input_jvm_types)
+ (list\map ..decorate_input)))))]
+ (auto_convert_output (get@ #import_member_mode commons))
+ (decorate_return_maybe member true classT)
+ (decorate_return_try member)
+ (decorate_return_io member))]]
+ (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs)))
+ ((~' wrap) (.list (.` (~ jvm_interop)))))))))
+
+ (#MethodDecl [commons method])
+ (with_gensyms [g!obj]
+ (do meta.monad
+ [#let [def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))])
+ (^slots [#import_member_kind]) commons
+ (^slots [#import_method_name]) method
+ [jvm_op object_ast] (: [Text (List Code)]
+ (case import_member_kind
+ #StaticIMK
+ ["jvm member invoke static"
+ (list)]
+
+ #VirtualIMK
+ (case kind
+ #Class
+ ["jvm member invoke virtual"
+ (list g!obj)]
+
+ #Interface
+ ["jvm member invoke interface"
+ (list g!obj)]
+ )))
+ method_return (get@ #import_method_return method)
+ callC (: Code
+ (` ((~ (code.text jvm_op))
+ [(~+ (list\map ..var$ class_tvars))]
+ (~ (code.text full_name))
+ (~ (code.text import_method_name))
+ [(~+ (list\map ..var$ (get@ #import_member_tvars commons)))]
+ (~+ (|> object_ast
+ (list\map ..un_quote)
+ (list.zip/2 (list (type.class full_name (list))))
+ (list\map (auto_convert_input (get@ #import_member_mode commons)))))
+ (~+ (|> (jvm_invoke_inputs (get@ #import_member_mode commons) input_jvm_types arg_function_inputs)
+ (list.zip/2 input_jvm_types)
+ (list\map ..decorate_input))))))
+ jvm_interop (: Code
+ (case (type.void? method_return)
+ (#.Left method_return)
+ (|> [method_return
+ callC]
+ (auto_convert_output (get@ #import_member_mode commons))
+ (decorate_return_maybe member false method_return)
+ (decorate_return_try member)
+ (decorate_return_io member))
+
+
+ (#.Right method_return)
+ (|> callC
+ (decorate_return_try member)
+ (decorate_return_io member))))]]
+ (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs)) (~+ object_ast))
+ ((~' wrap) (.list (.` (~ jvm_interop))))))))))
+
+ (#FieldAccessDecl fad)
+ (do meta.monad
+ [#let [(^open ".") fad
+ getter_name (code.identifier ["" (..import_name import_format method_prefix import_field_name)])
+ setter_name (code.identifier ["" (..import_name import_format method_prefix (format import_field_name "!"))])]
+ getter_interop (with_gensyms [g!obj]
+ (let [getter_call (if import_field_static?
+ (` ((~ getter_name)))
+ (` ((~ getter_name) (~ g!obj))))
+ getter_body (<| (auto_convert_output import_field_mode)
+ [import_field_type
+ (if import_field_static?
+ (get_static_field full_name import_field_name)
+ (get_virtual_field full_name import_field_name (un_quote g!obj)))])
+ getter_body (if import_field_maybe?
+ (` ((~! ???) (~ getter_body)))
+ getter_body)
+ getter_body (if import_field_setter?
+ (` ((~! io.io) (~ getter_body)))
+ getter_body)]
+ (wrap (` ((~! syntax:) (~ getter_call)
+ ((~' wrap) (.list (.` (~ getter_body)))))))))
+ setter_interop (: (Meta (List Code))
+ (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_value (|> [import_field_type (un_quote g!value)]
+ (auto_convert_input import_field_mode))
+ setter_value (if import_field_maybe?
+ (` ((~! !!!) (~ setter_value)))
+ setter_value)
+ setter_command (format (if import_field_static? "jvm putstatic" "jvm putfield")
+ ":" full_name ":" import_field_name)
+ g!obj+ (: (List Code)
+ (if import_field_static?
+ (list)
+ (list (un_quote g!obj))))]
+ (wrap (list (` ((~! syntax:) (~ setter_call)
+ ((~' wrap) (.list (.` ((~! io.io) ((~ (code.text setter_command)) (~+ g!obj+) (~ setter_value))))))))))))
+ (wrap (list))))]
+ (wrap (list& getter_interop setter_interop)))
+ )))
+
+(def: (member_import$ vars kind class [import_format member])
+ (-> (List (Type Var)) Class_Kind (Type Declaration) [Text Import_Member_Declaration] (Meta (List Code)))
+ (let [[full_name _] (parser.declaration class)
+ method_prefix (..internal full_name)]
+ (do meta.monad
+ [=args (member_def_arg_bindings vars member)]
+ (member_def_interop vars kind class =args member method_prefix import_format))))
+
+(def: interface?
+ (All [a] (-> (primitive "java.lang.Class" [a]) Bit))
+ (|>> ("jvm member invoke virtual" [] "java.lang.Class" "isInterface" [])
+ "jvm object cast"
+ (: ..Boolean)
+ (:as Bit)))
+
+(def: load_class
+ (-> External (Try (primitive "java.lang.Class" [Any])))
+ (|>> (:as (primitive "java.lang.String"))
+ ["Ljava/lang/String;"]
+ ("jvm member invoke static" [] "java.lang.Class" "forName" [])
+ try))
+
+(def: (class_kind declaration)
+ (-> (Type Declaration) (Meta Class_Kind))
+ (let [[class_name _] (parser.declaration declaration)]
+ (case (load_class class_name)
+ (#.Right class)
+ (\ meta.monad wrap (if (interface? class)
+ #Interface
+ #Class))
+
+ (#.Left _)
+ (meta.fail (format "Unknown class: " class_name)))))
+
+(syntax: #export (import:
+ {declaration ..declaration^}
+ {#let [[class_name class_type_vars] (parser.declaration declaration)]}
+ {bundles (<>.some (..bundle class_type_vars))})
+ {#.doc (doc "Allows importing JVM classes, and using them as types."
+ "Their methods, fields and enum options can also be imported."
+ (import: java/lang/Object
+ ["#::."
+ (new [])
+ (equals [java/lang/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 Try 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)."
+ (import: java/lang/String
+ ["#::."
+ (new [[byte]])
+ (#static valueOf [char] java/lang/String)
+ (#static valueOf #as int_valueOf [int] java/lang/String)])
+
+ (import: (java/util/List e)
+ ["#::."
+ (size [] int)
+ (get [int] e)])
+
+ (import: (java/util/ArrayList a)
+ ["#::."
+ ([T] toArray [[T]] [T])])
+
+ "The class-type that is generated is of the fully-qualified name."
+ "This avoids a clash between the java.util.List type, and Lux's own List type."
+ "All enum options to be imported must be specified."
+ (import: java/lang/Character$UnicodeScript
+ ["#::."
+ (#enum ARABIC CYRILLIC LATIN)])
+
+ "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-vars."
+ "Lux types, such as Maybe cannot be named (otherwise, they'd be confused for Java classes)."
+ (import: (lux/concurrency/promise/JvmPromise A)
+ ["#::."
+ (resolve [A] boolean)
+ (poll [] A)
+ (wasResolved [] boolean)
+ (waitOn [lux/Function] void)
+ (#static [A] make [A] (lux/concurrency/promise/JvmPromise A))])
+
+ "Also, the names of the imported members will look like Class::member"
+ (java/lang/Object::new [])
+ (java/lang/Object::equals [other_object] my_object)
+ (java/util/List::size [] my_list)
+ java/lang/Character$UnicodeScript::LATIN
+ )}
+ (do {! meta.monad}
+ [kind (class_kind declaration)
+ =members (|> bundles
+ (list\map (function (_ [import_format members])
+ (list\map (|>> [import_format]) members)))
+ list.concat
+ (monad.map ! (member_import$ class_type_vars kind declaration)))]
+ (wrap (list& (class_import$ declaration) (list\join =members)))))
+
+(syntax: #export (array {type (..type^ (list))}
+ size)
+ {#.doc (doc "Create an array of the given type, with the given size."
+ (array java/lang/Object 10))}
+ (let [g!size (` (|> (~ size)
+ (.: .Nat)
+ (.:as (.primitive (~ (code.text box.long))))
+ "jvm object cast"
+ "jvm conversion long-to-int"))]
+ (`` (cond (~~ (template [<primitive> <array_op>]
+ [(\ type.equivalence = <primitive> type)
+ (wrap (list (` (<array_op> (~ g!size)))))]
+
+ [type.boolean "jvm array new boolean"]
+ [type.byte "jvm array new byte"]
+ [type.short "jvm array new short"]
+ [type.int "jvm array new int"]
+ [type.long "jvm array new long"]
+ [type.float "jvm array new float"]
+ [type.double "jvm array new double"]
+ [type.char "jvm array new char"]))
+ ## else
+ (wrap (list (` (: (~ (value_type #ManualPrM (type.array type)))
+ ("jvm array new object" (~ g!size))))))))))
+
+(exception: #export (cannot_convert_to_jvm_type {type .Type})
+ (exception.report
+ ["Lux Type" (%.type type)]))
+
+(with_expansions [<failure> (as_is (meta.fail (exception.construct ..cannot_convert_to_jvm_type [type])))]
+ (def: (lux_type->jvm_type type)
+ (-> .Type (Meta (Type Value)))
+ (if (lux_type\= .Any type)
+ (\ meta.monad wrap $Object)
+ (case type
+ (#.Primitive name params)
+ (`` (cond (~~ (template [<type>]
+ [(text\= (..reflection <type>) name)
+ (case params
+ #.Nil
+ (\ meta.monad wrap <type>)
+
+ _
+ <failure>)]
+
+ [type.boolean]
+ [type.byte]
+ [type.short]
+ [type.int]
+ [type.long]
+ [type.float]
+ [type.double]
+ [type.char]))
+
+ (~~ (template [<type>]
+ [(text\= (..reflection (type.array <type>)) name)
+ (case params
+ #.Nil
+ (\ meta.monad wrap (type.array <type>))
+
+ _
+ <failure>)]
+
+ [type.boolean]
+ [type.byte]
+ [type.short]
+ [type.int]
+ [type.long]
+ [type.float]
+ [type.double]
+ [type.char]))
+
+ (text\= array.type_name name)
+ (case params
+ (#.Cons elementLT #.Nil)
+ (\ meta.monad map type.array
+ (lux_type->jvm_type elementLT))
+
+ _
+ <failure>)
+
+ (text.starts_with? descriptor.array_prefix name)
+ (case params
+ #.Nil
+ (let [[_ unprefixed] (maybe.assume (text.split_with descriptor.array_prefix name))]
+ (\ meta.monad map type.array
+ (lux_type->jvm_type (#.Primitive unprefixed (list)))))
+
+ _
+ <failure>)
+
+ ## else
+ (\ meta.monad map (type.class name)
+ (: (Meta (List (Type Parameter)))
+ (monad.map meta.monad
+ (function (_ paramLT)
+ (do meta.monad
+ [paramJT (lux_type->jvm_type paramLT)]
+ (case (parser.parameter? paramJT)
+ (#.Some paramJT)
+ (wrap paramJT)
+
+ #.None
+ <failure>)))
+ params)))))
+
+ (#.Apply A F)
+ (case (lux_type.apply (list A) F)
+ #.None
+ <failure>
+
+ (#.Some type')
+ (lux_type->jvm_type type'))
+
+ (#.Named _ type')
+ (lux_type->jvm_type type')
+
+ _
+ <failure>))))
+
+(syntax: #export (array_length array)
+ {#.doc (doc "Gives the length of an array."
+ (array_length my_array))}
+ (case array
+ [_ (#.Identifier array_name)]
+ (do meta.monad
+ [array_type (meta.find_type array_name)
+ array_jvm_type (lux_type->jvm_type array_type)
+ #let [g!extension (code.text (`` (cond (~~ (template [<primitive> <extension>]
+ [(\ type.equivalence =
+ (type.array <primitive>)
+ array_jvm_type)
+ <extension>]
+
+ [type.boolean "jvm array length boolean"]
+ [type.byte "jvm array length byte"]
+ [type.short "jvm array length short"]
+ [type.int "jvm array length int"]
+ [type.long "jvm array length long"]
+ [type.float "jvm array length float"]
+ [type.double "jvm array length double"]
+ [type.char "jvm array length char"]))
+
+ ## else
+ "jvm array length object")))]]
+ (wrap (list (` (.|> ((~ g!extension) (~ array))
+ "jvm conversion int-to-long"
+ "jvm object cast"
+ (.: (.primitive (~ (code.text box.long))))
+ (.:as .Nat))))))
+
+ _
+ (with_gensyms [g!array]
+ (wrap (list (` (let [(~ g!array) (~ array)]
+ (..array_length (~ g!array)))))))))
+
+(syntax: #export (array_read idx array)
+ {#.doc (doc "Loads an element from an array."
+ (array_read 10 my_array))}
+ (case array
+ [_ (#.Identifier array_name)]
+ (do meta.monad
+ [array_type (meta.find_type array_name)
+ array_jvm_type (lux_type->jvm_type array_type)
+ #let [g!idx (` (.|> (~ idx)
+ (.: .Nat)
+ (.:as (.primitive (~ (code.text box.long))))
+ "jvm object cast"
+ "jvm conversion long-to-int"))]]
+ (`` (cond (~~ (template [<primitive> <extension> <box>]
+ [(\ type.equivalence =
+ (type.array <primitive>)
+ array_jvm_type)
+ (wrap (list (` (.|> (<extension> (~ g!idx) (~ array))
+ "jvm object cast"
+ (.: (.primitive (~ (code.text <box>))))))))]
+
+ [type.boolean "jvm array read boolean" box.boolean]
+ [type.byte "jvm array read byte" box.byte]
+ [type.short "jvm array read short" box.short]
+ [type.int "jvm array read int" box.int]
+ [type.long "jvm array read long" box.long]
+ [type.float "jvm array read float" box.float]
+ [type.double "jvm array read double" box.double]
+ [type.char "jvm array read char" box.char]))
+
+ ## else
+ (wrap (list (` ("jvm array read object" (~ g!idx) (~ array))))))))
+
+ _
+ (with_gensyms [g!array]
+ (wrap (list (` (let [(~ g!array) (~ array)]
+ (..array_read (~ idx) (~ g!array)))))))))
+
+(syntax: #export (array_write idx value array)
+ {#.doc (doc "Stores an element into an array."
+ (array_write 10 my_object my_array))}
+ (case array
+ [_ (#.Identifier array_name)]
+ (do meta.monad
+ [array_type (meta.find_type array_name)
+ array_jvm_type (lux_type->jvm_type array_type)
+ #let [g!idx (` (.|> (~ idx)
+ (.: .Nat)
+ (.:as (.primitive (~ (code.text box.long))))
+ "jvm object cast"
+ "jvm conversion long-to-int"))]]
+ (`` (cond (~~ (template [<primitive> <extension> <box>]
+ [(\ type.equivalence =
+ (type.array <primitive>)
+ array_jvm_type)
+ (let [g!value (` (.|> (~ value)
+ (.:as (.primitive (~ (code.text <box>))))
+ "jvm object cast"))]
+ (wrap (list (` (<extension> (~ g!idx) (~ g!value) (~ array))))))]
+
+ [type.boolean "jvm array write boolean" box.boolean]
+ [type.byte "jvm array write byte" box.byte]
+ [type.short "jvm array write short" box.short]
+ [type.int "jvm array write int" box.int]
+ [type.long "jvm array write long" box.long]
+ [type.float "jvm array write float" box.float]
+ [type.double "jvm array write double" box.double]
+ [type.char "jvm array write char" box.char]))
+
+ ## else
+ (wrap (list (` ("jvm array write object" (~ g!idx) (~ value) (~ array))))))))
+
+ _
+ (with_gensyms [g!array]
+ (wrap (list (` (let [(~ g!array) (~ array)]
+ (..array_write (~ idx) (~ value) (~ g!array)))))))))
+
+(syntax: #export (class_for {type (..type^ (list))})
+ {#.doc (doc "Loads the class as a java.lang.Class object."
+ (class_for java/lang/String))}
+ (wrap (list (` ("jvm object class" (~ (code.text (..reflection type))))))))
+
+(syntax: #export (type {type (..type^ (list))})
+ (wrap (list (..value_type #ManualPrM type))))
+
+(exception: #export (cannot_cast_to_non_object {type (Type Value)})
+ (exception.report
+ ["Signature" (..signature type)]
+ ["Reflection" (..reflection type)]))
+
+(syntax: #export (:cast {type (..type^ (list))}
+ object)
+ (case [(parser.array? type)
+ (parser.class? type)]
+ (^or [(#.Some _) _] [_ (#.Some _)])
+ (wrap (list (` (.: (~ (..value_type #ManualPrM type))
+ ("jvm object cast" (~ object))))))
+
+ _
+ (meta.fail (exception.construct ..cannot_cast_to_non_object [type]))))
diff --git a/stdlib/source/library/lux/ffi.lua.lux b/stdlib/source/library/lux/ffi.lua.lux
new file mode 100644
index 000000000..0099865f5
--- /dev/null
+++ b/stdlib/source/library/lux/ffi.lua.lux
@@ -0,0 +1,310 @@
+(.module:
+ [library
+ [lux #*
+ ["." meta]
+ ["@" target]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io]
+ ["<>" parser ("#\." monad)
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text
+ ["%" format]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [type
+ abstract]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]
+ ["." template]]]])
+
+(abstract: #export (Object brand) Any)
+
+(template [<name>]
+ [(with_expansions [<brand> (template.identifier [<name> "'"])]
+ (abstract: #export <brand> Any)
+ (type: #export <name>
+ (..Object <brand>)))]
+
+ [Nil]
+ [Function]
+ [Table]
+ )
+
+(template [<name> <type>]
+ [(type: #export <name>
+ <type>)]
+
+ [Boolean Bit]
+ [Integer Int]
+ [Float Frac]
+ [String Text]
+ )
+
+(type: Nilable
+ [Bit Code])
+
+(def: nilable
+ (Parser Nilable)
+ (let [token (' #?)]
+ (<| (<>.and (<>.parses? (<code>.this! token)))
+ (<>.after (<>.not (<code>.this! token)))
+ <code>.any)))
+
+(type: Field
+ [Bit Text Nilable])
+
+(def: static!
+ (Parser Any)
+ (<code>.this! (' #static)))
+
+(def: field
+ (Parser Field)
+ (<code>.form ($_ <>.and
+ (<>.parses? ..static!)
+ <code>.local_identifier
+ ..nilable)))
+
+(def: constant
+ (Parser Field)
+ (<code>.form ($_ <>.and
+ (<>\wrap true)
+ <code>.local_identifier
+ ..nilable)))
+
+(type: Common_Method
+ {#name Text
+ #alias (Maybe Text)
+ #inputs (List Nilable)
+ #io? Bit
+ #try? Bit
+ #output Nilable})
+
+(type: Static_Method Common_Method)
+(type: Virtual_Method Common_Method)
+
+(type: Method
+ (#Static Static_Method)
+ (#Virtual Virtual_Method))
+
+(def: common_method
+ (Parser Common_Method)
+ ($_ <>.and
+ <code>.local_identifier
+ (<>.maybe (<>.after (<code>.this! (' #as)) <code>.local_identifier))
+ (<code>.tuple (<>.some ..nilable))
+ (<>.parses? (<code>.this! (' #io)))
+ (<>.parses? (<code>.this! (' #try)))
+ ..nilable))
+
+(def: static_method
+ (<>.after ..static! ..common_method))
+
+(def: method
+ (Parser Method)
+ (<code>.form (<>.or ..static_method
+ ..common_method)))
+
+(type: Member
+ (#Field Field)
+ (#Method Method))
+
+(def: member
+ (Parser Member)
+ ($_ <>.or
+ ..field
+ ..method
+ ))
+
+(def: input_variables
+ (-> (List Nilable) (List [Bit Code]))
+ (|>> list.enumeration
+ (list\map (function (_ [idx [nilable? type]])
+ [nilable? (|> idx %.nat code.local_identifier)]))))
+
+(def: (nilable_type [nilable? type])
+ (-> Nilable Code)
+ (if nilable?
+ (` (.Maybe (~ type)))
+ type))
+
+(def: (with_nil g!temp [nilable? input])
+ (-> Code [Bit Code] Code)
+ (if nilable?
+ (` (case (~ input)
+ (#.Some (~ g!temp))
+ (~ g!temp)
+
+ #.Nil
+ ("lua object nil")))
+ input))
+
+(def: (without_nil g!temp [nilable? outputT] output)
+ (-> Code Nilable Code Code)
+ (if nilable?
+ (` (let [(~ g!temp) (~ output)]
+ (if ("lua object nil?" (~ g!temp))
+ #.None
+ (#.Some (~ g!temp)))))
+ (` (let [(~ g!temp) (~ output)]
+ (if (not ("lua object nil?" (~ g!temp)))
+ (~ g!temp)
+ (.error! "Nil is an invalid value!"))))))
+
+(type: Import
+ (#Class [Text Text (List Member)])
+ (#Function Static_Method)
+ (#Constant Field))
+
+(def: import
+ ($_ <>.or
+ (<>.and <code>.local_identifier
+ (<>.default ["" (list)]
+ (<code>.tuple (<>.and <code>.text
+ (<>.some member)))))
+ (<code>.form ..common_method)
+ ..constant
+ ))
+
+(def: (with_io with? without)
+ (-> Bit Code Code)
+ (if with?
+ (` (io.io (~ without)))
+ without))
+
+(def: (io_type io? rawT)
+ (-> Bit Code Code)
+ (if io?
+ (` (io.IO (~ rawT)))
+ rawT))
+
+(def: (with_try with? without_try)
+ (-> Bit Code Code)
+ (if with?
+ (` (.try (~ without_try)))
+ without_try))
+
+(def: (try_type try? rawT)
+ (-> Bit Code Code)
+ (if try?
+ (` (.Either .Text (~ rawT)))
+ rawT))
+
+(def: (make_function g!method g!temp source inputsT io? try? outputT)
+ (-> Code Code Code (List Nilable) Bit Bit Nilable Code)
+ (let [g!inputs (input_variables inputsT)]
+ (` (def: ((~ g!method)
+ [(~+ (list\map product.right g!inputs))])
+ (-> [(~+ (list\map nilable_type inputsT))]
+ (~ (|> (nilable_type outputT)
+ (try_type try?)
+ (io_type io?))))
+ (:assume
+ (~ (<| (with_io io?)
+ (with_try try?)
+ (without_nil g!temp outputT)
+ (` ("lua apply"
+ (:as ..Function (~ source))
+ (~+ (list\map (with_nil g!temp) g!inputs)))))))))))
+
+(syntax: #export (import: {import ..import})
+ (with_gensyms [g!temp]
+ (case import
+ (#Class [class format members])
+ (with_gensyms [g!object]
+ (let [qualify (: (-> Text Code)
+ (function (_ member_name)
+ (|> format
+ (text.replace_all "#" class)
+ (text.replace_all "." member_name)
+ code.local_identifier)))
+ g!type (code.local_identifier class)
+ real_class (text.replace_all "/" "." class)
+ imported (case (text.split_all_with "/" class)
+ (#.Cons head tail)
+ (list\fold (function (_ sub super)
+ (` ("lua object get" (~ (code.text sub))
+ (:as (..Object .Any) (~ super)))))
+ (` ("lua import" (~ (code.text head))))
+ tail)
+
+ #.Nil
+ (` ("lua import" (~ (code.text class)))))]
+ (wrap (list& (` (type: (~ g!type)
+ (..Object (primitive (~ (code.text real_class))))))
+ (list\map (function (_ member)
+ (case member
+ (#Field [static? field fieldT])
+ (if static?
+ (` ((~! syntax:) ((~ (qualify field)))
+ (\ (~! meta.monad) (~' wrap)
+ (list (` (.:as (~ (nilable_type fieldT))
+ ("lua object get" (~ (code.text field))
+ (:as (..Object .Any) (~ imported)))))))))
+ (` (def: ((~ (qualify field))
+ (~ g!object))
+ (-> (~ g!type)
+ (~ (nilable_type fieldT)))
+ (:assume
+ (~ (without_nil g!temp fieldT (` ("lua object get" (~ (code.text field))
+ (:as (..Object .Any) (~ g!object))))))))))
+
+ (#Method method)
+ (case method
+ (#Static [method alias inputsT io? try? outputT])
+ (..make_function (qualify (maybe.default method alias))
+ g!temp
+ (` ("lua object get" (~ (code.text method))
+ (:as (..Object .Any) (~ imported))))
+ inputsT
+ io?
+ try?
+ outputT)
+
+ (#Virtual [method alias inputsT io? try? outputT])
+ (let [g!inputs (input_variables inputsT)]
+ (` (def: ((~ (qualify (maybe.default method alias)))
+ [(~+ (list\map product.right g!inputs))]
+ (~ g!object))
+ (-> [(~+ (list\map nilable_type inputsT))]
+ (~ g!type)
+ (~ (|> (nilable_type outputT)
+ (try_type try?)
+ (io_type io?))))
+ (:assume
+ (~ (<| (with_io io?)
+ (with_try try?)
+ (without_nil g!temp outputT)
+ (` ("lua object do"
+ (~ (code.text method))
+ (~ g!object)
+ (~+ (list\map (with_nil g!temp) g!inputs)))))))))))))
+ members)))))
+
+ (#Function [name alias inputsT io? try? outputT])
+ (wrap (list (..make_function (code.local_identifier (maybe.default name alias))
+ g!temp
+ (` ("lua constant" (~ (code.text (text.replace_all "/" "." name)))))
+ inputsT
+ io?
+ try?
+ outputT)))
+
+ (#Constant [_ name fieldT])
+ (wrap (list (` ((~! syntax:) ((~ (code.local_identifier name)))
+ (\ (~! meta.monad) (~' wrap)
+ (list (` (.:as (~ (nilable_type fieldT))
+ ("lua constant" (~ (code.text (text.replace_all "/" "." name))))))))))))
+ )))
+
+(template: #export (closure <inputs> <output>)
+ (.:as ..Function
+ (`` ("lua function"
+ (~~ (template.count <inputs>))
+ (.function (_ [<inputs>])
+ <output>)))))
diff --git a/stdlib/source/library/lux/ffi.old.lux b/stdlib/source/library/lux/ffi.old.lux
new file mode 100644
index 000000000..fdb5d1412
--- /dev/null
+++ b/stdlib/source/library/lux/ffi.old.lux
@@ -0,0 +1,1829 @@
+(.module:
+ [library
+ [lux (#- type interface:)
+ ["." type ("#\." equivalence)]
+ [abstract
+ ["." monad (#+ Monad do)]
+ ["." enum]]
+ [control
+ ["." function]
+ ["." io]
+ ["." try (#+ Try)]
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." maybe]
+ ["." product]
+ ["." bit ("#\." codec)]
+ ["." text ("#\." equivalence monoid)
+ ["%" format (#+ format)]]
+ [collection
+ ["." array (#+ Array)]
+ ["." list ("#\." monad fold monoid)]]]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]]
+ ["." meta
+ ["." annotation]]]])
+
+(template [<name> <op> <from> <to>]
+ [(def: #export (<name> value)
+ {#.doc (doc "Type converter."
+ (: <to>
+ (<name> (: <from> foo))))}
+ (-> (primitive <from>) (primitive <to>))
+ (<op> value))]
+
+ [byte_to_long "jvm convert byte-to-long" "java.lang.Byte" "java.lang.Long"]
+
+ [short_to_long "jvm convert short-to-long" "java.lang.Short" "java.lang.Long"]
+
+ [double_to_int "jvm convert double-to-int" "java.lang.Double" "java.lang.Integer"]
+ [double_to_long "jvm convert double-to-long" "java.lang.Double" "java.lang.Long"]
+ [double_to_float "jvm convert double-to-float" "java.lang.Double" "java.lang.Float"]
+
+ [float_to_int "jvm convert float-to-int" "java.lang.Float" "java.lang.Integer"]
+ [float_to_long "jvm convert float-to-long" "java.lang.Float" "java.lang.Long"]
+ [float_to_double "jvm convert float-to-double" "java.lang.Float" "java.lang.Double"]
+
+ [int_to_byte "jvm convert int-to-byte" "java.lang.Integer" "java.lang.Byte"]
+ [int_to_short "jvm convert int-to-short" "java.lang.Integer" "java.lang.Short"]
+ [int_to_long "jvm convert int-to-long" "java.lang.Integer" "java.lang.Long"]
+ [int_to_float "jvm convert int-to-float" "java.lang.Integer" "java.lang.Float"]
+ [int_to_double "jvm convert int-to-double" "java.lang.Integer" "java.lang.Double"]
+ [int_to_char "jvm convert int-to-char" "java.lang.Integer" "java.lang.Character"]
+
+ [long_to_byte "jvm convert long-to-byte" "java.lang.Long" "java.lang.Byte"]
+ [long_to_short "jvm convert long-to-short" "java.lang.Long" "java.lang.Short"]
+ [long_to_int "jvm convert long-to-int" "java.lang.Long" "java.lang.Integer"]
+ [long_to_float "jvm convert long-to-float" "java.lang.Long" "java.lang.Float"]
+ [long_to_double "jvm convert long-to-double" "java.lang.Long" "java.lang.Double"]
+
+ [char_to_byte "jvm convert char-to-byte" "java.lang.Character" "java.lang.Byte"]
+ [char_to_short "jvm convert char-to-short" "java.lang.Character" "java.lang.Short"]
+ [char_to_int "jvm convert char-to-int" "java.lang.Character" "java.lang.Integer"]
+ [char_to_long "jvm convert char-to-long" "java.lang.Character" "java.lang.Long"]
+ )
+
+## [Utils]
+(def: constructor_method_name "<init>")
+(def: member_separator "::")
+
+## Types
+(type: JVM_Code Text)
+
+(type: BoundKind
+ #UpperBound
+ #LowerBound)
+
+(type: #rec GenericType
+ (#GenericTypeVar Text)
+ (#GenericClass [Text (List GenericType)])
+ (#GenericArray GenericType)
+ (#GenericWildcard (Maybe [BoundKind GenericType])))
+
+(type: Type_Parameter
+ [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: Class_Kind
+ #Class
+ #Interface)
+
+(type: Class_Declaration
+ {#class_name Text
+ #class_params (List Type_Parameter)})
+
+(type: StackFrame (primitive "java/lang/StackTraceElement"))
+(type: StackTrace (Array StackFrame))
+
+(type: Super_Class_Decl
+ {#super_class_name Text
+ #super_class_params (List GenericType)})
+
+(type: AnnotationParam
+ [Text Code])
+
+(type: Annotation
+ {#ann_name Text
+ #ann_params (List AnnotationParam)})
+
+(type: Member_Declaration
+ {#member_name Text
+ #member_privacy PrivacyModifier
+ #member_anns (List Annotation)})
+
+(type: FieldDecl
+ (#ConstantField GenericType Code)
+ (#VariableField StateModifier GenericType))
+
+(type: MethodDecl
+ {#method_tvars (List Type_Parameter)
+ #method_inputs (List GenericType)
+ #method_output GenericType
+ #method_exs (List GenericType)})
+
+(type: ArgDecl
+ {#arg_name Text
+ #arg_type GenericType})
+
+(type: ConstructorArg
+ [GenericType Code])
+
+(type: Method_Definition
+ (#ConstructorMethod [Bit
+ (List Type_Parameter)
+ (List ArgDecl)
+ (List ConstructorArg)
+ Code
+ (List GenericType)])
+ (#VirtualMethod [Bit
+ Bit
+ (List Type_Parameter)
+ Text
+ (List ArgDecl)
+ GenericType
+ Code
+ (List GenericType)])
+ (#OverridenMethod [Bit
+ Class_Declaration
+ (List Type_Parameter)
+ Text
+ (List ArgDecl)
+ GenericType
+ Code
+ (List GenericType)])
+ (#StaticMethod [Bit
+ (List Type_Parameter)
+ (List ArgDecl)
+ GenericType
+ Code
+ (List GenericType)])
+ (#AbstractMethod [(List Type_Parameter)
+ (List ArgDecl)
+ GenericType
+ (List GenericType)])
+ (#NativeMethod [(List Type_Parameter)
+ (List ArgDecl)
+ GenericType
+ (List GenericType)]))
+
+(type: Partial_Call
+ {#pc_method Name
+ #pc_args (List Code)})
+
+(type: ImportMethodKind
+ #StaticIMK
+ #VirtualIMK)
+
+(type: ImportMethodCommons
+ {#import_member_mode Primitive_Mode
+ #import_member_alias Text
+ #import_member_kind ImportMethodKind
+ #import_member_tvars (List Type_Parameter)
+ #import_member_args (List [Bit GenericType])
+ #import_member_maybe? Bit
+ #import_member_try? Bit
+ #import_member_io? Bit})
+
+(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? Bit
+ #import_field_maybe? Bit
+ #import_field_setter? Bit
+ #import_field_type GenericType})
+
+(type: Import_Member_Declaration
+ (#EnumDecl (List Text))
+ (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl])
+ (#MethodDecl [ImportMethodCommons ImportMethodDecl])
+ (#FieldAccessDecl ImportFieldDecl))
+
+## Utils
+(def: (manual_primitive_to_type class)
+ (-> Text (Maybe Code))
+ (case class
+ (^template [<prim> <type>]
+ [<prim>
+ (#.Some (' <type>))])
+ (["boolean" (primitive "java.lang.Boolean")]
+ ["byte" (primitive "java.lang.Byte")]
+ ["short" (primitive "java.lang.Short")]
+ ["int" (primitive "java.lang.Integer")]
+ ["long" (primitive "java.lang.Long")]
+ ["float" (primitive "java.lang.Float")]
+ ["double" (primitive "java.lang.Double")]
+ ["char" (primitive "java.lang.Character")]
+ ["void" .Any])
+
+ _
+ #.None))
+
+(def: (auto_primitive_to_type class)
+ (-> Text (Maybe Code))
+ (case class
+ (^template [<prim> <type>]
+ [<prim>
+ (#.Some (' <type>))])
+ (["boolean" .Bit]
+ ["byte" .Int]
+ ["short" .Int]
+ ["int" .Int]
+ ["long" .Int]
+ ["float" .Frac]
+ ["double" .Frac]
+ ["void" .Any])
+
+ _
+ #.None))
+
+(def: sanitize
+ (-> Text Text)
+ (text.replace_all "/" "."))
+
+(def: (generic_class_to_type' mode type_params in_array? name+params
+ class_to_type')
+ (-> Primitive_Mode (List Type_Parameter) Bit [Text (List GenericType)]
+ (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code)
+ Code)
+ (case [name+params mode in_array?]
+ (^multi [[prim #.Nil] #ManualPrM #0]
+ [(manual_primitive_to_type prim) (#.Some output)])
+ output
+
+ (^multi [[prim #.Nil] #AutoPrM #0]
+ [(auto_primitive_to_type prim) (#.Some output)])
+ output
+
+ [[name params] _ _]
+ (let [name (sanitize name)
+ =params (list\map (class_to_type' mode type_params in_array?) params)]
+ (` (primitive (~ (code.text name)) [(~+ =params)])))))
+
+(def: (class_to_type' mode type_params in_array? class)
+ (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code)
+ (case class
+ (#GenericTypeVar name)
+ (case (list.find (function (_ [pname pbounds])
+ (and (text\= name pname)
+ (not (list.empty? pbounds))))
+ type_params)
+ #.None
+ (code.identifier ["" name])
+
+ (#.Some [pname pbounds])
+ (class_to_type' mode type_params in_array? (maybe.assume (list.head pbounds))))
+
+ (#GenericClass name+params)
+ (generic_class_to_type' mode type_params in_array? name+params
+ class_to_type')
+
+ (#GenericArray param)
+ (let [=param (class_to_type' mode type_params #1 param)]
+ (` ((~! array.Array) (~ =param))))
+
+ (^or (#GenericWildcard #.None) (#GenericWildcard (#.Some [#LowerBound _])))
+ (` .Any)
+
+ (#GenericWildcard (#.Some [#UpperBound upper_bound]))
+ (class_to_type' mode type_params in_array? upper_bound)
+ ))
+
+(def: (class_to_type mode type_params class)
+ (-> Primitive_Mode (List Type_Parameter) GenericType Code)
+ (class_to_type' mode type_params #0 class))
+
+(def: (type_param_type$ [name bounds])
+ (-> Type_Parameter Code)
+ (code.identifier ["" name]))
+
+(def: (class_decl_type$ (^slots [#class_name #class_params]))
+ (-> Class_Declaration Code)
+ (let [=params (list\map (: (-> Type_Parameter Code)
+ (function (_ [pname pbounds])
+ (case pbounds
+ #.Nil
+ (code.identifier ["" pname])
+
+ (#.Cons bound1 _)
+ (class_to_type #ManualPrM class_params bound1))))
+ class_params)]
+ (` (primitive (~ (code.text (sanitize class_name)))
+ [(~+ =params)]))))
+
+(def: type_var_class Text "java.lang.Object")
+
+(def: (simple_class$ env class)
+ (-> (List Type_Parameter) GenericType Text)
+ (case class
+ (#GenericTypeVar name)
+ (case (list.find (function (_ [pname pbounds])
+ (and (text\= name pname)
+ (not (list.empty? pbounds))))
+ env)
+ #.None
+ type_var_class
+
+ (#.Some [pname pbounds])
+ (simple_class$ env (maybe.assume (list.head pbounds))))
+
+ (^or (#GenericWildcard #.None) (#GenericWildcard (#.Some [#LowerBound _])))
+ type_var_class
+
+ (#GenericWildcard (#.Some [#UpperBound upper_bound]))
+ (simple_class$ env upper_bound)
+
+ (#GenericClass name env)
+ (sanitize name)
+
+ (#GenericArray param')
+ (case param'
+ (#GenericArray param)
+ (format "[" (simple_class$ env param))
+
+ (^template [<prim> <class>]
+ [(#GenericClass <prim> #.Nil)
+ <class>])
+ (["boolean" "[Z"]
+ ["byte" "[B"]
+ ["short" "[S"]
+ ["int" "[I"]
+ ["long" "[J"]
+ ["float" "[F"]
+ ["double" "[D"]
+ ["char" "[C"])
+
+ param
+ (format "[L" (simple_class$ env param) ";"))
+ ))
+
+(def: (make_get_const_parser class_name field_name)
+ (-> Text Text (Parser Code))
+ (do <>.monad
+ [#let [dotted_name (format "::" field_name)]
+ _ (<code>.this! (code.identifier ["" dotted_name]))]
+ (wrap (`' ((~ (code.text (format "jvm getstatic" ":" class_name ":" field_name))))))))
+
+(def: (make_get_var_parser class_name field_name)
+ (-> Text Text (Parser Code))
+ (do <>.monad
+ [#let [dotted_name (format "::" field_name)]
+ _ (<code>.this! (code.identifier ["" dotted_name]))]
+ (wrap (`' ((~ (code.text (format "jvm getfield" ":" class_name ":" field_name))) _jvm_this)))))
+
+(def: (make_put_var_parser class_name field_name)
+ (-> Text Text (Parser Code))
+ (do <>.monad
+ [#let [dotted_name (format "::" field_name)]
+ [_ _ value] (: (Parser [Any Any Code])
+ (<code>.form ($_ <>.and (<code>.this! (' :=)) (<code>.this! (code.identifier ["" dotted_name])) <code>.any)))]
+ (wrap (`' ((~ (code.text (format "jvm putfield" ":" class_name ":" field_name))) _jvm_this (~ value))))))
+
+(def: (pre_walk_replace f input)
+ (-> (-> Code Code) Code Code)
+ (case (f input)
+ (^template [<tag>]
+ [[meta (<tag> parts)]
+ [meta (<tag> (list\map (pre_walk_replace f) parts))]])
+ ([#.Form]
+ [#.Tuple])
+
+ [meta (#.Record pairs)]
+ [meta (#.Record (list\map (: (-> [Code Code] [Code Code])
+ (function (_ [key val])
+ [(pre_walk_replace f key) (pre_walk_replace f val)]))
+ pairs))]
+
+ ast'
+ ast'))
+
+(def: (parser->replacer p ast)
+ (-> (Parser Code) (-> Code Code))
+ (case (<>.run p (list ast))
+ (#.Right [#.Nil ast'])
+ ast'
+
+ _
+ ast
+ ))
+
+(def: (field->parser class_name [[field_name _ _] field])
+ (-> Text [Member_Declaration FieldDecl] (Parser Code))
+ (case field
+ (#ConstantField _)
+ (make_get_const_parser class_name field_name)
+
+ (#VariableField _)
+ (<>.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 Type_Parameter) Text (List ArgDecl) (Parser Code))
+ (do <>.monad
+ [args (: (Parser (List Code))
+ (<code>.form (<>.after (<code>.this! (' ::new!))
+ (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any)))))
+ #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ params)) arg_decls))]]
+ (wrap (` ((~ (code.text (format "jvm new" ":" class_name ":" (text.join_with "," arg_decls'))))
+ (~+ args))))))
+
+(def: (make_static_method_parser params class_name method_name arg_decls)
+ (-> (List Type_Parameter) Text Text (List ArgDecl) (Parser Code))
+ (do <>.monad
+ [#let [dotted_name (format "::" method_name "!")]
+ args (: (Parser (List Code))
+ (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name]))
+ (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any)))))
+ #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ params)) arg_decls))]]
+ (wrap (`' ((~ (code.text (format "jvm invokestatic" ":" class_name ":" method_name ":" (text.join_with "," arg_decls'))))
+ (~+ args))))))
+
+(template [<name> <jvm_op>]
+ [(def: (<name> params class_name method_name arg_decls)
+ (-> (List Type_Parameter) Text Text (List ArgDecl) (Parser Code))
+ (do <>.monad
+ [#let [dotted_name (format "::" method_name "!")]
+ args (: (Parser (List Code))
+ (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name]))
+ (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any)))))
+ #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ params)) arg_decls))]]
+ (wrap (`' ((~ (code.text (format <jvm_op> ":" class_name ":" method_name ":" (text.join_with "," arg_decls'))))
+ (~' _jvm_this) (~+ args))))))]
+
+ [make_special_method_parser "jvm invokespecial"]
+ [make_virtual_method_parser "jvm invokevirtual"]
+ )
+
+(def: (method->parser params class_name [[method_name _ _] meth_def])
+ (-> (List Type_Parameter) Text [Member_Declaration Method_Definition] (Parser Code))
+ (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 self_name args return_type return_expr exs)
+ (#OverridenMethod strict? owner_class type_vars self_name 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)))
+
+## Parsers
+(def: privacy_modifier^
+ (Parser PrivacyModifier)
+ (let [(^open ".") <>.monad]
+ ($_ <>.or
+ (<code>.this! (' #public))
+ (<code>.this! (' #private))
+ (<code>.this! (' #protected))
+ (wrap []))))
+
+(def: inheritance_modifier^
+ (Parser InheritanceModifier)
+ (let [(^open ".") <>.monad]
+ ($_ <>.or
+ (<code>.this! (' #final))
+ (<code>.this! (' #abstract))
+ (wrap []))))
+
+(def: bound_kind^
+ (Parser BoundKind)
+ (<>.or (<code>.this! (' <))
+ (<code>.this! (' >))))
+
+(def: (assert_no_periods name)
+ (-> Text (Parser Any))
+ (<>.assert "Names in class declarations cannot contain periods."
+ (not (text.contains? "." name))))
+
+(def: (generic_type^ type_vars)
+ (-> (List Type_Parameter) (Parser GenericType))
+ (<>.rec
+ (function (_ recur^)
+ ($_ <>.either
+ (do <>.monad
+ [_ (<code>.this! (' ?))]
+ (wrap (#GenericWildcard #.None)))
+ (<code>.tuple (do <>.monad
+ [_ (<code>.this! (' ?))
+ bound_kind bound_kind^
+ bound recur^]
+ (wrap (#GenericWildcard (#.Some [bound_kind bound])))))
+ (do <>.monad
+ [name <code>.local_identifier
+ _ (assert_no_periods name)]
+ (if (list.member? text.equivalence (list\map product.left type_vars) name)
+ (wrap (#GenericTypeVar name))
+ (wrap (#GenericClass name (list)))))
+ (<code>.tuple (do <>.monad
+ [component recur^]
+ (case component
+ (^template [<class> <name>]
+ [(#GenericClass <name> #.Nil)
+ (wrap (#GenericClass <class> (list)))])
+ (["[Z" "boolean"]
+ ["[B" "byte"]
+ ["[S" "short"]
+ ["[I" "int"]
+ ["[J" "long"]
+ ["[F" "float"]
+ ["[D" "double"]
+ ["[C" "char"])
+
+ _
+ (wrap (#GenericArray component)))))
+ (<code>.form (do <>.monad
+ [name <code>.local_identifier
+ _ (assert_no_periods name)
+ params (<>.some recur^)
+ _ (<>.assert (format name " cannot be a type-parameter!")
+ (not (list.member? text.equivalence (list\map product.left type_vars) name)))]
+ (wrap (#GenericClass name params))))
+ ))))
+
+(def: type_param^
+ (Parser Type_Parameter)
+ (<>.either (do <>.monad
+ [param_name <code>.local_identifier]
+ (wrap [param_name (list)]))
+ (<code>.tuple (do <>.monad
+ [param_name <code>.local_identifier
+ _ (<code>.this! (' <))
+ bounds (<>.many (..generic_type^ (list)))]
+ (wrap [param_name bounds])))))
+
+(def: type_params^
+ (Parser (List Type_Parameter))
+ (|> ..type_param^
+ <>.some
+ <code>.tuple
+ (<>.default (list))))
+
+(def: class_decl^
+ (Parser Class_Declaration)
+ (<>.either (do <>.monad
+ [name <code>.local_identifier
+ _ (assert_no_periods name)]
+ (wrap [name (list)]))
+ (<code>.form (do <>.monad
+ [name <code>.local_identifier
+ _ (assert_no_periods name)
+ params (<>.some ..type_param^)]
+ (wrap [name params])))
+ ))
+
+(def: (super_class_decl^ type_vars)
+ (-> (List Type_Parameter) (Parser Super_Class_Decl))
+ (<>.either (do <>.monad
+ [name <code>.local_identifier
+ _ (assert_no_periods name)]
+ (wrap [name (list)]))
+ (<code>.form (do <>.monad
+ [name <code>.local_identifier
+ _ (assert_no_periods name)
+ params (<>.some (..generic_type^ type_vars))]
+ (wrap [name params])))))
+
+(def: annotation_params^
+ (Parser (List AnnotationParam))
+ (<code>.record (<>.some (<>.and <code>.local_tag <code>.any))))
+
+(def: annotation^
+ (Parser Annotation)
+ (<>.either (do <>.monad
+ [ann_name <code>.local_identifier]
+ (wrap [ann_name (list)]))
+ (<code>.form (<>.and <code>.local_identifier
+ annotation_params^))))
+
+(def: annotations^'
+ (Parser (List Annotation))
+ (do <>.monad
+ [_ (<code>.this! (' #ann))]
+ (<code>.tuple (<>.some ..annotation^))))
+
+(def: annotations^
+ (Parser (List Annotation))
+ (do <>.monad
+ [anns?? (<>.maybe ..annotations^')]
+ (wrap (maybe.default (list) anns??))))
+
+(def: (throws_decl'^ type_vars)
+ (-> (List Type_Parameter) (Parser (List GenericType)))
+ (do <>.monad
+ [_ (<code>.this! (' #throws))]
+ (<code>.tuple (<>.some (..generic_type^ type_vars)))))
+
+(def: (throws_decl^ type_vars)
+ (-> (List Type_Parameter) (Parser (List GenericType)))
+ (do <>.monad
+ [exs? (<>.maybe (throws_decl'^ type_vars))]
+ (wrap (maybe.default (list) exs?))))
+
+(def: (method_decl^ type_vars)
+ (-> (List Type_Parameter) (Parser [Member_Declaration MethodDecl]))
+ (<code>.form (do <>.monad
+ [tvars ..type_params^
+ name <code>.local_identifier
+ anns ..annotations^
+ inputs (<code>.tuple (<>.some (..generic_type^ type_vars)))
+ output (..generic_type^ type_vars)
+ exs (..throws_decl^ type_vars)]
+ (wrap [[name #PublicPM anns] {#method_tvars tvars
+ #method_inputs inputs
+ #method_output output
+ #method_exs exs}]))))
+
+(def: state_modifier^
+ (Parser StateModifier)
+ ($_ <>.or
+ (<code>.this! (' #volatile))
+ (<code>.this! (' #final))
+ (\ <>.monad wrap [])))
+
+(def: (field_decl^ type_vars)
+ (-> (List Type_Parameter) (Parser [Member_Declaration FieldDecl]))
+ (<>.either (<code>.form (do <>.monad
+ [_ (<code>.this! (' #const))
+ name <code>.local_identifier
+ anns ..annotations^
+ type (..generic_type^ type_vars)
+ body <code>.any]
+ (wrap [[name #PublicPM anns] (#ConstantField [type body])])))
+ (<code>.form (do <>.monad
+ [pm privacy_modifier^
+ sm state_modifier^
+ name <code>.local_identifier
+ anns ..annotations^
+ type (..generic_type^ type_vars)]
+ (wrap [[name pm anns] (#VariableField [sm type])])))))
+
+(def: (arg_decl^ type_vars)
+ (-> (List Type_Parameter) (Parser ArgDecl))
+ (<code>.record (<>.and <code>.local_identifier
+ (..generic_type^ type_vars))))
+
+(def: (arg_decls^ type_vars)
+ (-> (List Type_Parameter) (Parser (List ArgDecl)))
+ (<>.some (arg_decl^ type_vars)))
+
+(def: (constructor_arg^ type_vars)
+ (-> (List Type_Parameter) (Parser ConstructorArg))
+ (<code>.record (<>.and (..generic_type^ type_vars) <code>.any)))
+
+(def: (constructor_args^ type_vars)
+ (-> (List Type_Parameter) (Parser (List ConstructorArg)))
+ (<code>.tuple (<>.some (constructor_arg^ type_vars))))
+
+(def: (constructor_method^ class_vars)
+ (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition]))
+ (<code>.form (do <>.monad
+ [pm privacy_modifier^
+ strict_fp? (<>.parses? (<code>.this! (' #strict)))
+ method_vars ..type_params^
+ #let [total_vars (list\compose class_vars method_vars)]
+ [_ arg_decls] (<code>.form (<>.and (<code>.this! (' new))
+ (..arg_decls^ total_vars)))
+ constructor_args (..constructor_args^ total_vars)
+ exs (..throws_decl^ total_vars)
+ annotations ..annotations^
+ body <code>.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^ class_vars)
+ (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition]))
+ (<code>.form (do <>.monad
+ [pm privacy_modifier^
+ strict_fp? (<>.parses? (<code>.this! (' #strict)))
+ final? (<>.parses? (<code>.this! (' #final)))
+ method_vars ..type_params^
+ #let [total_vars (list\compose class_vars method_vars)]
+ [name this_name arg_decls] (<code>.form ($_ <>.and
+ <code>.local_identifier
+ <code>.local_identifier
+ (..arg_decls^ total_vars)))
+ return_type (..generic_type^ total_vars)
+ exs (..throws_decl^ total_vars)
+ annotations ..annotations^
+ body <code>.any]
+ (wrap [{#member_name name
+ #member_privacy pm
+ #member_anns annotations}
+ (#VirtualMethod final? strict_fp?
+ method_vars
+ this_name arg_decls return_type
+ body exs)]))))
+
+(def: overriden_method_def^
+ (Parser [Member_Declaration Method_Definition])
+ (<code>.form (do <>.monad
+ [strict_fp? (<>.parses? (<code>.this! (' #strict)))
+ owner_class ..class_decl^
+ method_vars ..type_params^
+ #let [total_vars (list\compose (product.right owner_class) method_vars)]
+ [name this_name arg_decls] (<code>.form ($_ <>.and
+ <code>.local_identifier
+ <code>.local_identifier
+ (..arg_decls^ total_vars)))
+ return_type (..generic_type^ total_vars)
+ exs (..throws_decl^ total_vars)
+ annotations ..annotations^
+ body <code>.any]
+ (wrap [{#member_name name
+ #member_privacy #PublicPM
+ #member_anns annotations}
+ (#OverridenMethod strict_fp?
+ owner_class method_vars
+ this_name arg_decls return_type
+ body exs)]))))
+
+(def: static_method_def^
+ (Parser [Member_Declaration Method_Definition])
+ (<code>.form (do <>.monad
+ [pm privacy_modifier^
+ strict_fp? (<>.parses? (<code>.this! (' #strict)))
+ _ (<code>.this! (' #static))
+ method_vars ..type_params^
+ #let [total_vars method_vars]
+ [name arg_decls] (<code>.form (<>.and <code>.local_identifier
+ (..arg_decls^ total_vars)))
+ return_type (..generic_type^ total_vars)
+ exs (..throws_decl^ total_vars)
+ annotations ..annotations^
+ body <code>.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^
+ (Parser [Member_Declaration Method_Definition])
+ (<code>.form (do <>.monad
+ [pm privacy_modifier^
+ _ (<code>.this! (' #abstract))
+ method_vars ..type_params^
+ #let [total_vars method_vars]
+ [name arg_decls] (<code>.form (<>.and <code>.local_identifier
+ (..arg_decls^ total_vars)))
+ return_type (..generic_type^ total_vars)
+ exs (..throws_decl^ total_vars)
+ annotations ..annotations^]
+ (wrap [{#member_name name
+ #member_privacy pm
+ #member_anns annotations}
+ (#AbstractMethod method_vars arg_decls return_type exs)]))))
+
+(def: native_method_def^
+ (Parser [Member_Declaration Method_Definition])
+ (<code>.form (do <>.monad
+ [pm privacy_modifier^
+ _ (<code>.this! (' #native))
+ method_vars ..type_params^
+ #let [total_vars method_vars]
+ [name arg_decls] (<code>.form (<>.and <code>.local_identifier
+ (..arg_decls^ total_vars)))
+ return_type (..generic_type^ total_vars)
+ exs (..throws_decl^ total_vars)
+ annotations ..annotations^]
+ (wrap [{#member_name name
+ #member_privacy pm
+ #member_anns annotations}
+ (#NativeMethod method_vars arg_decls return_type exs)]))))
+
+(def: (method_def^ class_vars)
+ (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition]))
+ ($_ <>.either
+ (..constructor_method^ class_vars)
+ (..virtual_method_def^ class_vars)
+ ..overriden_method_def^
+ ..static_method_def^
+ ..abstract_method_def^
+ ..native_method_def^))
+
+(def: partial_call^
+ (Parser Partial_Call)
+ (<code>.form (<>.and <code>.identifier (<>.some <code>.any))))
+
+(def: class_kind^
+ (Parser Class_Kind)
+ (<>.either (do <>.monad
+ [_ (<code>.this! (' #class))]
+ (wrap #Class))
+ (do <>.monad
+ [_ (<code>.this! (' #interface))]
+ (wrap #Interface))
+ ))
+
+(def: import_member_alias^
+ (Parser (Maybe Text))
+ (<>.maybe (do <>.monad
+ [_ (<code>.this! (' #as))]
+ <code>.local_identifier)))
+
+(def: (import_member_args^ type_vars)
+ (-> (List Type_Parameter) (Parser (List [Bit GenericType])))
+ (<code>.tuple (<>.some (<>.and (<>.parses? (<code>.this! (' #?))) (..generic_type^ type_vars)))))
+
+(def: import_member_return_flags^
+ (Parser [Bit Bit Bit])
+ ($_ <>.and (<>.parses? (<code>.this! (' #io))) (<>.parses? (<code>.this! (' #try))) (<>.parses? (<code>.this! (' #?)))))
+
+(def: primitive_mode^
+ (Parser Primitive_Mode)
+ (<>.or (<code>.this! (' #manual))
+ (<code>.this! (' #auto))))
+
+(def: (import_member_decl^ owner_vars)
+ (-> (List Type_Parameter) (Parser Import_Member_Declaration))
+ ($_ <>.either
+ (<code>.form (do <>.monad
+ [_ (<code>.this! (' #enum))
+ enum_members (<>.some <code>.local_identifier)]
+ (wrap (#EnumDecl enum_members))))
+ (<code>.form (do <>.monad
+ [tvars ..type_params^
+ _ (<code>.this! (' new))
+ ?alias import_member_alias^
+ #let [total_vars (list\compose owner_vars tvars)]
+ ?prim_mode (<>.maybe primitive_mode^)
+ args (..import_member_args^ total_vars)
+ [io? try? maybe?] import_member_return_flags^]
+ (wrap (#ConstructorDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode)
+ #import_member_alias (maybe.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?}
+ {}]))
+ ))
+ (<code>.form (do <>.monad
+ [kind (: (Parser ImportMethodKind)
+ (<>.or (<code>.this! (' #static))
+ (wrap [])))
+ tvars ..type_params^
+ name <code>.local_identifier
+ ?alias import_member_alias^
+ #let [total_vars (list\compose owner_vars tvars)]
+ ?prim_mode (<>.maybe primitive_mode^)
+ args (..import_member_args^ total_vars)
+ [io? try? maybe?] import_member_return_flags^
+ return (..generic_type^ total_vars)]
+ (wrap (#MethodDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode)
+ #import_member_alias (maybe.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
+ }]))))
+ (<code>.form (do <>.monad
+ [static? (<>.parses? (<code>.this! (' #static)))
+ name <code>.local_identifier
+ ?prim_mode (<>.maybe primitive_mode^)
+ gtype (..generic_type^ owner_vars)
+ maybe? (<>.parses? (<code>.this! (' #?)))
+ setter? (<>.parses? (<code>.this! (' #!)))]
+ (wrap (#FieldAccessDecl {#import_field_mode (maybe.default #AutoPrM ?prim_mode)
+ #import_field_name name
+ #import_field_static? static?
+ #import_field_maybe? maybe?
+ #import_field_setter? setter?
+ #import_field_type gtype}))))
+ ))
+
+(def: bundle
+ (-> (List Type_Parameter) (Parser [Text (List Import_Member_Declaration)]))
+ (|>> ..import_member_decl^
+ <>.some
+ (<>.and <code>.text)
+ <code>.tuple))
+
+## Generators
+(def: with_parens
+ (-> JVM_Code JVM_Code)
+ (text.enclose ["(" ")"]))
+
+(def: with_brackets
+ (-> JVM_Code JVM_Code)
+ (text.enclose ["[" "]"]))
+
+(def: spaced
+ (-> (List JVM_Code) JVM_Code)
+ (text.join_with " "))
+
+(def: (privacy_modifier$ pm)
+ (-> PrivacyModifier JVM_Code)
+ (case pm
+ #PublicPM "public"
+ #PrivatePM "private"
+ #ProtectedPM "protected"
+ #DefaultPM "default"))
+
+(def: (inheritance_modifier$ im)
+ (-> InheritanceModifier JVM_Code)
+ (case im
+ #FinalIM "final"
+ #AbstractIM "abstract"
+ #DefaultIM "default"))
+
+(def: (annotation_param$ [name value])
+ (-> AnnotationParam JVM_Code)
+ (format name "=" (code.format value)))
+
+(def: (annotation$ [name params])
+ (-> Annotation JVM_Code)
+ (format "(" name " " "{" (text.join_with text.tab (list\map annotation_param$ params)) "}" ")"))
+
+(def: (bound_kind$ kind)
+ (-> BoundKind JVM_Code)
+ (case kind
+ #UpperBound "<"
+ #LowerBound ">"))
+
+(def: (generic_type$ gtype)
+ (-> GenericType JVM_Code)
+ (case gtype
+ (#GenericTypeVar name)
+ name
+
+ (#GenericClass name params)
+ (format "(" (sanitize name) " " (spaced (list\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])
+ (-> Type_Parameter JVM_Code)
+ (format "(" name " " (spaced (list\map generic_type$ bounds)) ")"))
+
+(def: (class_decl$ (^open "."))
+ (-> Class_Declaration JVM_Code)
+ (format "(" (sanitize class_name) " " (spaced (list\map type_param$ class_params)) ")"))
+
+(def: (super_class_decl$ (^slots [#super_class_name #super_class_params]))
+ (-> Super_Class_Decl JVM_Code)
+ (format "(" (sanitize super_class_name) " " (spaced (list\map generic_type$ super_class_params)) ")"))
+
+(def: (method_decl$ [[name pm anns] method_decl])
+ (-> [Member_Declaration MethodDecl] JVM_Code)
+ (let [(^slots [#method_tvars #method_inputs #method_output #method_exs]) method_decl]
+ (with_parens
+ (spaced (list name
+ (with_brackets (spaced (list\map annotation$ anns)))
+ (with_brackets (spaced (list\map type_param$ method_tvars)))
+ (with_brackets (spaced (list\map generic_type$ method_exs)))
+ (with_brackets (spaced (list\map generic_type$ method_inputs)))
+ (generic_type$ method_output))
+ ))))
+
+(def: (state_modifier$ sm)
+ (-> StateModifier JVM_Code)
+ (case sm
+ #VolatileSM "volatile"
+ #FinalSM "final"
+ #DefaultSM "default"))
+
+(def: (field_decl$ [[name pm anns] field])
+ (-> [Member_Declaration FieldDecl] JVM_Code)
+ (case field
+ (#ConstantField class value)
+ (with_parens
+ (spaced (list "constant" name
+ (with_brackets (spaced (list\map annotation$ anns)))
+ (generic_type$ class)
+ (code.format value))
+ ))
+
+ (#VariableField sm class)
+ (with_parens
+ (spaced (list "variable" name
+ (privacy_modifier$ pm)
+ (state_modifier$ sm)
+ (with_brackets (spaced (list\map annotation$ anns)))
+ (generic_type$ class))
+ ))
+ ))
+
+(def: (arg_decl$ [name type])
+ (-> ArgDecl JVM_Code)
+ (with_parens
+ (spaced (list name (generic_type$ type)))))
+
+(def: (constructor_arg$ [class term])
+ (-> ConstructorArg JVM_Code)
+ (with_brackets
+ (spaced (list (generic_type$ class) (code.format term)))))
+
+(def: (method_def$ replacer super_class [[name pm anns] method_def])
+ (-> (-> Code Code) Super_Class_Decl [Member_Declaration Method_Definition] JVM_Code)
+ (case method_def
+ (#ConstructorMethod strict_fp? type_vars arg_decls constructor_args body exs)
+ (with_parens
+ (spaced (list "init"
+ (privacy_modifier$ pm)
+ (bit\encode strict_fp?)
+ (with_brackets (spaced (list\map annotation$ anns)))
+ (with_brackets (spaced (list\map type_param$ type_vars)))
+ (with_brackets (spaced (list\map generic_type$ exs)))
+ (with_brackets (spaced (list\map arg_decl$ arg_decls)))
+ (with_brackets (spaced (list\map constructor_arg$ constructor_args)))
+ (code.format (pre_walk_replace replacer body))
+ )))
+
+ (#VirtualMethod final? strict_fp? type_vars this_name arg_decls return_type body exs)
+ (with_parens
+ (spaced (list "virtual"
+ name
+ (privacy_modifier$ pm)
+ (bit\encode final?)
+ (bit\encode strict_fp?)
+ (with_brackets (spaced (list\map annotation$ anns)))
+ (with_brackets (spaced (list\map type_param$ type_vars)))
+ (with_brackets (spaced (list\map generic_type$ exs)))
+ (with_brackets (spaced (list\map arg_decl$ arg_decls)))
+ (generic_type$ return_type)
+ (code.format (pre_walk_replace replacer (` (let [(~ (code.local_identifier this_name)) (~' _jvm_this)]
+ (~ body))))))))
+
+ (#OverridenMethod strict_fp? class_decl type_vars this_name arg_decls return_type body exs)
+ (let [super_replacer (parser->replacer (<code>.form (do <>.monad
+ [_ (<code>.this! (' ::super!))
+ args (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any))
+ #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ (list)))
+ arg_decls))]]
+ (wrap (`' ((~ (code.text (format "jvm 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
+ (bit\encode strict_fp?)
+ (with_brackets (spaced (list\map annotation$ anns)))
+ (with_brackets (spaced (list\map type_param$ type_vars)))
+ (with_brackets (spaced (list\map generic_type$ exs)))
+ (with_brackets (spaced (list\map arg_decl$ arg_decls)))
+ (generic_type$ return_type)
+ (|> (` (let [(~ (code.local_identifier this_name)) (~' _jvm_this)]
+ (~ body)))
+ (pre_walk_replace replacer)
+ (pre_walk_replace super_replacer)
+ (code.format))
+ ))))
+
+ (#StaticMethod strict_fp? type_vars arg_decls return_type body exs)
+ (with_parens
+ (spaced (list "static"
+ name
+ (privacy_modifier$ pm)
+ (bit\encode strict_fp?)
+ (with_brackets (spaced (list\map annotation$ anns)))
+ (with_brackets (spaced (list\map type_param$ type_vars)))
+ (with_brackets (spaced (list\map generic_type$ exs)))
+ (with_brackets (spaced (list\map arg_decl$ arg_decls)))
+ (generic_type$ return_type)
+ (code.format (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 (list\map annotation$ anns)))
+ (with_brackets (spaced (list\map type_param$ type_vars)))
+ (with_brackets (spaced (list\map generic_type$ exs)))
+ (with_brackets (spaced (list\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 (list\map annotation$ anns)))
+ (with_brackets (spaced (list\map type_param$ type_vars)))
+ (with_brackets (spaced (list\map generic_type$ exs)))
+ (with_brackets (spaced (list\map arg_decl$ arg_decls)))
+ (generic_type$ return_type))))
+ ))
+
+(def: (complete_call$ g!obj [method args])
+ (-> Code Partial_Call Code)
+ (` ((~ (code.identifier method)) (~+ args) (~ g!obj))))
+
+## [Syntax]
+(def: object_super_class
+ Super_Class_Decl
+ {#super_class_name "java/lang/Object"
+ #super_class_params (list)})
+
+(syntax: #export (class:
+ {im inheritance_modifier^}
+ {class_decl ..class_decl^}
+ {#let [full_class_name (product.left class_decl)]}
+ {#let [class_vars (product.right class_decl)]}
+ {super (<>.default object_super_class
+ (..super_class_decl^ class_vars))}
+ {interfaces (<>.default (list)
+ (<code>.tuple (<>.some (..super_class_decl^ class_vars))))}
+ {annotations ..annotations^}
+ {fields (<>.some (..field_decl^ class_vars))}
+ {methods (<>.some (..method_def^ class_vars))})
+ {#.doc (doc "Allows defining JVM classes in Lux code."
+ "For example:"
+ (class: #final (TestClass A) [Runnable]
+ ## Fields
+ (#private foo boolean)
+ (#private bar A)
+ (#private baz java/lang/Object)
+ ## Methods
+ (#public [] (new [value A]) []
+ (exec (:= ::foo #1)
+ (:= ::bar value)
+ (:= ::baz "")
+ []))
+ (#public (virtual) java/lang/Object
+ "")
+ (#public #static (static) java/lang/Object
+ "")
+ (Runnable [] (run) void
+ [])
+ )
+
+ "The tuple corresponds to parent interfaces."
+ "An optional super-class can be specified before the tuple. 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 #1) for modifying it."
+ "(::new! []) for calling the class's constructor."
+ "(::resolve! container [value]) for calling the 'resolve' method."
+ )}
+ (do meta.monad
+ [current_module meta.current_module_name
+ #let [fully_qualified_class_name (format (sanitize current_module) "." full_class_name)
+ field_parsers (list\map (field->parser fully_qualified_class_name) fields)
+ method_parsers (list\map (method->parser (product.right class_decl) fully_qualified_class_name) methods)
+ replacer (parser->replacer (list\fold <>.either
+ (<>.fail "")
+ (list\compose field_parsers method_parsers)))
+ def_code (format "jvm class:"
+ (spaced (list (class_decl$ class_decl)
+ (super_class_decl$ super)
+ (with_brackets (spaced (list\map super_class_decl$ interfaces)))
+ (inheritance_modifier$ im)
+ (with_brackets (spaced (list\map annotation$ annotations)))
+ (with_brackets (spaced (list\map field_decl$ fields)))
+ (with_brackets (spaced (list\map (method_def$ replacer super) methods))))))]]
+ (wrap (list (` ((~ (code.text def_code))))))))
+
+(syntax: #export (interface:
+ {class_decl ..class_decl^}
+ {#let [class_vars (product.right class_decl)]}
+ {supers (<>.default (list)
+ (<code>.tuple (<>.some (..super_class_decl^ class_vars))))}
+ {annotations ..annotations^}
+ {members (<>.some (..method_decl^ class_vars))})
+ {#.doc (doc "Allows defining JVM interfaces."
+ (interface: TestInterface
+ ([] foo [boolean String] void #throws [Exception])))}
+ (let [def_code (format "jvm interface:"
+ (spaced (list (class_decl$ class_decl)
+ (with_brackets (spaced (list\map super_class_decl$ supers)))
+ (with_brackets (spaced (list\map annotation$ annotations)))
+ (spaced (list\map method_decl$ members)))))]
+ (wrap (list (` ((~ (code.text def_code))))))
+ ))
+
+(syntax: #export (object
+ {class_vars (<code>.tuple (<>.some ..type_param^))}
+ {super (<>.default object_super_class
+ (..super_class_decl^ class_vars))}
+ {interfaces (<>.default (list)
+ (<code>.tuple (<>.some (..super_class_decl^ class_vars))))}
+ {constructor_args (..constructor_args^ class_vars)}
+ {methods (<>.some ..overriden_method_def^)})
+ {#.doc (doc "Allows defining anonymous classes."
+ "The 1st tuple corresponds to class-level type-variables."
+ "The 2nd tuple corresponds to parent interfaces."
+ "The 3rd tuple corresponds to arguments to the super class constructor."
+ "An optional super-class can be specified before the 1st tuple. If not specified, java.lang.Object will be assumed."
+ (object [] [Runnable]
+ []
+ (Runnable [] (run self) void
+ (exec (do_something some_value)
+ [])))
+ )}
+ (let [def_code (format "jvm anon-class:"
+ (spaced (list (super_class_decl$ super)
+ (with_brackets (spaced (list\map super_class_decl$ interfaces)))
+ (with_brackets (spaced (list\map constructor_arg$ constructor_args)))
+ (with_brackets (spaced (list\map (method_def$ function.identity super) methods))))))]
+ (wrap (list (` ((~ (code.text def_code))))))))
+
+(syntax: #export (null)
+ {#.doc (doc "Null object reference."
+ (null))}
+ (wrap (list (` ("jvm object null")))))
+
+(def: #export (null? obj)
+ {#.doc (doc "Test for null object reference."
+ (= (null? (null))
+ true)
+ (= (null? "YOLO")
+ false))}
+ (-> (primitive "java.lang.Object") Bit)
+ ("jvm object null?" obj))
+
+(syntax: #export (??? expr)
+ {#.doc (doc "Takes a (potentially null) ObjectType reference and creates a (Maybe ObjectType) for it."
+ (= (??? (: java/lang/String (null)))
+ #.None)
+ (= (??? "YOLO")
+ (#.Some "YOLO")))}
+ (with_gensyms [g!temp]
+ (wrap (list (` (let [(~ g!temp) (~ expr)]
+ (if ("jvm object null?" (~ g!temp))
+ #.None
+ (#.Some (~ g!temp)))))))))
+
+(syntax: #export (!!! expr)
+ {#.doc (doc "Takes a (Maybe ObjectType) and returns a ObjectType."
+ "A #.None would get translated into a (null)."
+ (= (null)
+ (!!! (??? (: java/lang/Thread (null)))))
+ (= "foo"
+ (!!! (??? "foo"))))}
+ (with_gensyms [g!value]
+ (wrap (list (` ({(#.Some (~ g!value))
+ (~ g!value)
+
+ #.None
+ ("jvm object null")}
+ (~ expr)))))))
+
+(syntax: #export (check {class (..generic_type^ (list))}
+ {unchecked (<>.maybe <code>.any)})
+ {#.doc (doc "Checks whether an object is an instance of a particular class."
+ "Caveat emptor: Cannot check for polymorphism, so avoid using parameterized classes."
+ (case (check java/lang/String "YOLO")
+ (#.Some value_as_string)
+ #.None))}
+ (with_gensyms [g!_ g!unchecked]
+ (let [class_name (simple_class$ (list) class)
+ class_type (` (.primitive (~ (code.text class_name))))
+ check_type (` (.Maybe (~ class_type)))
+ check_code (` (if ((~ (code.text (format "jvm instanceof" ":" class_name))) (~ g!unchecked))
+ (#.Some (.:as (~ class_type)
+ (~ g!unchecked)))
+ #.None))]
+ (case unchecked
+ (#.Some unchecked)
+ (wrap (list (` (: (~ check_type)
+ (let [(~ g!unchecked) (~ unchecked)]
+ (~ check_code))))))
+
+ #.None
+ (wrap (list (` (: (-> (primitive "java.lang.Object") (~ check_type))
+ (function ((~ g!_) (~ g!unchecked))
+ (~ check_code))))))
+ ))))
+
+(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 (` ("jvm object synchronized" (~ lock) (~ body))))))
+
+(syntax: #export (do_to obj {methods (<>.some partial_call^)})
+ {#.doc (doc "Call a variety of methods on an object. Then, return the object."
+ (do_to object
+ (ClassName::method1 arg0 arg1 arg2)
+ (ClassName::method2 arg3 arg4 arg5)))}
+ (with_gensyms [g!obj]
+ (wrap (list (` (let [(~ g!obj) (~ obj)]
+ (exec (~+ (list\map (complete_call$ g!obj) methods))
+ (~ g!obj))))))))
+
+(def: (class_import$ [full_name params])
+ (-> Class_Declaration Code)
+ (let [params' (list\map (|>> product.left code.local_identifier) params)]
+ (` (def: (~ (code.identifier ["" full_name]))
+ {#..jvm_class (~ (code.text full_name))}
+ Type
+ (All [(~+ params')]
+ (primitive (~ (code.text (sanitize full_name)))
+ [(~+ params')]))))))
+
+(def: (member_type_vars class_tvars member)
+ (-> (List Type_Parameter) Import_Member_Declaration (List Type_Parameter))
+ (case member
+ (#ConstructorDecl [commons _])
+ (list\compose class_tvars (get@ #import_member_tvars commons))
+
+ (#MethodDecl [commons _])
+ (case (get@ #import_member_kind commons)
+ #StaticIMK
+ (get@ #import_member_tvars commons)
+
+ _
+ (list\compose class_tvars (get@ #import_member_tvars commons)))
+
+ _
+ class_tvars))
+
+(def: (member_def_arg_bindings type_params class member)
+ (-> (List Type_Parameter) Class_Declaration Import_Member_Declaration (Meta [(List [Bit Code]) (List Text) (List Code)]))
+ (case member
+ (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
+ (let [(^slots [#import_member_tvars #import_member_args]) commons]
+ (do {! meta.monad}
+ [arg_inputs (monad.map !
+ (: (-> [Bit GenericType] (Meta [Bit Code]))
+ (function (_ [maybe? _])
+ (with_gensyms [arg_name]
+ (wrap [maybe? arg_name]))))
+ import_member_args)
+ #let [arg_classes (: (List Text)
+ (list\map (|>> product.right (simple_class$ (list\compose type_params import_member_tvars)))
+ import_member_args))
+ arg_types (list\map (: (-> [Bit GenericType] Code)
+ (function (_ [maybe? arg])
+ (let [arg_type (class_to_type (get@ #import_member_mode commons) type_params arg)]
+ (if maybe?
+ (` (Maybe (~ arg_type)))
+ arg_type))))
+ import_member_args)]]
+ (wrap [arg_inputs arg_classes arg_types])))
+
+ _
+ (\ meta.monad wrap [(list) (list) (list)])))
+
+(def: (decorate_return_maybe class member return_term)
+ (-> Class_Declaration Import_Member_Declaration Code Code)
+ (case member
+ (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
+ (if (get@ #import_member_maybe? commons)
+ (` (??? (~ return_term)))
+ (let [g!temp (` ((~' ~') (~ (code.identifier ["" " Ω "]))))]
+ (` (let [(~ g!temp) (~ return_term)]
+ (if (not (..null? (:as (primitive "java.lang.Object")
+ (~ g!temp))))
+ (~ g!temp)
+ (error! (~ (code.text (format "Cannot produce null references from method calls @ "
+ (get@ #class_name class)
+ "." (get@ #import_member_alias commons))))))))))
+
+ _
+ return_term))
+
+(template [<name> <tag> <term_trans>]
+ [(def: (<name> member return_term)
+ (-> Import_Member_Declaration Code Code)
+ (case member
+ (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
+ (if (get@ <tag> commons)
+ <term_trans>
+ return_term)
+
+ _
+ return_term))]
+
+ [decorate_return_try #import_member_try? (` (.try (~ return_term)))]
+ [decorate_return_io #import_member_io? (` ((~! io.io) (~ return_term)))]
+ )
+
+(def: (free_type_param? [name bounds])
+ (-> Type_Parameter Bit)
+ (case bounds
+ #.Nil #1
+ _ #0))
+
+(def: (type_param->type_arg [name _])
+ (-> Type_Parameter Code)
+ (code.identifier ["" name]))
+
+(template [<name> <byte> <short> <int> <float>]
+ [(def: (<name> mode [class expression])
+ (-> Primitive_Mode [Text Code] Code)
+ (case mode
+ #ManualPrM
+ expression
+
+ #AutoPrM
+ (case class
+ "byte" (` (<byte> (~ expression)))
+ "short" (` (<short> (~ expression)))
+ "int" (` (<int> (~ expression)))
+ "float" (` (<float> (~ expression)))
+ _ expression)))]
+
+ [auto_convert_input long_to_byte long_to_short long_to_int double_to_float]
+ [auto_convert_output byte_to_long short_to_long int_to_long float_to_double]
+ )
+
+(def: (un_quote quoted)
+ (-> Code Code)
+ (` ((~' ~) (~ quoted))))
+
+(def: (jvm_extension_inputs mode classes inputs)
+ (-> Primitive_Mode (List Text) (List [Bit Code]) (List Code))
+ (|> inputs
+ (list\map (function (_ [maybe? input])
+ (if maybe?
+ (` ((~! !!!) (~ (un_quote input))))
+ (un_quote input))))
+ (list.zip/2 classes)
+ (list\map (auto_convert_input mode))))
+
+(def: (import_name format class member)
+ (-> Text Text Text Text)
+ (|> format
+ (text.replace_all "#" class)
+ (text.replace_all "." member)))
+
+(def: (member_def_interop type_params kind class [arg_function_inputs arg_classes arg_types] member method_prefix import_format)
+ (-> (List Type_Parameter) Class_Kind Class_Declaration [(List [Bit Code]) (List Text) (List Code)] Import_Member_Declaration Text Text (Meta (List Code)))
+ (let [[full_name class_tvars] class
+ full_name (sanitize full_name)
+ all_params (|> (member_type_vars class_tvars member)
+ (list.filter free_type_param?)
+ (list\map type_param->type_arg))]
+ (case member
+ (#EnumDecl enum_members)
+ (do {! meta.monad}
+ [#let [enum_type (: Code
+ (case class_tvars
+ #.Nil
+ (` (primitive (~ (code.text full_name))))
+
+ _
+ (let [=class_tvars (|> class_tvars
+ (list.filter free_type_param?)
+ (list\map type_param->type_arg))]
+ (` (All [(~+ =class_tvars)] (primitive (~ (code.text full_name)) [(~+ =class_tvars)]))))))
+ getter_interop (: (-> Text Code)
+ (function (_ name)
+ (let [getter_name (code.identifier ["" (..import_name import_format method_prefix name)])]
+ (` (def: (~ getter_name)
+ (~ enum_type)
+ ((~ (code.text (format "jvm getstatic" ":" full_name ":" name)))))))))]]
+ (wrap (list\map getter_interop enum_members)))
+
+ (#ConstructorDecl [commons _])
+ (do meta.monad
+ [#let [def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))])
+ jvm_extension (code.text (format "jvm new" ":" full_name ":" (text.join_with "," arg_classes)))
+ jvm_interop (|> (` ((~ jvm_extension)
+ (~+ (jvm_extension_inputs (get@ #import_member_mode commons) arg_classes arg_function_inputs))))
+ (decorate_return_maybe class member)
+ (decorate_return_try member)
+ (decorate_return_io member))]]
+ (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs)))
+ ((~' wrap) (.list (.` (~ jvm_interop)))))))))
+
+ (#MethodDecl [commons method])
+ (with_gensyms [g!obj]
+ (do meta.monad
+ [#let [def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))])
+ (^slots [#import_member_kind]) commons
+ (^slots [#import_method_name]) method
+ [jvm_op object_ast] (: [Text (List Code)]
+ (case import_member_kind
+ #StaticIMK
+ ["invokestatic"
+ (list)]
+
+ #VirtualIMK
+ (case kind
+ #Class
+ ["invokevirtual"
+ (list g!obj)]
+
+ #Interface
+ ["invokeinterface"
+ (list g!obj)]
+ )))
+ jvm_extension (code.text (format "jvm " jvm_op ":" full_name ":" import_method_name ":" (text.join_with "," arg_classes)))
+ jvm_interop (|> [(simple_class$ (list) (get@ #import_method_return method))
+ (` ((~ jvm_extension) (~+ (list\map un_quote object_ast))
+ (~+ (jvm_extension_inputs (get@ #import_member_mode commons) arg_classes arg_function_inputs))))]
+ (auto_convert_output (get@ #import_member_mode commons))
+ (decorate_return_maybe class member)
+ (decorate_return_try member)
+ (decorate_return_io member))]]
+ (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs)) (~+ object_ast))
+ ((~' wrap) (.list (.` (~ jvm_interop))))))))))
+
+ (#FieldAccessDecl fad)
+ (do meta.monad
+ [#let [(^open ".") fad
+ base_gtype (class_to_type import_field_mode type_params import_field_type)
+ classC (class_decl_type$ class)
+ typeC (if import_field_maybe?
+ (` (Maybe (~ base_gtype)))
+ base_gtype)
+ tvar_asts (: (List Code)
+ (|> class_tvars
+ (list.filter free_type_param?)
+ (list\map type_param->type_arg)))
+ getter_name (code.identifier ["" (..import_name import_format method_prefix import_field_name)])
+ setter_name (code.identifier ["" (..import_name import_format method_prefix (format import_field_name "!"))])]
+ getter_interop (with_gensyms [g!obj]
+ (let [getter_call (if import_field_static?
+ (` ((~ getter_name)))
+ (` ((~ getter_name) (~ g!obj))))
+ getter_body (<| (auto_convert_output import_field_mode)
+ [(simple_class$ (list) import_field_type)
+ (if import_field_static?
+ (let [jvm_extension (code.text (format "jvm getstatic" ":" full_name ":" import_field_name))]
+ (` ((~ jvm_extension))))
+ (let [jvm_extension (code.text (format "jvm getfield" ":" full_name ":" import_field_name))]
+ (` ((~ jvm_extension) (~ (un_quote g!obj))))))])
+ getter_body (if import_field_maybe?
+ (` ((~! ???) (~ getter_body)))
+ getter_body)
+ getter_body (if import_field_setter?
+ (` ((~! io.io) (~ getter_body)))
+ getter_body)]
+ (wrap (` ((~! syntax:) (~ getter_call)
+ ((~' wrap) (.list (.` (~ getter_body)))))))))
+ setter_interop (: (Meta (List Code))
+ (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_value (auto_convert_input import_field_mode
+ [(simple_class$ (list) import_field_type) (un_quote g!value)])
+ setter_value (if import_field_maybe?
+ (` ((~! !!!) (~ setter_value)))
+ setter_value)
+ setter_command (format (if import_field_static? "jvm putstatic" "jvm putfield")
+ ":" full_name ":" import_field_name)
+ g!obj+ (: (List Code)
+ (if import_field_static?
+ (list)
+ (list (un_quote g!obj))))]
+ (wrap (list (` ((~! syntax:) (~ setter_call)
+ ((~' wrap) (.list (.` ((~! io.io) ((~ (code.text setter_command)) (~+ g!obj+) (~ setter_value))))))))))))
+ (wrap (list))))]
+ (wrap (list& getter_interop setter_interop)))
+ )))
+
+(def: (member_import$ type_params kind class [import_format member])
+ (-> (List Type_Parameter) Class_Kind Class_Declaration [Text Import_Member_Declaration] (Meta (List Code)))
+ (let [[method_prefix _] class]
+ (do meta.monad
+ [=args (member_def_arg_bindings type_params class member)]
+ (member_def_interop type_params kind class =args member method_prefix import_format))))
+
+(type: (java/lang/Class a)
+ (primitive "java.lang.Class" [a]))
+
+(def: interface?
+ (All [a] (-> (java/lang/Class a) Bit))
+ (|>> "jvm invokevirtual:java.lang.Class:isInterface:"))
+
+(def: (load_class class_name)
+ (-> Text (Try (java/lang/Class Any)))
+ (try ("jvm invokestatic:java.lang.Class:forName:java.lang.String" class_name)))
+
+(def: (class_kind [class_name _])
+ (-> Class_Declaration (Meta Class_Kind))
+ (let [class_name (..sanitize class_name)]
+ (case (..load_class class_name)
+ (#try.Success class)
+ (\ meta.monad wrap (if (interface? class)
+ #Interface
+ #Class))
+
+ (#try.Failure error)
+ (meta.fail (format "Cannot load class: " class_name text.new_line
+ error)))))
+
+(syntax: #export (import:
+ {class_decl ..class_decl^}
+ {bundles (<>.some (..bundle (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."
+ (import: java/lang/Object
+ ["#::."
+ (new [])
+ (equals [java/lang/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 Try 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)."
+ (import: java/lang/String
+ ["#::."
+ (new [[byte]])
+ (#static valueOf [char] java/lang/String)
+ (#static valueOf #as int_valueOf [int] java/lang/String)])
+
+ (import: (java/util/List e)
+ ["#::."
+ (size [] int)
+ (get [int] e)])
+
+ (import: (java/util/ArrayList a)
+ ["#::."
+ ([T] toArray [[T]] [T])])
+
+ "The class-type that is generated is of the fully-qualified name."
+ "This avoids a clash between the java.util.List type, and Lux's own List type."
+ "All enum options to be imported must be specified."
+ (import: java/lang/Character$UnicodeScript
+ ["#::."
+ (#enum ARABIC CYRILLIC LATIN)])
+
+ "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 cannot be named (otherwise, they'd be confused for Java classes)."
+ (import: (lux/concurrency/promise/JvmPromise A)
+ ["#::."
+ (resolve [A] boolean)
+ (poll [] A)
+ (wasResolved [] boolean)
+ (waitOn [lux/Function] void)
+ (#static [A] make [A] (lux/concurrency/promise/JvmPromise A))])
+
+ "Also, the names of the imported members will look like Class::member"
+ (java/lang/Object::new [])
+ (java/lang/Object::equals [other_object] my_object)
+ (java/util/List::size [] my_list)
+ java/lang/Character$UnicodeScript::LATIN
+ )}
+ (do {! meta.monad}
+ [kind (class_kind class_decl)
+ =members (|> bundles
+ (list\map (function (_ [import_format members])
+ (list\map (|>> [import_format]) members)))
+ list.concat
+ (monad.map ! (member_import$ (product.right class_decl) kind class_decl)))]
+ (wrap (list& (class_import$ class_decl) (list\join =members)))))
+
+(syntax: #export (array {type (..generic_type^ (list))}
+ size)
+ {#.doc (doc "Create an array of the given type, with the given size."
+ (array java/lang/Object 10))}
+ (case type
+ (^template [<type> <array_op>]
+ [(^ (#GenericClass <type> (list)))
+ (wrap (list (` (<array_op> (~ size)))))])
+ (["boolean" "jvm znewarray"]
+ ["byte" "jvm bnewarray"]
+ ["short" "jvm snewarray"]
+ ["int" "jvm inewarray"]
+ ["long" "jvm lnewarray"]
+ ["float" "jvm fnewarray"]
+ ["double" "jvm dnewarray"]
+ ["char" "jvm cnewarray"])
+
+ _
+ (wrap (list (` ("jvm anewarray" (~ (code.text (generic_type$ type))) (~ size)))))))
+
+(syntax: #export (array_length array)
+ {#.doc (doc "Gives the length of an array."
+ (array_length my_array))}
+ (wrap (list (` ("jvm arraylength" (~ array))))))
+
+(def: (type->class_name type)
+ (-> Type (Meta Text))
+ (if (type\= Any type)
+ (\ meta.monad wrap "java.lang.Object")
+ (case type
+ (#.Primitive name params)
+ (\ meta.monad wrap name)
+
+ (#.Apply A F)
+ (case (type.apply (list A) F)
+ #.None
+ (meta.fail (format "Cannot apply type: " (type.format F) " to " (type.format A)))
+
+ (#.Some type')
+ (type->class_name type'))
+
+ (#.Named _ type')
+ (type->class_name type')
+
+ _
+ (meta.fail (format "Cannot convert to JvmType: " (type.format type))))))
+
+(syntax: #export (array_read idx array)
+ {#.doc (doc "Loads an element from an array."
+ (array_read 10 my_array))}
+ (case array
+ [_ (#.Identifier array_name)]
+ (do meta.monad
+ [array_type (meta.find_type array_name)
+ array_jvm_type (type->class_name array_type)]
+ (case array_jvm_type
+ (^template [<type> <array_op>]
+ [<type>
+ (wrap (list (` (<array_op> (~ array) (~ idx)))))])
+ (["[Z" "jvm zaload"]
+ ["[B" "jvm baload"]
+ ["[S" "jvm saload"]
+ ["[I" "jvm iaload"]
+ ["[J" "jvm jaload"]
+ ["[F" "jvm faload"]
+ ["[D" "jvm daload"]
+ ["[C" "jvm caload"])
+
+ _
+ (wrap (list (` ("jvm aaload" (~ array) (~ idx)))))))
+
+ _
+ (with_gensyms [g!array]
+ (wrap (list (` (let [(~ g!array) (~ array)]
+ (..array_read (~ idx) (~ g!array)))))))))
+
+(syntax: #export (array_write idx value array)
+ {#.doc (doc "Stores an element into an array."
+ (array_write 10 my_object my_array))}
+ (case array
+ [_ (#.Identifier array_name)]
+ (do meta.monad
+ [array_type (meta.find_type array_name)
+ array_jvm_type (type->class_name array_type)]
+ (case array_jvm_type
+ (^template [<type> <array_op>]
+ [<type>
+ (wrap (list (` (<array_op> (~ array) (~ idx) (~ value)))))])
+ (["[Z" "jvm zastore"]
+ ["[B" "jvm bastore"]
+ ["[S" "jvm sastore"]
+ ["[I" "jvm iastore"]
+ ["[J" "jvm jastore"]
+ ["[F" "jvm fastore"]
+ ["[D" "jvm dastore"]
+ ["[C" "jvm castore"])
+
+ _
+ (wrap (list (` ("jvm aastore" (~ array) (~ idx) (~ value)))))))
+
+ _
+ (with_gensyms [g!array]
+ (wrap (list (` (let [(~ g!array) (~ array)]
+ (..array_write (~ idx) (~ value) (~ g!array)))))))))
+
+(syntax: #export (class_for {type (..generic_type^ (list))})
+ {#.doc (doc "Loads the class as a java.lang.Class object."
+ (class_for java/lang/String))}
+ (wrap (list (` ("jvm object class" (~ (code.text (simple_class$ (list) type))))))))
+
+(syntax: #export (type {type (..generic_type^ (list))})
+ (wrap (list (..class_to_type #ManualPrM (list) type))))
diff --git a/stdlib/source/library/lux/ffi.php.lux b/stdlib/source/library/lux/ffi.php.lux
new file mode 100644
index 000000000..eb9b5fbed
--- /dev/null
+++ b/stdlib/source/library/lux/ffi.php.lux
@@ -0,0 +1,314 @@
+(.module:
+ [library
+ [lux (#- Alias)
+ ["." meta]
+ ["@" target]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io]
+ ["<>" parser ("#\." monad)
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text
+ ["%" format]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [type
+ abstract]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]
+ ["." template]]]])
+
+(abstract: #export (Object brand) Any)
+
+(template [<name>]
+ [(with_expansions [<brand> (template.identifier [<name> "'"])]
+ (abstract: #export <brand> Any)
+ (type: #export <name>
+ (..Object <brand>)))]
+
+ [Null]
+ [Function]
+ )
+
+(template [<name> <type>]
+ [(type: #export <name>
+ <type>)]
+
+ [Boolean Bit]
+ [Integer Int]
+ [Float Frac]
+ [String Text]
+ )
+
+(type: Nullable
+ [Bit Code])
+
+(def: nullable
+ (Parser Nullable)
+ (let [token (' #?)]
+ (<| (<>.and (<>.parses? (<code>.this! token)))
+ (<>.after (<>.not (<code>.this! token)))
+ <code>.any)))
+
+(type: Alias
+ Text)
+
+(def: alias
+ (Parser Alias)
+ (<>.after (<code>.this! (' #as)) <code>.local_identifier))
+
+(type: Field
+ [Bit Text (Maybe Alias) Nullable])
+
+(def: static!
+ (Parser Any)
+ (<code>.this! (' #static)))
+
+(def: field
+ (Parser Field)
+ (<code>.form ($_ <>.and
+ (<>.parses? ..static!)
+ <code>.local_identifier
+ (<>.maybe ..alias)
+ ..nullable)))
+
+(def: constant
+ (Parser Field)
+ (<code>.form ($_ <>.and
+ (<>\wrap true)
+ <code>.local_identifier
+ (<>.maybe ..alias)
+ ..nullable)))
+
+(type: Common_Method
+ {#name Text
+ #alias (Maybe Alias)
+ #inputs (List Nullable)
+ #io? Bit
+ #try? Bit
+ #output Nullable})
+
+(type: Static_Method Common_Method)
+(type: Virtual_Method Common_Method)
+
+(type: Method
+ (#Static Static_Method)
+ (#Virtual Virtual_Method))
+
+(def: common_method
+ (Parser Common_Method)
+ ($_ <>.and
+ <code>.local_identifier
+ (<>.maybe ..alias)
+ (<code>.tuple (<>.some ..nullable))
+ (<>.parses? (<code>.this! (' #io)))
+ (<>.parses? (<code>.this! (' #try)))
+ ..nullable))
+
+(def: static_method
+ (<>.after ..static! ..common_method))
+
+(def: method
+ (Parser Method)
+ (<code>.form (<>.or ..static_method
+ ..common_method)))
+
+(type: Member
+ (#Field Field)
+ (#Method Method))
+
+(def: member
+ (Parser Member)
+ ($_ <>.or
+ ..field
+ ..method
+ ))
+
+(def: input_variables
+ (-> (List Nullable) (List [Bit Code]))
+ (|>> list.enumeration
+ (list\map (function (_ [idx [nullable? type]])
+ [nullable? (|> idx %.nat code.local_identifier)]))))
+
+(def: (nullable_type [nullable? type])
+ (-> Nullable Code)
+ (if nullable?
+ (` (.Maybe (~ type)))
+ type))
+
+(def: (with_null g!temp [nullable? input])
+ (-> Code [Bit Code] Code)
+ (if nullable?
+ (` (case (~ input)
+ (#.Some (~ g!temp))
+ (~ g!temp)
+
+ #.Null
+ ("php object null")))
+ input))
+
+(def: (without_null g!temp [nullable? outputT] output)
+ (-> Code Nullable Code Code)
+ (if nullable?
+ (` (let [(~ g!temp) (~ output)]
+ (if ("php object null?" (~ g!temp))
+ #.None
+ (#.Some (~ g!temp)))))
+ (` (let [(~ g!temp) (~ output)]
+ (if (not ("php object null?" (~ g!temp)))
+ (~ g!temp)
+ (.error! "Null is an invalid value!"))))))
+
+(type: Import
+ (#Class Text (Maybe Alias) Text (List Member))
+ (#Function Static_Method)
+ (#Constant Field))
+
+(def: import
+ (Parser Import)
+ ($_ <>.or
+ ($_ <>.and
+ <code>.local_identifier
+ (<>.maybe ..alias)
+ (<>.default ["" (list)]
+ (<code>.tuple (<>.and <code>.text
+ (<>.some member)))))
+ (<code>.form ..common_method)
+ ..constant
+ ))
+
+(syntax: #export (try expression)
+ {#.doc (doc (case (try (risky_computation input))
+ (#.Right success)
+ (do_something success)
+
+ (#.Left error)
+ (recover_from_failure error)))}
+ (wrap (list (` ("lux try" ((~! io.io) (~ expression)))))))
+
+(def: (with_io with? without)
+ (-> Bit Code Code)
+ (if with?
+ (` (io.io (~ without)))
+ without))
+
+(def: (io_type io? rawT)
+ (-> Bit Code Code)
+ (if io?
+ (` (io.IO (~ rawT)))
+ rawT))
+
+(def: (with_try with? without_try)
+ (-> Bit Code Code)
+ (if with?
+ (` (..try (~ without_try)))
+ without_try))
+
+(def: (try_type try? rawT)
+ (-> Bit Code Code)
+ (if try?
+ (` (.Either .Text (~ rawT)))
+ rawT))
+
+(def: (make_function g!method g!temp source inputsT io? try? outputT)
+ (-> Code Code Code (List Nullable) Bit Bit Nullable Code)
+ (let [g!inputs (input_variables inputsT)]
+ (` (def: ((~ g!method)
+ [(~+ (list\map product.right g!inputs))])
+ (-> [(~+ (list\map nullable_type inputsT))]
+ (~ (|> (nullable_type outputT)
+ (try_type try?)
+ (io_type io?))))
+ (:assume
+ (~ (<| (with_io io?)
+ (with_try try?)
+ (without_null g!temp outputT)
+ (` ("php apply"
+ (:as ..Function (~ source))
+ (~+ (list\map (with_null g!temp) g!inputs)))))))))))
+
+(syntax: #export (import: {import ..import})
+ (with_gensyms [g!temp]
+ (case import
+ (#Class [class alias format members])
+ (with_gensyms [g!object]
+ (let [qualify (: (-> Text Code)
+ (function (_ member_name)
+ (|> format
+ (text.replace_all "#" (maybe.default class alias))
+ (text.replace_all "." member_name)
+ code.local_identifier)))
+ g!type (code.local_identifier (maybe.default class alias))
+ class_import (` ("php constant" (~ (code.text class))))]
+ (wrap (list& (` (type: (~ g!type)
+ (..Object (primitive (~ (code.text class))))))
+ (list\map (function (_ member)
+ (case member
+ (#Field [static? field alias fieldT])
+ (if static?
+ (` ((~! syntax:) ((~ (qualify (maybe.default field alias))))
+ (\ (~! meta.monad) (~' wrap)
+ (list (` (.:as (~ (nullable_type fieldT))
+ ("php constant" (~ (code.text (%.format class "::" field))))))))))
+ (` (def: ((~ (qualify field))
+ (~ g!object))
+ (-> (~ g!type)
+ (~ (nullable_type fieldT)))
+ (:assume
+ (~ (without_null g!temp fieldT (` ("php object get" (~ (code.text field))
+ (:as (..Object .Any) (~ g!object))))))))))
+
+ (#Method method)
+ (case method
+ (#Static [method alias inputsT io? try? outputT])
+ (..make_function (qualify (maybe.default method alias))
+ g!temp
+ (` ("php object get" (~ (code.text method))
+ (:as (..Object .Any)
+ ("php constant" (~ (code.text (%.format class "::" method)))))))
+ inputsT
+ io?
+ try?
+ outputT)
+
+ (#Virtual [method alias inputsT io? try? outputT])
+ (let [g!inputs (input_variables inputsT)]
+ (` (def: ((~ (qualify (maybe.default method alias)))
+ [(~+ (list\map product.right g!inputs))]
+ (~ g!object))
+ (-> [(~+ (list\map nullable_type inputsT))]
+ (~ g!type)
+ (~ (|> (nullable_type outputT)
+ (try_type try?)
+ (io_type io?))))
+ (:assume
+ (~ (<| (with_io io?)
+ (with_try try?)
+ (without_null g!temp outputT)
+ (` ("php object do"
+ (~ (code.text method))
+ (~ g!object)
+ (~+ (list\map (with_null g!temp) g!inputs)))))))))))))
+ members)))))
+
+ (#Function [name alias inputsT io? try? outputT])
+ (let [imported (` ("php constant" (~ (code.text name))))]
+ (wrap (list (..make_function (code.local_identifier (maybe.default name alias))
+ g!temp
+ imported
+ inputsT
+ io?
+ try?
+ outputT))))
+
+ (#Constant [_ name alias fieldT])
+ (let [imported (` ("php constant" (~ (code.text name))))]
+ (wrap (list (` ((~! syntax:) ((~ (code.local_identifier (maybe.default name alias))))
+ (\ (~! meta.monad) (~' wrap)
+ (list (` (.:as (~ (nullable_type fieldT)) (~ imported))))))))))
+ )))
diff --git a/stdlib/source/library/lux/ffi.py.lux b/stdlib/source/library/lux/ffi.py.lux
new file mode 100644
index 000000000..737cfefd8
--- /dev/null
+++ b/stdlib/source/library/lux/ffi.py.lux
@@ -0,0 +1,315 @@
+(.module:
+ [library
+ [lux #*
+ ["." meta]
+ ["@" target]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io]
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text
+ ["%" format]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [type
+ abstract]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]
+ ["." template]]]])
+
+(abstract: #export (Object brand) Any)
+
+(template [<name>]
+ [(with_expansions [<brand> (template.identifier [<name> "'"])]
+ (abstract: <brand> Any)
+ (type: #export <name>
+ (..Object <brand>)))]
+
+ [None]
+ [Dict]
+ [Function]
+ )
+
+(template [<name> <type>]
+ [(type: #export <name>
+ <type>)]
+
+ [Boolean Bit]
+ [Integer Int]
+ [Float Frac]
+ [String Text]
+ )
+
+(type: Noneable
+ [Bit Code])
+
+(def: noneable
+ (Parser Noneable)
+ (let [token (' #?)]
+ (<| (<>.and (<>.parses? (<code>.this! token)))
+ (<>.after (<>.not (<code>.this! token)))
+ <code>.any)))
+
+(type: Constructor
+ (List Noneable))
+
+(def: constructor
+ (Parser Constructor)
+ (<code>.form (<>.after (<code>.this! (' new))
+ (<code>.tuple (<>.some ..noneable)))))
+
+(type: Field
+ [Bit Text Noneable])
+
+(def: static!
+ (Parser Any)
+ (<code>.this! (' #static)))
+
+(def: field
+ (Parser Field)
+ (<code>.form ($_ <>.and
+ (<>.parses? ..static!)
+ <code>.local_identifier
+ ..noneable)))
+
+(type: Common_Method
+ {#name Text
+ #alias (Maybe Text)
+ #inputs (List Noneable)
+ #io? Bit
+ #try? Bit
+ #output Noneable})
+
+(type: Static_Method Common_Method)
+(type: Virtual_Method Common_Method)
+
+(type: Method
+ (#Static Static_Method)
+ (#Virtual Virtual_Method))
+
+(def: common_method
+ (Parser Common_Method)
+ ($_ <>.and
+ <code>.local_identifier
+ (<>.maybe (<>.after (<code>.this! (' #as)) <code>.local_identifier))
+ (<code>.tuple (<>.some ..noneable))
+ (<>.parses? (<code>.this! (' #io)))
+ (<>.parses? (<code>.this! (' #try)))
+ ..noneable))
+
+(def: static_method
+ (<>.after ..static! ..common_method))
+
+(def: method
+ (Parser Method)
+ (<code>.form (<>.or ..static_method
+ ..common_method)))
+
+(type: Member
+ (#Constructor Constructor)
+ (#Field Field)
+ (#Method Method))
+
+(def: member
+ (Parser Member)
+ ($_ <>.or
+ ..constructor
+ ..field
+ ..method
+ ))
+
+(def: input_variables
+ (-> (List Noneable) (List [Bit Code]))
+ (|>> list.enumeration
+ (list\map (function (_ [idx [noneable? type]])
+ [noneable? (|> idx %.nat code.local_identifier)]))))
+
+(def: (noneable_type [noneable? type])
+ (-> Noneable Code)
+ (if noneable?
+ (` (.Maybe (~ type)))
+ type))
+
+(def: (with_none g!temp [noneable? input])
+ (-> Code [Bit Code] Code)
+ (if noneable?
+ (` (case (~ input)
+ (#.Some (~ g!temp))
+ (~ g!temp)
+
+ #.None
+ ("python object none")))
+ input))
+
+(def: (without_none g!temp [noneable? outputT] output)
+ (-> Code Noneable Code Code)
+ (if noneable?
+ (` (let [(~ g!temp) (~ output)]
+ (if ("python object none?" (~ g!temp))
+ #.None
+ (#.Some (~ g!temp)))))
+ (` (let [(~ g!temp) (~ output)]
+ (if (not ("python object none?" (~ g!temp)))
+ (~ g!temp)
+ (.error! "None is an invalid value!"))))))
+
+(type: Import
+ (#Class [Text Text (List Member)])
+ (#Function Static_Method))
+
+(def: import
+ (Parser Import)
+ (<>.or (<>.and <code>.local_identifier
+ (<>.default ["" (list)]
+ (<code>.tuple (<>.and <code>.text
+ (<>.some member)))))
+ (<code>.form ..common_method)))
+
+(def: (with_io with? without)
+ (-> Bit Code Code)
+ (if with?
+ (` (io.io (~ without)))
+ without))
+
+(def: (io_type io? rawT)
+ (-> Bit Code Code)
+ (if io?
+ (` (io.IO (~ rawT)))
+ rawT))
+
+(def: (with_try with? without_try)
+ (-> Bit Code Code)
+ (if with?
+ (` (.try (~ without_try)))
+ without_try))
+
+(def: (try_type try? rawT)
+ (-> Bit Code Code)
+ (if try?
+ (` (.Either .Text (~ rawT)))
+ rawT))
+
+(def: (make_function g!method g!temp source inputsT io? try? outputT)
+ (-> Code Code Code (List Noneable) Bit Bit Noneable Code)
+ (let [g!inputs (input_variables inputsT)]
+ (` (def: ((~ g!method)
+ [(~+ (list\map product.right g!inputs))])
+ (-> [(~+ (list\map noneable_type inputsT))]
+ (~ (|> (noneable_type outputT)
+ (try_type try?)
+ (io_type io?))))
+ (:assume
+ (~ (<| (with_io io?)
+ (with_try try?)
+ (without_none g!temp outputT)
+ (` ("python apply"
+ (:as ..Function (~ source))
+ (~+ (list\map (with_none g!temp) g!inputs)))))))))))
+
+(syntax: #export (import: {import ..import})
+ (with_gensyms [g!temp]
+ (case import
+ (#Class [class format members])
+ (with_gensyms [g!object]
+ (let [qualify (: (-> Text Code)
+ (function (_ member_name)
+ (|> format
+ (text.replace_all "#" class)
+ (text.replace_all "." member_name)
+ code.local_identifier)))
+ g!type (code.local_identifier class)
+ real_class (text.replace_all "/" "." class)
+ imported (case (text.split_all_with "/" class)
+ (#.Cons head tail)
+ (list\fold (function (_ sub super)
+ (` ("python object get" (~ (code.text sub))
+ (:as (..Object .Any) (~ super)))))
+ (` ("python import" (~ (code.text head))))
+ tail)
+
+ #.Nil
+ (` ("python import" (~ (code.text class)))))]
+ (wrap (list& (` (type: (~ g!type)
+ (..Object (primitive (~ (code.text real_class))))))
+ (list\map (function (_ member)
+ (case member
+ (#Constructor inputsT)
+ (let [g!inputs (input_variables inputsT)]
+ (` (def: ((~ (qualify "new"))
+ [(~+ (list\map product.right g!inputs))])
+ (-> [(~+ (list\map noneable_type inputsT))]
+ (~ g!type))
+ (:assume
+ ("python apply"
+ (:as ..Function (~ imported))
+ (~+ (list\map (with_none g!temp) g!inputs)))))))
+
+ (#Field [static? field fieldT])
+ (if static?
+ (` ((~! syntax:) ((~ (qualify field)))
+ (\ (~! meta.monad) (~' wrap)
+ (list (` (.:as (~ (noneable_type fieldT))
+ ("python object get" (~ (code.text field))
+ (:as (..Object .Any) (~ imported)))))))))
+ (` (def: ((~ (qualify field))
+ (~ g!object))
+ (-> (~ g!type)
+ (~ (noneable_type fieldT)))
+ (:assume
+ (~ (without_none g!temp fieldT (` ("python object get" (~ (code.text field))
+ (:as (..Object .Any) (~ g!object))))))))))
+
+ (#Method method)
+ (case method
+ (#Static [method alias inputsT io? try? outputT])
+ (..make_function (qualify (maybe.default method alias))
+ g!temp
+ (` ("python object get" (~ (code.text method))
+ (:as (..Object .Any) (~ imported))))
+ inputsT
+ io?
+ try?
+ outputT)
+
+ (#Virtual [method alias inputsT io? try? outputT])
+ (let [g!inputs (input_variables inputsT)]
+ (` (def: ((~ (qualify (maybe.default method alias)))
+ [(~+ (list\map product.right g!inputs))]
+ (~ g!object))
+ (-> [(~+ (list\map noneable_type inputsT))]
+ (~ g!type)
+ (~ (|> (noneable_type outputT)
+ (try_type try?)
+ (io_type io?))))
+ (:assume
+ (~ (<| (with_io io?)
+ (with_try try?)
+ (without_none g!temp outputT)
+ (` ("python object do"
+ (~ (code.text method))
+ (~ g!object)
+ (~+ (list\map (with_none g!temp) g!inputs)))))))))))))
+ members)))))
+
+ (#Function [name alias inputsT io? try? outputT])
+ (wrap (list (..make_function (code.local_identifier (maybe.default name alias))
+ g!temp
+ (` ("python constant" (~ (code.text name))))
+ inputsT
+ io?
+ try?
+ outputT)))
+ )))
+
+(template: #export (lambda <inputs> <output>)
+ (.:as ..Function
+ (`` ("python function"
+ (~~ (template.count <inputs>))
+ (.function (_ [<inputs>])
+ <output>)))))
diff --git a/stdlib/source/library/lux/ffi.rb.lux b/stdlib/source/library/lux/ffi.rb.lux
new file mode 100644
index 000000000..511351bad
--- /dev/null
+++ b/stdlib/source/library/lux/ffi.rb.lux
@@ -0,0 +1,332 @@
+(.module:
+ [library
+ [lux (#- Alias)
+ ["@" target]
+ ["." meta]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io]
+ ["<>" parser ("#\." monad)
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text
+ ["%" format]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [type
+ abstract]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]
+ ["." template]]]])
+
+(abstract: #export (Object brand) Any)
+
+(template [<name>]
+ [(with_expansions [<brand> (template.identifier [<name> "'"])]
+ (abstract: #export <brand> Any)
+ (type: #export <name>
+ (..Object <brand>)))]
+
+ [Nil]
+ [Function]
+ )
+
+(template [<name> <type>]
+ [(type: #export <name>
+ <type>)]
+
+ [Boolean Bit]
+ [Integer Int]
+ [Float Frac]
+ [String Text]
+ )
+
+(type: Nilable
+ [Bit Code])
+
+(def: nilable
+ (Parser Nilable)
+ (let [token (' #?)]
+ (<| (<>.and (<>.parses? (<code>.this! token)))
+ (<>.after (<>.not (<code>.this! token)))
+ <code>.any)))
+
+(type: Alias
+ Text)
+
+(def: alias
+ (Parser Alias)
+ (<>.after (<code>.this! (' #as)) <code>.local_identifier))
+
+(type: Field
+ [Bit Text (Maybe Alias) Nilable])
+
+(def: static!
+ (Parser Any)
+ (<code>.this! (' #static)))
+
+(def: field
+ (Parser Field)
+ (<code>.form ($_ <>.and
+ (<>.parses? ..static!)
+ <code>.local_identifier
+ (<>.maybe ..alias)
+ ..nilable)))
+
+(def: constant
+ (Parser Field)
+ (<code>.form ($_ <>.and
+ (<>\wrap true)
+ <code>.local_identifier
+ (<>.maybe ..alias)
+ ..nilable)))
+
+(type: Common_Method
+ {#name Text
+ #alias (Maybe Alias)
+ #inputs (List Nilable)
+ #io? Bit
+ #try? Bit
+ #output Nilable})
+
+(type: Static_Method Common_Method)
+(type: Virtual_Method Common_Method)
+
+(type: Method
+ (#Static Static_Method)
+ (#Virtual Virtual_Method))
+
+(def: common_method
+ (Parser Common_Method)
+ ($_ <>.and
+ <code>.local_identifier
+ (<>.maybe ..alias)
+ (<code>.tuple (<>.some ..nilable))
+ (<>.parses? (<code>.this! (' #io)))
+ (<>.parses? (<code>.this! (' #try)))
+ ..nilable))
+
+(def: static_method
+ (<>.after ..static! ..common_method))
+
+(def: method
+ (Parser Method)
+ (<code>.form (<>.or ..static_method
+ ..common_method)))
+
+(type: Member
+ (#Field Field)
+ (#Method Method))
+
+(def: member
+ (Parser Member)
+ ($_ <>.or
+ ..field
+ ..method
+ ))
+
+(def: input_variables
+ (-> (List Nilable) (List [Bit Code]))
+ (|>> list.enumeration
+ (list\map (function (_ [idx [nilable? type]])
+ [nilable? (|> idx %.nat code.local_identifier)]))))
+
+(def: (nilable_type [nilable? type])
+ (-> Nilable Code)
+ (if nilable?
+ (` (.Maybe (~ type)))
+ type))
+
+(def: (with_nil g!temp [nilable? input])
+ (-> Code [Bit Code] Code)
+ (if nilable?
+ (` (case (~ input)
+ (#.Some (~ g!temp))
+ (~ g!temp)
+
+ #.Nil
+ ("ruby object nil")))
+ input))
+
+(def: (without_nil g!temp [nilable? outputT] output)
+ (-> Code Nilable Code Code)
+ (if nilable?
+ (` (let [(~ g!temp) (~ output)]
+ (if ("ruby object nil?" (~ g!temp))
+ #.None
+ (#.Some (~ g!temp)))))
+ (` (let [(~ g!temp) (~ output)]
+ (if (not ("ruby object nil?" (~ g!temp)))
+ (~ g!temp)
+ (.error! "Nil is an invalid value!"))))))
+
+(type: Import
+ (#Class Text (Maybe Alias) Text (List Member))
+ (#Function Static_Method)
+ (#Constant Field))
+
+(def: import
+ (Parser [(Maybe Text) Import])
+ ($_ <>.and
+ (<>.maybe <code>.text)
+ ($_ <>.or
+ ($_ <>.and
+ <code>.local_identifier
+ (<>.maybe ..alias)
+ (<>.default ["" (list)]
+ (<code>.tuple (<>.and <code>.text
+ (<>.some member)))))
+ (<code>.form ..common_method)
+ ..constant
+ )))
+
+(def: (with_io with? without)
+ (-> Bit Code Code)
+ (if with?
+ (` (io.io (~ without)))
+ without))
+
+(def: (io_type io? rawT)
+ (-> Bit Code Code)
+ (if io?
+ (` (io.IO (~ rawT)))
+ rawT))
+
+(def: (with_try with? without_try)
+ (-> Bit Code Code)
+ (if with?
+ (` (.try (~ without_try)))
+ without_try))
+
+(def: (try_type try? rawT)
+ (-> Bit Code Code)
+ (if try?
+ (` (.Either .Text (~ rawT)))
+ rawT))
+
+(def: (make_function g!method g!temp source inputsT io? try? outputT)
+ (-> Code Code Code (List Nilable) Bit Bit Nilable Code)
+ (let [g!inputs (input_variables inputsT)]
+ (` (def: ((~ g!method)
+ [(~+ (list\map product.right g!inputs))])
+ (-> [(~+ (list\map nilable_type inputsT))]
+ (~ (|> (nilable_type outputT)
+ (try_type try?)
+ (io_type io?))))
+ (:assume
+ (~ (<| (with_io io?)
+ (with_try try?)
+ (without_nil g!temp outputT)
+ (` ("ruby apply"
+ (:as ..Function (~ source))
+ (~+ (list\map (with_nil g!temp) g!inputs)))))))))))
+
+(syntax: #export (import: {[?module import] ..import})
+ (with_gensyms [g!temp]
+ (case import
+ (#Class [class alias format members])
+ (with_gensyms [g!object]
+ (let [qualify (: (-> Text Code)
+ (function (_ member_name)
+ (|> format
+ (text.replace_all "#" (maybe.default class alias))
+ (text.replace_all "." member_name)
+ code.local_identifier)))
+ g!type (code.local_identifier (maybe.default class alias))
+ module_import (: (List Code)
+ (case ?module
+ (#.Some module)
+ (list (` ("ruby import" (~ (code.text module)))))
+
+ #.None
+ (list)))
+ class_import (` ("ruby constant" (~ (code.text class))))]
+ (wrap (list& (` (type: (~ g!type)
+ (..Object (primitive (~ (code.text class))))))
+ (list\map (function (_ member)
+ (case member
+ (#Field [static? field alias fieldT])
+ (if static?
+ (` ((~! syntax:) ((~ (qualify (maybe.default field alias))))
+ (\ (~! meta.monad) (~' wrap)
+ (list (` (.:as (~ (nilable_type fieldT))
+ (.exec
+ (~+ module_import)
+ ("ruby constant" (~ (code.text (%.format class "::" field)))))))))))
+ (` (def: ((~ (qualify field))
+ (~ g!object))
+ (-> (~ g!type)
+ (~ (nilable_type fieldT)))
+ (:assume
+ (~ (without_nil g!temp fieldT (` ("ruby object get" (~ (code.text field))
+ (:as (..Object .Any) (~ g!object))))))))))
+
+ (#Method method)
+ (case method
+ (#Static [method alias inputsT io? try? outputT])
+ (..make_function (qualify (maybe.default method alias))
+ g!temp
+ (` ("ruby object get" (~ (code.text method))
+ (:as (..Object .Any)
+ (.exec
+ (~+ module_import)
+ ("ruby constant" (~ (code.text (%.format class "::" method))))))))
+ inputsT
+ io?
+ try?
+ outputT)
+
+ (#Virtual [method alias inputsT io? try? outputT])
+ (let [g!inputs (input_variables inputsT)]
+ (` (def: ((~ (qualify (maybe.default method alias)))
+ [(~+ (list\map product.right g!inputs))]
+ (~ g!object))
+ (-> [(~+ (list\map nilable_type inputsT))]
+ (~ g!type)
+ (~ (|> (nilable_type outputT)
+ (try_type try?)
+ (io_type io?))))
+ (:assume
+ (~ (<| (with_io io?)
+ (with_try try?)
+ (without_nil g!temp outputT)
+ (` ("ruby object do"
+ (~ (code.text method))
+ (~ g!object)
+ (~+ (list\map (with_nil g!temp) g!inputs)))))))))))))
+ members)))))
+
+ (#Function [name alias inputsT io? try? outputT])
+ (let [imported (` (.exec
+ (~+ (case ?module
+ (#.Some module)
+ (list (` ("ruby import" (~ (code.text module)))))
+
+ #.None
+ (list)))
+ ("ruby constant" (~ (code.text name)))))]
+ (wrap (list (..make_function (code.local_identifier (maybe.default name alias))
+ g!temp
+ imported
+ inputsT
+ io?
+ try?
+ outputT))))
+
+ (#Constant [_ name alias fieldT])
+ (let [imported (` (.exec
+ (~+ (case ?module
+ (#.Some module)
+ (list (` ("ruby import" (~ (code.text module)))))
+
+ #.None
+ (list)))
+ ("ruby constant" (~ (code.text name)))))]
+ (wrap (list (` ((~! syntax:) ((~ (code.local_identifier (maybe.default name alias))))
+ (\ (~! meta.monad) (~' wrap)
+ (list (` (.:as (~ (nilable_type fieldT)) (~ imported))))))))))
+ )))
diff --git a/stdlib/source/library/lux/ffi.scm.lux b/stdlib/source/library/lux/ffi.scm.lux
new file mode 100644
index 000000000..85370fcf6
--- /dev/null
+++ b/stdlib/source/library/lux/ffi.scm.lux
@@ -0,0 +1,220 @@
+(.module:
+ [library
+ [lux (#- Alias)
+ ["@" target]
+ ["." meta]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io]
+ ["<>" parser ("#\." monad)
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [type
+ abstract]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]
+ ["." template]]]])
+
+(abstract: #export (Object brand) Any)
+
+(template [<name>]
+ [(with_expansions [<brand> (template.identifier [<name> "'"])]
+ (abstract: #export <brand> Any)
+ (type: #export <name>
+ (..Object <brand>)))]
+
+ [Nil]
+ [Function]
+ )
+
+(template [<name> <type>]
+ [(type: #export <name>
+ <type>)]
+
+ [Boolean Bit]
+ [Integer Int]
+ [Float Frac]
+ [String Text]
+ )
+
+(type: Nilable
+ [Bit Code])
+
+(def: nilable
+ (Parser Nilable)
+ (let [token (' #?)]
+ (<| (<>.and (<>.parses? (<code>.this! token)))
+ (<>.after (<>.not (<code>.this! token)))
+ <code>.any)))
+
+(type: Alias
+ Text)
+
+(def: alias
+ (Parser Alias)
+ (<>.after (<code>.this! (' #as)) <code>.local_identifier))
+
+(type: Field
+ [Bit Text (Maybe Alias) Nilable])
+
+(def: static!
+ (Parser Any)
+ (<code>.this! (' #static)))
+
+(def: field
+ (Parser Field)
+ (<code>.form ($_ <>.and
+ (<>.parses? ..static!)
+ <code>.local_identifier
+ (<>.maybe ..alias)
+ ..nilable)))
+
+(def: constant
+ (Parser Field)
+ (<code>.form ($_ <>.and
+ (<>\wrap true)
+ <code>.local_identifier
+ (<>.maybe ..alias)
+ ..nilable)))
+
+(type: Common_Method
+ {#name Text
+ #alias (Maybe Alias)
+ #inputs (List Nilable)
+ #io? Bit
+ #try? Bit
+ #output Nilable})
+
+(def: common_method
+ (Parser Common_Method)
+ ($_ <>.and
+ <code>.local_identifier
+ (<>.maybe ..alias)
+ (<code>.tuple (<>.some ..nilable))
+ (<>.parses? (<code>.this! (' #io)))
+ (<>.parses? (<code>.this! (' #try)))
+ ..nilable))
+
+(def: input_variables
+ (-> (List Nilable) (List [Bit Code]))
+ (|>> list.enumeration
+ (list\map (function (_ [idx [nilable? type]])
+ [nilable? (|> idx %.nat code.local_identifier)]))))
+
+(def: (nilable_type [nilable? type])
+ (-> Nilable Code)
+ (if nilable?
+ (` (.Maybe (~ type)))
+ type))
+
+(def: (with_nil g!temp [nilable? input])
+ (-> Code [Bit Code] Code)
+ (if nilable?
+ (` (case (~ input)
+ (#.Some (~ g!temp))
+ (~ g!temp)
+
+ #.Nil
+ ("scheme object nil")))
+ input))
+
+(def: (without_nil g!temp [nilable? outputT] output)
+ (-> Code Nilable Code Code)
+ (if nilable?
+ (` (let [(~ g!temp) (~ output)]
+ (if ("scheme object nil?" (~ g!temp))
+ #.None
+ (#.Some (~ g!temp)))))
+ (` (let [(~ g!temp) (~ output)]
+ (if (not ("scheme object nil?" (~ g!temp)))
+ (~ g!temp)
+ (.error! "Nil is an invalid value!"))))))
+
+(type: Import
+ (#Function Common_Method)
+ (#Constant Field))
+
+(def: import
+ (Parser Import)
+ ($_ <>.or
+ (<code>.form ..common_method)
+ ..constant
+ ))
+
+(syntax: #export (try expression)
+ {#.doc (doc (case (try (risky_computation input))
+ (#.Right success)
+ (do_something success)
+
+ (#.Left error)
+ (recover_from_failure error)))}
+ (wrap (list (` ("lux try" ((~! io.io) (~ expression)))))))
+
+(def: (with_io with? without)
+ (-> Bit Code Code)
+ (if with?
+ (` (io.io (~ without)))
+ without))
+
+(def: (io_type io? rawT)
+ (-> Bit Code Code)
+ (if io?
+ (` (io.IO (~ rawT)))
+ rawT))
+
+(def: (with_try with? without_try)
+ (-> Bit Code Code)
+ (if with?
+ (` (..try (~ without_try)))
+ without_try))
+
+(def: (try_type try? rawT)
+ (-> Bit Code Code)
+ (if try?
+ (` (.Either .Text (~ rawT)))
+ rawT))
+
+(def: (make_function g!method g!temp source inputsT io? try? outputT)
+ (-> Code Code Code (List Nilable) Bit Bit Nilable Code)
+ (let [g!inputs (input_variables inputsT)]
+ (` (def: ((~ g!method)
+ [(~+ (list\map product.right g!inputs))])
+ (-> [(~+ (list\map nilable_type inputsT))]
+ (~ (|> (nilable_type outputT)
+ (try_type try?)
+ (io_type io?))))
+ (:assume
+ (~ (<| (with_io io?)
+ (with_try try?)
+ (without_nil g!temp outputT)
+ (` ("scheme apply"
+ (:as ..Function (~ source))
+ (~+ (list\map (with_nil g!temp) g!inputs)))))))))))
+
+(syntax: #export (import: {import ..import})
+ (with_gensyms [g!temp]
+ (case import
+ (#Function [name alias inputsT io? try? outputT])
+ (let [imported (` ("scheme constant" (~ (code.text name))))]
+ (wrap (list (..make_function (code.local_identifier (maybe.default name alias))
+ g!temp
+ imported
+ inputsT
+ io?
+ try?
+ outputT))))
+
+ (#Constant [_ name alias fieldT])
+ (let [imported (` ("scheme constant" (~ (code.text name))))]
+ (wrap (list (` ((~! syntax:) ((~ (code.local_identifier (maybe.default name alias))))
+ (\ (~! meta.monad) (~' wrap)
+ (list (` (.:as (~ (nilable_type fieldT)) (~ imported))))))))))
+ )))
diff --git a/stdlib/source/library/lux/locale.lux b/stdlib/source/library/lux/locale.lux
new file mode 100644
index 000000000..381938c74
--- /dev/null
+++ b/stdlib/source/library/lux/locale.lux
@@ -0,0 +1,45 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ ["." hash (#+ Hash)]]
+ [data
+ ["." maybe ("#\." functor)]
+ ["." text
+ ["%" format (#+ format)]
+ ["." encoding (#+ Encoding)]]]
+ [type
+ abstract]]]
+ [/
+ ["." language (#+ Language)]
+ ["." territory (#+ Territory)]])
+
+(abstract: #export Locale
+ Text
+
+ (def: territory_separator "_")
+ (def: encoding_separator ".")
+
+ (def: #export (locale language territory encoding)
+ (-> Language (Maybe Territory) (Maybe Encoding) Locale)
+ (:abstraction (format (language.code language)
+ (|> territory
+ (maybe\map (|>> territory.long_code (format ..territory_separator)))
+ (maybe.default ""))
+ (|> encoding
+ (maybe\map (|>> encoding.name (format ..encoding_separator)))
+ (maybe.default "")))))
+
+ (def: #export code
+ (-> Locale Text)
+ (|>> :representation))
+
+ (def: #export hash
+ (Hash Locale)
+ (\ hash.functor map ..code text.hash))
+
+ (def: #export equivalence
+ (Equivalence Locale)
+ (\ ..hash &equivalence))
+ )
diff --git a/stdlib/source/library/lux/locale/language.lux b/stdlib/source/library/lux/locale/language.lux
new file mode 100644
index 000000000..554606609
--- /dev/null
+++ b/stdlib/source/library/lux/locale/language.lux
@@ -0,0 +1,573 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]]
+ [data
+ ["." text]]
+ [type
+ abstract]
+ [macro
+ ["." template]]]])
+
+## https://en.wikipedia.org/wiki/List_of_ISO_639-2_codes
+(abstract: #export Language
+ {#name Text
+ #code Text}
+
+ (template [<name> <tag>]
+ [(def: #export <name>
+ (-> Language Text)
+ (|>> :representation (get@ <tag>)))]
+
+ [name #name]
+ [code #code]
+ )
+
+ (template [<bundle>]
+ [(with_expansions [<bundle>' (template.splice <bundle>)]
+ (template [<code> <name> <definition> <alias>+]
+ [(def: #export <definition>
+ Language
+ (:abstraction {#name <name>
+ #code <code>}))
+ (`` (template [<alias>]
+ [(def: #export <alias>
+ Language
+ <definition>)]
+
+ (~~ (template.splice <alias>+))))]
+
+ <bundle>'
+ ))]
+
+ [[["mis" "uncoded languages" uncoded []]
+ ["mul" "multiple languages" multiple []]
+ ["und" "undetermined" undetermined []]
+ ["zxx" "no linguistic content; not applicable" not_applicable []]]]
+
+ [[["aar" "Afar" afar []]
+ ["abk" "Abkhazian" abkhazian []]
+ ["ace" "Achinese" achinese []]
+ ["ach" "Acoli" acoli []]
+ ["ada" "Adangme" adangme []]
+ ["ady" "Adyghe; Adygei" adyghe []]
+ ["afa" "Afro-Asiatic languages" afro_asiatic []]
+ ["afh" "Afrihili" afrihili []]
+ ["afr" "Afrikaans" afrikaans []]
+ ["ain" "Ainu" ainu []]
+ ["aka" "Akan" akan []]
+ ["akk" "Akkadian" akkadian []]
+ ["ale" "Aleut" aleut []]
+ ["alg" "Algonquian languages" algonquian []]
+ ["alt" "Southern Altai" southern_altai []]
+ ["amh" "Amharic" amharic []]
+ ["ang" "Old English (ca.450–1100)" old_english []]
+ ["anp" "Angika" angika []]
+ ["apa" "Apache languages" apache []]
+ ["ara" "Arabic" arabic []]
+ ["arc" "Official Aramaic (700–300 BCE); Imperial Aramaic (700–300 BCE)" official_aramaic [[imperial_aramaic]]]
+ ["arg" "Aragonese" aragonese []]
+ ["arn" "Mapudungun; Mapuche" mapudungun []]
+ ["arp" "Arapaho" arapaho []]
+ ["art" "Artificial languages" artificial []]
+ ["arw" "Arawak" arawak []]
+ ["asm" "Assamese" assamese []]
+ ["ast" "Asturian; Bable; Leonese; Asturleonese" asturian [[bable] [leonese] [asturleonese]]]
+ ["ath" "Athapascan languages" athapascan []]
+ ["aus" "Australian languages" australian []]
+ ["ava" "Avaric" avaric []]
+ ["ave" "Avestan" avestan []]
+ ["awa" "Awadhi" awadhi []]
+ ["aym" "Aymara" aymara []]
+ ["aze" "Azerbaijani" azerbaijani []]]]
+
+ [[["bad" "Banda languages" banda []]
+ ["bai" "Bamileke languages" bamileke []]
+ ["bak" "Bashkir" bashkir []]
+ ["bal" "Baluchi" baluchi []]
+ ["bam" "Bambara" bambara []]
+ ["ban" "Balinese" balinese []]
+ ["bas" "Basa" basa []]
+ ["bat" "Baltic languages" baltic []]
+ ["bej" "Beja; Bedawiyet" beja []]
+ ["bel" "Belarusian" belarusian []]
+ ["bem" "Bemba" bemba []]
+ ["ben" "Bengali" bengali []]
+ ["ber" "Berber languages" berber []]
+ ["bho" "Bhojpuri" bhojpuri []]
+ ["bih" "Bihari languages" bihari []]
+ ["bik" "Bikol" bikol []]
+ ["bin" "Bini; Edo" bini [[edo]]]
+ ["bis" "Bislama" bislama []]
+ ["bla" "Siksika" siksika []]
+ ["bnt" "Bantu languages" bantu []]
+ ["bod" "Tibetan" tibetan []]
+ ["bos" "Bosnian" bosnian []]
+ ["bra" "Braj" braj []]
+ ["bre" "Breton" breton []]
+ ["btk" "Batak languages" batak []]
+ ["bua" "Buriat" buriat []]
+ ["bug" "Buginese" buginese []]
+ ["bul" "Bulgarian" bulgarian []]
+ ["byn" "Blin; Bilin" blin [[bilin]]]]]
+
+ [[["cad" "Caddo" caddo []]
+ ["cai" "Central American Indian languages" central_american_indian []]
+ ["car" "Galibi Carib" galibi_carib []]
+ ["cat" "Catalan; Valencian" catalan [[valencian]]]
+ ["cau" "Caucasian languages" caucasian []]
+ ["ceb" "Cebuano" cebuano []]
+ ["cel" "Celtic languages" celtic []]
+ ["ces" "Czech" czech []]
+ ["cha" "Chamorro" chamorro []]
+ ["chb" "Chibcha" chibcha []]
+ ["che" "Chechen" chechen []]
+ ["chg" "Chagatai" chagatai []]
+ ["chk" "Chuukese" chuukese []]
+ ["chm" "Mari" mari []]
+ ["chn" "Chinook jargon" chinook []]
+ ["cho" "Choctaw" choctaw []]
+ ["chp" "Chipewyan; Dene Suline" chipewyan []]
+ ["chr" "Cherokee" cherokee []]
+ ["chu" "Church Slavic; Old Slavonic; Church Slavonic; Old Bulgarian; Old Church Slavonic" church_slavic [[old_slavonic] [church_slavonic] [old_bulgarian] [old_church_slavonic]]]
+ ["chv" "Chuvash" chuvash []]
+ ["chy" "Cheyenne" cheyenne []]
+ ["cmc" "Chamic languages" chamic []]
+ ["cnr" "Montenegrin" montenegrin []]
+ ["cop" "Coptic" coptic []]
+ ["cor" "Cornish" cornish []]
+ ["cos" "Corsican" corsican []]
+ ["cpe" "Creoles and pidgins, English based" creoles_and_pidgins/english []]
+ ["cpf" "Creoles and pidgins, French-based" creoles_and_pidgins/french []]
+ ["cpp" "Creoles and pidgins, Portuguese-based" creoles_and_pidgins/portuguese []]
+ ["cre" "Cree" cree []]
+ ["crh" "Crimean Tatar; Crimean Turkish" crimean []]
+ ["crp" "Creoles and pidgins" creoles_and_pidgins []]
+ ["csb" "Kashubian" kashubian []]
+ ["cus" "Cushitic languages" cushitic []]
+ ["cym" "Welsh" welsh []]]]
+
+ [[["dak" "Dakota" dakota []]
+ ["dan" "Danish" danish []]
+ ["dar" "Dargwa" dargwa []]
+ ["day" "Land Dayak languages" land_dayak []]
+ ["del" "Delaware" delaware []]
+ ["den" "Slave (Athapascan)" slavey []]
+ ["deu" "German" german []]
+ ["dgr" "Dogrib" dogrib []]
+ ["din" "Dinka" dinka []]
+ ["div" "Divehi; Dhivehi; Maldivian" dhivehi [[maldivian]]]
+ ["doi" "Dogri" dogri []]
+ ["dra" "Dravidian languages" dravidian []]
+ ["dsb" "Lower Sorbian" lower_sorbian []]
+ ["dua" "Duala" duala []]
+ ["dum" "Middle Dutch (ca. 1050–1350)" middle_dutch []]
+ ["dyu" "Dyula" dyula []]
+ ["dzo" "Dzongkha" dzongkha []]]]
+
+ [[["efi" "Efik" efik []]
+ ["egy" "Ancient Egyptian" egyptian []]
+ ["eka" "Ekajuk" ekajuk []]
+ ["ell" "Modern Greek (1453–)" greek []]
+ ["elx" "Elamite" elamite []]
+ ["eng" "English" english []]
+ ["enm" "Middle English (1100–1500)" middle_english []]
+ ["epo" "Esperanto" esperanto []]
+ ["est" "Estonian" estonian []]
+ ["eus" "Basque" basque []]
+ ["ewe" "Ewe" ewe []]
+ ["ewo" "Ewondo" ewondo []]]]
+
+ [[["fan" "Fang" fang []]
+ ["fao" "Faroese" faroese []]
+ ["fas" "Persian" persian []]
+ ["fat" "Fanti" fanti []]
+ ["fij" "Fijian" fijian []]
+ ["fil" "Filipino; Pilipino" filipino []]
+ ["fin" "Finnish" finnish []]
+ ["fiu" "Finno-Ugrian languages" finno_ugrian []]
+ ["fon" "Fon" fon []]
+ ["fra" "French" french []]
+ ["frm" "Middle French (ca. 1400–1600)" middle_french []]
+ ["fro" "Old French (ca. 842–1400)" old_french []]
+ ["frr" "Northern Frisian" northern_frisian []]
+ ["frs" "Eastern Frisian" eastern_frisian []]
+ ["fry" "Western Frisian" western_frisian []]
+ ["ful" "Fulah" fulah []]
+ ["fur" "Friulian" friulian []]]]
+
+ [[["gaa" "Ga" ga []]
+ ["gay" "Gayo" gayo []]
+ ["gba" "Gbaya" gbaya []]
+ ["gem" "Germanic languages" germanic []]
+ ["gez" "Geez" geez []]
+ ["gil" "Gilbertese" gilbertese []]
+ ["gla" "Gaelic; Scottish Gaelic" gaelic []]
+ ["gle" "Irish" irish []]
+ ["glg" "Galician" galician []]
+ ["glv" "Manx" manx []]
+ ["gmh" "Middle High German (ca. 1050–1500)" middle_high_german []]
+ ["goh" "Old High German (ca. 750–1050)" old_high_german []]
+ ["gon" "Gondi" gondi []]
+ ["gor" "Gorontalo" gorontalo []]
+ ["got" "Gothic" gothic []]
+ ["grb" "Grebo" grebo []]
+ ["grc" "Ancient Greek (to 1453)" ancient_greek []]
+ ["grn" "Guarani" guarani []]
+ ["gsw" "Swiss German; Alemannic; Alsatian" swiss_german [[alemannic] [alsatian]]]
+ ["guj" "Gujarati" gujarati []]
+ ["gwi" "Gwich'in" gwich'in []]]]
+
+ [[["hai" "Haida" haida []]
+ ["hat" "Haitian; Haitian Creole" haitian []]
+ ["hau" "Hausa" hausa []]
+ ["haw" "Hawaiian" hawaiian []]
+ ["heb" "Hebrew" hebrew []]
+ ["her" "Herero" herero []]
+ ["hil" "Hiligaynon" hiligaynon []]
+ ["him" "Himachali languages; Pahari languages" himachali []]
+ ["hin" "Hindi" hindi []]
+ ["hit" "Hittite" hittite []]
+ ["hmn" "Hmong; Mong" hmong []]
+ ["hmo" "Hiri Motu" hiri_motu []]
+ ["hrv" "Croatian" croatian []]
+ ["hsb" "Upper Sorbian" upper_sorbian []]
+ ["hun" "Hungarian" hungarian []]
+ ["hup" "Hupa" hupa []]
+ ["hye" "Armenian" armenian []]]]
+
+ [[["iba" "Iban" iban []]
+ ["ibo" "Igbo" igbo []]
+ ["ido" "Ido" ido []]
+ ["iii" "Sichuan Yi; Nuosu" sichuan_yi [[nuosu]]]
+ ["ijo" "Ijo languages" ijo []]
+ ["iku" "Inuktitut" inuktitut []]
+ ["ile" "Interlingue; Occidental" interlingue []]
+ ["ilo" "Iloko" iloko []]
+ ["ina" "Interlingua (International Auxiliary Language Association)" interlingua []]
+ ["inc" "Indic languages" indic []]
+ ["ind" "Indonesian" indonesian []]
+ ["ine" "Indo-European languages" indo_european []]
+ ["inh" "Ingush" ingush []]
+ ["ipk" "Inupiaq" inupiaq []]
+ ["ira" "Iranian languages" iranian []]
+ ["iro" "Iroquoian languages" iroquoian []]
+ ["isl" "Icelandic" icelandic []]
+ ["ita" "Italian" italian []]]]
+
+ [[["jav" "Javanese" javanese []]
+ ["jbo" "Lojban" lojban []]
+ ["jpn" "Japanese" japanese []]
+ ["jpr" "Judeo-Persian" judeo_persian []]
+ ["jrb" "Judeo-Arabic" judeo_arabic []]]]
+
+ [[["kaa" "Kara-Kalpak" kara_kalpak []]
+ ["kab" "Kabyle" kabyle []]
+ ["kac" "Kachin; Jingpho" kachin [[jingpho]]]
+ ["kal" "Kalaallisut; Greenlandic" kalaallisut [[greenlandic]]]
+ ["kam" "Kamba" kamba []]
+ ["kan" "Kannada" kannada []]
+ ["kar" "Karen languages" karen []]
+ ["kas" "Kashmiri" kashmiri []]
+ ["kat" "Georgian" georgian []]
+ ["kau" "Kanuri" kanuri []]
+ ["kaw" "Kawi" kawi []]
+ ["kaz" "Kazakh" kazakh []]
+ ["kbd" "Kabardian" kabardian []]
+ ["kha" "Khasi" khasi []]
+ ["khi" "Khoisan languages" khoisan []]
+ ["khm" "Central Khmer" central_khmer []]
+ ["kho" "Khotanese; Sakan" khotanese [[sakan]]]
+ ["kik" "Kikuyu; Gikuyu" gikuyu []]
+ ["kin" "Kinyarwanda" kinyarwanda []]
+ ["kir" "Kirghiz; Kyrgyz" kyrgyz []]
+ ["kmb" "Kimbundu" kimbundu []]
+ ["kok" "Konkani" konkani []]
+ ["kom" "Komi" komi []]
+ ["kon" "Kongo" kongo []]
+ ["kor" "Korean" korean []]
+ ["kos" "Kosraean" kosraean []]
+ ["kpe" "Kpelle" kpelle []]
+ ["krc" "Karachay-Balkar" karachay_balkar []]
+ ["krl" "Karelian" karelian []]
+ ["kro" "Kru languages" kru []]
+ ["kru" "Kurukh" kurukh []]
+ ["kua" "Kuanyama; Kwanyama" kwanyama []]
+ ["kum" "Kumyk" kumyk []]
+ ["kur" "Kurdish" kurdish []]
+ ["kut" "Kutenai" kutenai []]]]
+
+ [[["lad" "Ladino" ladino []]
+ ["lah" "Lahnda" lahnda []]
+ ["lam" "Lamba" lamba []]
+ ["lao" "Lao" lao []]
+ ["lat" "Latin" latin []]
+ ["lav" "Latvian" latvian []]
+ ["lez" "Lezghian" lezghian []]
+ ["lim" "Limburgan; Limburger; Limburgish" limburgan []]
+ ["lin" "Lingala" lingala []]
+ ["lit" "Lithuanian" lithuanian []]
+ ["lol" "Mongo" mongo []]
+ ["loz" "Lozi" lozi []]
+ ["ltz" "Luxembourgish; Letzeburgesch" luxembourgish []]
+ ["lua" "Luba-Lulua" luba_lulua []]
+ ["lub" "Luba-Katanga" luba_katanga []]
+ ["lug" "Ganda" ganda []]
+ ["lui" "Luiseno" luiseno []]
+ ["lun" "Lunda" lunda []]
+ ["luo" "Luo (Kenya and Tanzania)" luo []]
+ ["lus" "Lushai" lushai []]]]
+
+ [[["mad" "Madurese" madurese []]
+ ["mag" "Magahi" magahi []]
+ ["mah" "Marshallese" marshallese []]
+ ["mai" "Maithili" maithili []]
+ ["mak" "Makasar" makasar []]
+ ["mal" "Malayalam" malayalam []]
+ ["man" "Mandingo" mandingo []]
+ ["map" "Austronesian languages" austronesian []]
+ ["mar" "Marathi" marathi []]
+ ["mas" "Masai" masai []]
+ ["mdf" "Moksha" moksha []]
+ ["mdr" "Mandar" mandar []]
+ ["men" "Mende" mende []]
+ ["mga" "Middle Irish (900–1200)" middle_irish []]
+ ["mic" "Mi'kmaq; Micmac" mi'kmaq [[micmac]]]
+ ["min" "Minangkabau" minangkabau []]
+ ["mkd" "Macedonian" macedonian []]
+ ["mkh" "Mon-Khmer languages" mon_khmer []]
+ ["mlg" "Malagasy" malagasy []]
+ ["mlt" "Maltese" maltese []]
+ ["mnc" "Manchu" manchu []]
+ ["mni" "Manipuri" manipuri []]
+ ["mno" "Manobo languages" manobo []]
+ ["moh" "Mohawk" mohawk []]
+ ["mon" "Mongolian" mongolian []]
+ ["mos" "Mossi" mossi []]
+ ["mri" "Maori" maori []]
+ ["msa" "Malay" malay []]
+ ["mun" "Munda languages" munda []]
+ ["mus" "Creek" creek []]
+ ["mwl" "Mirandese" mirandese []]
+ ["mwr" "Marwari" marwari []]
+ ["mya" "Burmese" burmese []]
+ ["myn" "Mayan languages" mayan []]
+ ["myv" "Erzya" erzya []]]]
+
+ [[["nah" "Nahuatl languages" nahuatl []]
+ ["nai" "North American Indian languages" north_american_indian []]
+ ["nap" "Neapolitan" neapolitan []]
+ ["nau" "Nauru" nauru []]
+ ["nav" "Navajo; Navaho" navajo []]
+ ["nbl" "South Ndebele" south_ndebele []]
+ ["nde" "North Ndebele" north_ndebele []]
+ ["ndo" "Ndonga" ndonga []]
+ ["nds" "Low German; Low Saxon" low_german []]
+ ["nep" "Nepali" nepali []]
+ ["new" "Nepal Bhasa; Newari" newari [[nepal_bhasa]]]
+ ["nia" "Nias" nias []]
+ ["nic" "Niger-Kordofanian languages" niger_kordofanian []]
+ ["niu" "Niuean" niuean []]
+ ["nld" "Dutch; Flemish" dutch [[flemish]]]
+ ["nno" "Norwegian Nynorsk" nynorsk []]
+ ["nob" "Norwegian Bokmål" bokmal []]
+ ["nog" "Nogai" nogai []]
+ ["non" "Old Norse" old_norse []]
+ ["nor" "Norwegian" norwegian []]
+ ["nqo" "N'Ko" n'ko []]
+ ["nso" "Pedi; Sepedi; Northern Sotho" northern_sotho [[pedi] [sepedi]]]
+ ["nub" "Nubian languages" nubian []]
+ ["nwc" "Classical Newari; Old Newari; Classical Nepal Bhasa" old_newari [[classical_newari] [classical_nepal_bhasa]]]
+ ["nya" "Chichewa; Chewa; Nyanja" nyanja [[chichewa] [chewa]]]
+ ["nym" "Nyamwezi" nyamwezi []]
+ ["nyn" "Nyankole" nyankole []]
+ ["nyo" "Nyoro" nyoro []]
+ ["nzi" "Nzima" nzima []]]]
+
+ [[["oci" "Occitan (post 1500); Provençal" occitan [[provencal]]]
+ ["oji" "Ojibwa" ojibwa []]
+ ["ori" "Oriya" oriya []]
+ ["orm" "Oromo" oromo []]
+ ["osa" "Osage" osage []]
+ ["oss" "Ossetian; Ossetic" ossetic []]
+ ["ota" "Ottoman Turkish (1500–1928)" ottoman_turkish []]
+ ["oto" "Otomian languages" otomian []]]]
+
+ [[["paa" "Papuan languages" papuan []]
+ ["pag" "Pangasinan" pangasinan []]
+ ["pal" "Pahlavi" pahlavi []]
+ ["pam" "Pampanga; Kapampangan" pampanga [[kapampangan]]]
+ ["pan" "Panjabi; Punjabi" punjabi []]
+ ["pap" "Papiamento" papiamento []]
+ ["pau" "Palauan" palauan []]
+ ["peo" "Old Persian (ca. 600–400 B.C.)" old_persian []]
+ ["phi" "Philippine languages" philippine []]
+ ["phn" "Phoenician" phoenician []]
+ ["pli" "Pali" pali []]
+ ["pol" "Polish" polish []]
+ ["pon" "Pohnpeian" pohnpeian []]
+ ["por" "Portuguese" portuguese []]
+ ["pra" "Prakrit languages" prakrit []]
+ ["pro" "Old Provençal (to 1500); Old Occitan (to 1500)" old_provencal []]
+ ["pus" "Pushto; Pashto" pashto []]]]
+
+ [[["que" "Quechua" quechua []]]]
+
+ [[["raj" "Rajasthani" rajasthani []]
+ ["rap" "Rapanui" rapanui []]
+ ["rar" "Rarotongan; Cook Islands Maori" rarotongan [[cook_islands_maori]]]
+ ["roa" "Romance languages" romance []]
+ ["roh" "Romansh" romansh []]
+ ["rom" "Romany" romany []]
+ ["ron" "Romanian; Moldavian; Moldovan" romanian [[moldavian] [moldovan]]]
+ ["run" "Rundi" rundi []]
+ ["rup" "Aromanian; Arumanian; Macedo-Romanian" aromanian [[arumanian] [macedo_romanian]]]
+ ["rus" "Russian" russian []]]]
+
+ [[["sad" "Sandawe" sandawe []]
+ ["sag" "Sango" sango []]
+ ["sah" "Yakut" yakut []]
+ ["sai" "South American Indian (Other)" south_american_indian []]
+ ["sal" "Salishan languages" salishan []]
+ ["sam" "Samaritan Aramaic" samaritan_aramaic []]
+ ["san" "Sanskrit" sanskrit []]
+ ["sas" "Sasak" sasak []]
+ ["sat" "Santali" santali []]
+ ["scn" "Sicilian" sicilian []]
+ ["sco" "Scots" scots []]
+ ["sel" "Selkup" selkup []]
+ ["sem" "Semitic languages" semitic []]
+ ["sga" "Old Irish (to 900)" old_irish []]
+ ["sgn" "Sign Languages" sign []]
+ ["shn" "Shan" shan []]
+ ["sid" "Sidamo" sidamo []]
+ ["sin" "Sinhala; Sinhalese" sinhalese []]
+ ["sio" "Siouan languages" siouan []]
+ ["sit" "Sino-Tibetan languages" sino_tibetan []]
+ ["sla" "Slavic languages" slavic []]
+ ["slk" "Slovak" slovak []]
+ ["slv" "Slovenian" slovenian []]
+ ["sma" "Southern Sami" southern_sami []]
+ ["sme" "Northern Sami" northern_sami []]
+ ["smi" "Sami languages" sami []]
+ ["smj" "Lule Sami" lule []]
+ ["smn" "Inari Sami" inari []]
+ ["smo" "Samoan" samoan []]
+ ["sms" "Skolt Sami" skolt_sami []]
+ ["sna" "Shona" shona []]
+ ["snd" "Sindhi" sindhi []]
+ ["snk" "Soninke" soninke []]
+ ["sog" "Sogdian" sogdian []]
+ ["som" "Somali" somali []]
+ ["son" "Songhai languages" songhai []]
+ ["sot" "Southern Sotho" southern_sotho []]
+ ["spa" "Spanish; Castilian" spanish [[castilian]]]
+ ["sqi" "Albanian" albanian []]
+ ["srd" "Sardinian" sardinian []]
+ ["srn" "Sranan Tongo" sranan_tongo []]
+ ["srp" "Serbian" serbian []]
+ ["srr" "Serer" serer []]
+ ["ssa" "Nilo-Saharan languages" nilo_saharan []]
+ ["ssw" "Swati" swati []]
+ ["suk" "Sukuma" sukuma []]
+ ["sun" "Sundanese" sundanese []]
+ ["sus" "Susu" susu []]
+ ["sux" "Sumerian" sumerian []]
+ ["swa" "Swahili" swahili []]
+ ["swe" "Swedish" swedish []]
+ ["syc" "Classical Syriac" classical_syriac []]
+ ["syr" "Syriac" syriac []]]]
+
+ [[["tah" "Tahitian" tahitian []]
+ ["tai" "Tai languages" tai []]
+ ["tam" "Tamil" tamil []]
+ ["tat" "Tatar" tatar []]
+ ["tel" "Telugu" telugu []]
+ ["tem" "Timne" timne []]
+ ["ter" "Tereno" tereno []]
+ ["tet" "Tetum" tetum []]
+ ["tgk" "Tajik" tajik []]
+ ["tgl" "Tagalog" tagalog []]
+ ["tha" "Thai" thai []]
+ ["tig" "Tigre" tigre []]
+ ["tir" "Tigrinya" tigrinya []]
+ ["tiv" "Tiv" tiv []]
+ ["tkl" "Tokelau" tokelau []]
+ ["tlh" "Klingon; tlhIngan-Hol" klingon []]
+ ["tli" "Tlingit" tlingit []]
+ ["tmh" "Tamashek" tamashek []]
+ ["tog" "Tonga (Nyasa)" tonga []]
+ ["ton" "Tonga (Tonga Islands)" tongan []]
+ ["tpi" "Tok Pisin" tok_pisin []]
+ ["tsi" "Tsimshian" tsimshian []]
+ ["tsn" "Tswana" tswana []]
+ ["tso" "Tsonga" tsonga []]
+ ["tuk" "Turkmen" turkmen []]
+ ["tum" "Tumbuka" tumbuka []]
+ ["tup" "Tupi languages" tupi []]
+ ["tur" "Turkish" turkish []]
+ ["tut" "Altaic languages" altaic []]
+ ["tvl" "Tuvalu" tuvalu []]
+ ["twi" "Twi" twi []]
+ ["tyv" "Tuvinian" tuvinian []]]]
+
+ [[["udm" "Udmurt" udmurt []]
+ ["uga" "Ugaritic" ugaritic []]
+ ["uig" "Uighur; Uyghur" uyghur []]
+ ["ukr" "Ukrainian" ukrainian []]
+ ["umb" "Umbundu" umbundu []]
+ ["urd" "Urdu" urdu []]
+ ["uzb" "Uzbek" uzbek []]]]
+
+ [[["vai" "Vai" vai []]
+ ["ven" "Venda" venda []]
+ ["vie" "Vietnamese" vietnamese []]
+ ["vol" "Volapük" volapük []]
+ ["vot" "Votic" votic []]]]
+
+ [[["wak" "Wakashan languages" wakashan []]
+ ["wal" "Wolaitta; Wolaytta" walamo []]
+ ["war" "Waray" waray []]
+ ["was" "Washo" washo []]
+ ["wen" "Sorbian languages" sorbian []]
+ ["wln" "Walloon" walloon []]
+ ["wol" "Wolof" wolof []]]]
+
+ [[["xal" "Kalmyk; Oirat" kalmyk [[oirat]]]
+ ["xho" "Xhosa" xhosa []]]]
+
+ [[["yao" "Yao" yao []]
+ ["yap" "Yapese" yapese []]
+ ["yid" "Yiddish" yiddish []]
+ ["yor" "Yoruba" yoruba []]
+ ["ypk" "Yupik languages" yupik []]]]
+
+ [[["zap" "Zapotec" zapotec []]
+ ["zbl" "Blissymbols; Blissymbolics; Bliss" blissymbols []]
+ ["zen" "Zenaga" zenaga []]
+ ["zgh" "Standard Moroccan Tamazight" standard_moroccan_tamazight []]
+ ["zha" "Zhuang; Chuang" zhuang []]
+ ["zho" "Chinese" chinese []]
+ ["znd" "Zande languages" zande []]
+ ["zul" "Zulu" zulu []]
+ ["zun" "Zuni" zuni []]
+ ["zza" "Zaza; Dimili; Dimli; Kirdki; Kirmanjki; Zazaki" zaza [[dimili] [dimli] [kirdki] [kirmanjki] [zazaki]]]]])
+
+ (implementation: #export equivalence
+ (Equivalence Language)
+
+ (def: (= reference sample)
+ (is? reference sample)))
+
+ (implementation: #export hash
+ (Hash Language)
+
+ (def: &equivalence
+ ..equivalence)
+
+ (def: hash
+ (|>> ..code
+ (\ text.hash hash))))
+ )
diff --git a/stdlib/source/library/lux/locale/territory.lux b/stdlib/source/library/lux/locale/territory.lux
new file mode 100644
index 000000000..be60b6734
--- /dev/null
+++ b/stdlib/source/library/lux/locale/territory.lux
@@ -0,0 +1,312 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]]
+ [data
+ ["." text]]
+ [type
+ abstract]
+ [macro
+ ["." template]]]])
+
+## https://en.wikipedia.org/wiki/ISO_3166-1
+(abstract: #export Territory
+ {#name Text
+ #short Text
+ #long Text
+ #code Nat}
+
+ (template [<name> <field> <type>]
+ [(def: #export <name>
+ (-> Territory <type>)
+ (|>> :representation
+ (get@ <field>)))]
+
+ [name #name Text]
+ [short_code #short Text]
+ [long_code #long Text]
+ [numeric_code #code Nat]
+ )
+
+ (template [<short> <long> <number> <name> <main> <neighbor>+]
+ [(def: #export <main>
+ Territory
+ (:abstraction {#name <name>
+ #short <short>
+ #long <long>
+ #code <number>}))
+
+ (`` (template [<neighbor>]
+ [(def: #export <neighbor> Territory <main>)]
+
+ (~~ (template.splice <neighbor>+))))]
+
+ ["AF" "AFG" 004 "Afghanistan" afghanistan []]
+ ["AX" "ALA" 248 "Ã…land Islands" aland_islands []]
+ ["AL" "ALB" 008 "Albania" albania []]
+ ["DZ" "DZA" 012 "Algeria" algeria []]
+ ["AS" "ASM" 016 "American Samoa" american_samoa []]
+ ["AD" "AND" 020 "Andorra" andorra []]
+ ["AO" "AGO" 024 "Angola" angola []]
+ ["AI" "AIA" 660 "Anguilla" anguilla []]
+ ["AQ" "ATA" 010 "Antarctica" antarctica []]
+ ["AG" "ATG" 028 "Antigua and Barbuda" antigua [[barbuda]]]
+ ["AR" "ARG" 032 "Argentina" argentina []]
+ ["AM" "ARM" 051 "Armenia" armenia []]
+ ["AW" "ABW" 533 "Aruba" aruba []]
+ ["AU" "AUS" 036 "Australia" australia []]
+ ["AT" "AUT" 040 "Austria" austria []]
+ ["AZ" "AZE" 031 "Azerbaijan" azerbaijan []]
+ ["BS" "BHS" 044 "The Bahamas" the_bahamas []]
+ ["BH" "BHR" 048 "Bahrain" bahrain []]
+ ["BD" "BGD" 050 "Bangladesh" bangladesh []]
+ ["BB" "BRB" 052 "Barbados" barbados []]
+ ["BY" "BLR" 112 "Belarus" belarus []]
+ ["BE" "BEL" 056 "Belgium" belgium []]
+ ["BZ" "BLZ" 084 "Belize" belize []]
+ ["BJ" "BEN" 204 "Benin" benin []]
+ ["BM" "BMU" 060 "Bermuda" bermuda []]
+ ["BT" "BTN" 064 "Bhutan" bhutan []]
+ ["BO" "BOL" 068 "Bolivia" bolivia []]
+ ["BQ" "BES" 535 "Bonaire, Sint Eustatius and Saba" bonaire [[sint_eustatius] [saba]]]
+ ["BA" "BIH" 070 "Bosnia and Herzegovina" bosnia [[herzegovina]]]
+ ["BW" "BWA" 072 "Botswana" botswana []]
+ ["BV" "BVT" 074 "Bouvet Island" bouvet_island []]
+ ["BR" "BRA" 076 "Brazil" brazil []]
+ ["IO" "IOT" 086 "British Indian Ocean Territory" british_indian_ocean_territory []]
+ ["BN" "BRN" 096 "Brunei Darussalam" brunei_darussalam []]
+ ["BG" "BGR" 100 "Bulgaria" bulgaria []]
+ ["BF" "BFA" 854 "Burkina Faso" burkina_faso []]
+ ["BI" "BDI" 108 "Burundi" burundi []]
+ ["CV" "CPV" 132 "Cape Verde" cape_verde []]
+ ["KH" "KHM" 116 "Cambodia" cambodia []]
+ ["CM" "CMR" 120 "Cameroon" cameroon []]
+ ["CA" "CAN" 124 "Canada" canada []]
+ ["KY" "CYM" 136 "Cayman Islands" cayman_islands []]
+ ["CF" "CAF" 140 "Central African Republic" central_african_republic []]
+ ["TD" "TCD" 148 "Chad" chad []]
+ ["CL" "CHL" 152 "Chile" chile []]
+ ["CN" "CHN" 156 "China" china []]
+ ["CX" "CXR" 162 "Christmas Island" christmas_island []]
+ ["CC" "CCK" 166 "Cocos (Keeling) Islands" cocos_islands []]
+ ["CO" "COL" 170 "Colombia" colombia []]
+ ["KM" "COM" 174 "Comoros" comoros []]
+ ["CG" "COG" 178 "Congo" congo []]
+ ["CD" "COD" 180 "Democratic Republic of the Congo" democratic_republic_of_the_congo []]
+ ["CK" "COK" 184 "Cook Islands" cook_islands []]
+ ["CR" "CRI" 188 "Costa Rica" costa_rica []]
+ ["CI" "CIV" 384 "Ivory Coast" ivory_coast []]
+ ["HR" "HRV" 191 "Croatia" croatia []]
+ ["CU" "CUB" 192 "Cuba" cuba []]
+ ["CW" "CUW" 531 "Curacao" curacao []]
+ ["CY" "CYP" 196 "Cyprus" cyprus []]
+ ["CZ" "CZE" 203 "Czech Republic" czech_republic []]
+ ["DK" "DNK" 208 "Denmark" denmark []]
+ ["DJ" "DJI" 262 "Djibouti" djibouti []]
+ ["DM" "DMA" 212 "Dominica" dominica []]
+ ["DO" "DOM" 214 "Dominican Republic" dominican_republic []]
+ ["EC" "ECU" 218 "Ecuador" ecuador []]
+ ["EG" "EGY" 818 "Egypt" egypt []]
+ ["SV" "SLV" 222 "El Salvador" el_salvador []]
+ ["GQ" "GNQ" 226 "Equatorial Guinea" equatorial_guinea []]
+ ["ER" "ERI" 232 "Eritrea" eritrea []]
+ ["EE" "EST" 233 "Estonia" estonia []]
+ ["SZ" "SWZ" 748 "Eswatini" eswatini []]
+ ["ET" "ETH" 231 "Ethiopia" ethiopia []]
+ ["FK" "FLK" 238 "Falkland Islands" falkland_islands []]
+ ["FO" "FRO" 234 "Faroe Islands" faroe_islands []]
+ ["FJ" "FJI" 242 "Fiji" fiji []]
+ ["FI" "FIN" 246 "Finland" finland []]
+ ["FR" "FRA" 250 "France" france []]
+ ["GF" "GUF" 254 "French Guiana" french_guiana []]
+ ["PF" "PYF" 258 "French Polynesia" french_polynesia []]
+ ["TF" "ATF" 260 "French Southern Territories" french_southern_territories []]
+ ["GA" "GAB" 266 "Gabon" gabon []]
+ ["GM" "GMB" 270 "The Gambia" the_gambia []]
+ ["GE" "GEO" 268 "Georgia" georgia []]
+ ["DE" "DEU" 276 "Germany" germany []]
+ ["GH" "GHA" 288 "Ghana" ghana []]
+ ["GI" "GIB" 292 "Gibraltar" gibraltar []]
+ ["GR" "GRC" 300 "Greece" greece []]
+ ["GL" "GRL" 304 "Greenland" greenland []]
+ ["GD" "GRD" 308 "Grenada" grenada []]
+ ["GP" "GLP" 312 "Guadeloupe" guadeloupe []]
+ ["GU" "GUM" 316 "Guam" guam []]
+ ["GT" "GTM" 320 "Guatemala" guatemala []]
+ ["GG" "GGY" 831 "Guernsey" guernsey []]
+ ["GN" "GIN" 324 "Guinea" guinea []]
+ ["GW" "GNB" 624 "Guinea-Bissau" guinea_bissau []]
+ ["GY" "GUY" 328 "Guyana" guyana []]
+ ["HT" "HTI" 332 "Haiti" haiti []]
+ ["HM" "HMD" 334 "Heard Island and McDonald Islands" heard_island [[mcdonald_islands]]]
+ ["VA" "VAT" 336 "Vatican City" vatican_city []]
+ ["HN" "HND" 340 "Honduras" honduras []]
+ ["HK" "HKG" 344 "Hong Kong" hong_kong []]
+ ["HU" "HUN" 348 "Hungary" hungary []]
+ ["IS" "ISL" 352 "Iceland" iceland []]
+ ["IN" "IND" 356 "India" india []]
+ ["ID" "IDN" 360 "Indonesia" indonesia []]
+ ["IR" "IRN" 364 "Iran" iran []]
+ ["IQ" "IRQ" 368 "Iraq" iraq []]
+ ["IE" "IRL" 372 "Ireland" ireland []]
+ ["IM" "IMN" 833 "Isle of Man" isle_of_man []]
+ ["IL" "ISR" 376 "Israel" israel []]
+ ["IT" "ITA" 380 "Italy" italy []]
+ ["JM" "JAM" 388 "Jamaica" jamaica []]
+ ["JP" "JPN" 392 "Japan" japan []]
+ ["JE" "JEY" 832 "Jersey" jersey []]
+ ["JO" "JOR" 400 "Jordan" jordan []]
+ ["KZ" "KAZ" 398 "Kazakhstan" kazakhstan []]
+ ["KE" "KEN" 404 "Kenya" kenya []]
+ ["KI" "KIR" 296 "Kiribati" kiribati []]
+ ["KP" "PRK" 408 "North Korea" north_korea []]
+ ["KR" "KOR" 410 "South Korea" south_korea []]
+ ["KW" "KWT" 414 "Kuwait" kuwait []]
+ ["KG" "KGZ" 417 "Kyrgyzstan" kyrgyzstan []]
+ ["LA" "LAO" 418 "Laos" laos []]
+ ["LV" "LVA" 428 "Latvia" latvia []]
+ ["LB" "LBN" 422 "Lebanon" lebanon []]
+ ["LS" "LSO" 426 "Lesotho" lesotho []]
+ ["LR" "LBR" 430 "Liberia" liberia []]
+ ["LY" "LBY" 434 "Libya" libya []]
+ ["LI" "LIE" 438 "Liechtenstein" liechtenstein []]
+ ["LT" "LTU" 440 "Lithuania" lithuania []]
+ ["LU" "LUX" 442 "Luxembourg" luxembourg []]
+ ["MO" "MAC" 446 "Macau" macau []]
+ ["MK" "MKD" 807 "Macedonia" macedonia []]
+ ["MG" "MDG" 450 "Madagascar" madagascar []]
+ ["MW" "MWI" 454 "Malawi" malawi []]
+ ["MY" "MYS" 458 "Malaysia" malaysia []]
+ ["MV" "MDV" 462 "Maldives" maldives []]
+ ["ML" "MLI" 466 "Mali" mali []]
+ ["MT" "MLT" 470 "Malta" malta []]
+ ["MH" "MHL" 584 "Marshall Islands" marshall_islands []]
+ ["MQ" "MTQ" 474 "Martinique" martinique []]
+ ["MR" "MRT" 478 "Mauritania" mauritania []]
+ ["MU" "MUS" 480 "Mauritius" mauritius []]
+ ["YT" "MYT" 175 "Mayotte" mayotte []]
+ ["MX" "MEX" 484 "Mexico" mexico []]
+ ["FM" "FSM" 583 "Micronesia" micronesia []]
+ ["MD" "MDA" 498 "Moldova" moldova []]
+ ["MC" "MCO" 492 "Monaco" monaco []]
+ ["MN" "MNG" 496 "Mongolia" mongolia []]
+ ["ME" "MNE" 499 "Montenegro" montenegro []]
+ ["MS" "MSR" 500 "Montserrat" montserrat []]
+ ["MA" "MAR" 504 "Morocco" morocco []]
+ ["MZ" "MOZ" 508 "Mozambique" mozambique []]
+ ["MM" "MMR" 104 "Myanmar" myanmar []]
+ ["NA" "NAM" 516 "Namibia" namibia []]
+ ["NR" "NRU" 520 "Nauru" nauru []]
+ ["NP" "NPL" 524 "Nepal" nepal []]
+ ["NL" "NLD" 528 "Netherlands" netherlands []]
+ ["NC" "NCL" 540 "New Caledonia" new_caledonia []]
+ ["NZ" "NZL" 554 "New Zealand" new_zealand []]
+ ["NI" "NIC" 558 "Nicaragua" nicaragua []]
+ ["NE" "NER" 562 "Niger" niger []]
+ ["NG" "NGA" 566 "Nigeria" nigeria []]
+ ["NU" "NIU" 570 "Niue" niue []]
+ ["NF" "NFK" 574 "Norfolk Island" norfolk_island []]
+ ["MP" "MNP" 580 "Northern Mariana Islands" northern_mariana_islands []]
+ ["NO" "NOR" 578 "Norway" norway []]
+ ["OM" "OMN" 512 "Oman" oman []]
+ ["PK" "PAK" 586 "Pakistan" pakistan []]
+ ["PW" "PLW" 585 "Palau" palau []]
+ ["PS" "PSE" 275 "Palestine" palestine []]
+ ["PA" "PAN" 591 "Panama" panama []]
+ ["PG" "PNG" 598 "Papua New Guinea" papua_new_guinea []]
+ ["PY" "PRY" 600 "Paraguay" paraguay []]
+ ["PE" "PER" 604 "Peru" peru []]
+ ["PH" "PHL" 608 "Philippines" philippines []]
+ ["PN" "PCN" 612 "Pitcairn Islands" pitcairn_islands []]
+ ["PL" "POL" 616 "Poland" poland []]
+ ["PT" "PRT" 620 "Portugal" portugal []]
+ ["PR" "PRI" 630 "Puerto Rico" puerto_rico []]
+ ["QA" "QAT" 634 "Qatar" qatar []]
+ ["RE" "REU" 638 "Reunion" reunion []]
+ ["RO" "ROU" 642 "Romania" romania []]
+ ["RU" "RUS" 643 "Russia" russia []]
+ ["RW" "RWA" 646 "Rwanda" rwanda []]
+ ["BL" "BLM" 652 "Saint Barthélemy" saint_barthelemy []]
+ ["SH" "SHN" 654 "Saint Helena, Ascension and Tristan da Cunha" saint_helena [[ascension] [tristan_da_cunha]]]
+ ["KN" "KNA" 659 "Saint Kitts and Nevis" saint_kitts [[nevis]]]
+ ["LC" "LCA" 662 "Saint Lucia" saint_lucia []]
+ ["MF" "MAF" 663 "Saint Martin" saint_martin []]
+ ["PM" "SPM" 666 "Saint Pierre and Miquelon" saint_pierre [[miquelon]]]
+ ["VC" "VCT" 670 "Saint Vincent and the Grenadines" saint_vincent [[the_grenadines]]]
+ ["WS" "WSM" 882 "Samoa" samoa []]
+ ["SM" "SMR" 674 "San Marino" san_marino []]
+ ["ST" "STP" 678 "Sao Tome and Principe" sao_tome [[principe]]]
+ ["SA" "SAU" 682 "Saudi Arabia" saudi_arabia []]
+ ["SN" "SEN" 686 "Senegal" senegal []]
+ ["RS" "SRB" 688 "Serbia" serbia []]
+ ["SC" "SYC" 690 "Seychelles" seychelles []]
+ ["SL" "SLE" 694 "Sierra Leone" sierra_leone []]
+ ["SG" "SGP" 702 "Singapore" singapore []]
+ ["SX" "SXM" 534 "Sint Maarten" sint_maarten []]
+ ["SK" "SVK" 703 "Slovakia" slovakia []]
+ ["SI" "SVN" 705 "Slovenia" slovenia []]
+ ["SB" "SLB" 090 "Solomon Islands" solomon_islands []]
+ ["SO" "SOM" 706 "Somalia" somalia []]
+ ["ZA" "ZAF" 710 "South Africa" south_africa []]
+ ["GS" "SGS" 239 "South Georgia and the South Sandwich Islands" south_georgia [[south_sandwich_islands]]]
+ ["SS" "SSD" 728 "South Sudan" south_sudan []]
+ ["ES" "ESP" 724 "Spain" spain []]
+ ["LK" "LKA" 144 "Sri Lanka" sri_lanka []]
+ ["SD" "SDN" 729 "Sudan" sudan []]
+ ["SR" "SUR" 740 "Suriname" suriname []]
+ ["SJ" "SJM" 744 "Svalbard and Jan Mayen" svalbard [[jan_mayen]]]
+ ["SE" "SWE" 752 "Sweden" sweden []]
+ ["CH" "CHE" 756 "Switzerland" switzerland []]
+ ["SY" "SYR" 760 "Syria" syria []]
+ ["TW" "TWN" 158 "Taiwan" taiwan []]
+ ["TJ" "TJK" 762 "Tajikistan" tajikistan []]
+ ["TZ" "TZA" 834 "Tanzania" tanzania []]
+ ["TH" "THA" 764 "Thailand" thailand []]
+ ["TL" "TLS" 626 "East Timor" east_timor []]
+ ["TG" "TGO" 768 "Togo" togo []]
+ ["TK" "TKL" 772 "Tokelau" tokelau []]
+ ["TO" "TON" 776 "Tonga" tonga []]
+ ["TT" "TTO" 780 "Trinidad and Tobago" trinidad [[tobago]]]
+ ["TN" "TUN" 788 "Tunisia" tunisia []]
+ ["TR" "TUR" 792 "Turkey" turkey []]
+ ["TM" "TKM" 795 "Turkmenistan" turkmenistan []]
+ ["TC" "TCA" 796 "Turks and Caicos Islands" turks [[caicos_islands]]]
+ ["TV" "TUV" 798 "Tuvalu" tuvalu []]
+ ["UG" "UGA" 800 "Uganda" uganda []]
+ ["UA" "UKR" 804 "Ukraine" ukraine []]
+ ["AE" "ARE" 784 "United Arab Emirates" united_arab_emirates []]
+ ["GB" "GBR" 826 "United Kingdom of Great Britain and Northern Ireland" united_kingdom [[northern_ireland]]]
+ ["US" "USA" 840 "United States of America" united_states_of_america []]
+ ["UM" "UMI" 581 "United States Minor Outlying Islands" united_states_minor_outlying_islands []]
+ ["UY" "URY" 858 "Uruguay" uruguay []]
+ ["UZ" "UZB" 860 "Uzbekistan" uzbekistan []]
+ ["VU" "VUT" 548 "Vanuatu" vanuatu []]
+ ["VE" "VEN" 862 "Venezuela" venezuela []]
+ ["VN" "VNM" 704 "Vietnam" vietnam []]
+ ["VG" "VGB" 092 "British Virgin Islands" british_virgin_islands []]
+ ["VI" "VIR" 850 "United States Virgin Islands" united_states_virgin_islands []]
+ ["WF" "WLF" 876 "Wallis and Futuna" wallis [[futuna]]]
+ ["EH" "ESH" 732 "Western Sahara" western_sahara []]
+ ["YE" "YEM" 887 "Yemen" yemen []]
+ ["ZM" "ZMB" 894 "Zambia" zambia []]
+ ["ZW" "ZWE" 716 "Zimbabwe" zimbabwe []]
+ )
+
+ (implementation: #export equivalence
+ (Equivalence Territory)
+
+ (def: (= reference sample)
+ (is? reference sample)))
+
+ (implementation: #export hash
+ (Hash Territory)
+
+ (def: &equivalence ..equivalence)
+
+ (def: hash
+ (|>> :representation
+ (get@ #long)
+ (\ text.hash hash))))
+ )
diff --git a/stdlib/source/library/lux/macro.lux b/stdlib/source/library/lux/macro.lux
new file mode 100644
index 000000000..c446dfa70
--- /dev/null
+++ b/stdlib/source/library/lux/macro.lux
@@ -0,0 +1,210 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." text ("#\." monoid)]
+ ["." name ("#\." codec)]
+ [collection
+ ["." list ("#\." monoid monad)]]]
+ [macro
+ ["." code]]
+ [math
+ [number
+ ["." nat]
+ ["." int]]]]]
+ ["." // #_
+ ["#" meta
+ ["." location]]])
+
+(def: #export (expand_once syntax)
+ {#.doc (doc "Given code that requires applying a macro, does it once and returns the result."
+ "Otherwise, returns the code as-is.")}
+ (-> Code (Meta (List Code)))
+ (case syntax
+ [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))]
+ (do //.monad
+ [?macro (//.find_macro name)]
+ (case ?macro
+ (#.Some macro)
+ ((:as Macro' macro) args)
+
+ #.None
+ (\ //.monad wrap (list syntax))))
+
+ _
+ (\ //.monad wrap (list syntax))))
+
+(def: #export (expand syntax)
+ {#.doc (doc "Given code that requires applying a macro, expands repeatedly until no more direct macro-calls are left."
+ "Otherwise, returns the code as-is.")}
+ (-> Code (Meta (List Code)))
+ (case syntax
+ [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))]
+ (do //.monad
+ [?macro (//.find_macro name)]
+ (case ?macro
+ (#.Some macro)
+ (do //.monad
+ [expansion ((:as Macro' macro) args)
+ expansion' (monad.map //.monad expand expansion)]
+ (wrap (list\join expansion')))
+
+ #.None
+ (\ //.monad wrap (list syntax))))
+
+ _
+ (\ //.monad wrap (list syntax))))
+
+(def: #export (expand_all syntax)
+ {#.doc "Expands all macro-calls everywhere recursively, until only primitive/base code remains."}
+ (-> Code (Meta (List Code)))
+ (case syntax
+ [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))]
+ (do //.monad
+ [?macro (//.find_macro name)]
+ (case ?macro
+ (#.Some macro)
+ (do //.monad
+ [expansion ((:as Macro' macro) args)
+ expansion' (monad.map //.monad expand_all expansion)]
+ (wrap (list\join expansion')))
+
+ #.None
+ (do //.monad
+ [parts' (monad.map //.monad expand_all (list& (code.identifier name) args))]
+ (wrap (list (code.form (list\join parts')))))))
+
+ [_ (#.Form (#.Cons [harg targs]))]
+ (do //.monad
+ [harg+ (expand_all harg)
+ targs+ (monad.map //.monad expand_all targs)]
+ (wrap (list (code.form (list\compose harg+ (list\join (: (List (List Code)) targs+)))))))
+
+ [_ (#.Tuple members)]
+ (do //.monad
+ [members' (monad.map //.monad expand_all members)]
+ (wrap (list (code.tuple (list\join members')))))
+
+ [_ (#.Record members)]
+ (|> members
+ (monad.map //.monad
+ (function (_ [left right])
+ (do //.monad
+ [left (expand_all left)
+ right (expand_all right)]
+ (case [left right]
+ [(#.Cons left #.Nil) (#.Cons right #.Nil)]
+ (wrap [left right])
+
+ _
+ (//.fail "Record members must expand into singletons.")))))
+ (\ //.monad map (|>> code.record list)))
+
+ _
+ (\ //.monad wrap (list syntax))))
+
+(def: #export (gensym prefix)
+ {#.doc (doc "Generates a unique name as an Code node (ready to be used in code templates)."
+ "A prefix can be given (or just be empty text) to better identify the code for debugging purposes.")}
+ (-> Text (Meta Code))
+ (do //.monad
+ [id //.count]
+ (wrap (|> id
+ (\ nat.decimal encode)
+ ($_ text\compose "__gensym__" prefix)
+ [""] code.identifier))))
+
+(def: (get_local_identifier ast)
+ (-> Code (Meta Text))
+ (case ast
+ [_ (#.Identifier [_ name])]
+ (\ //.monad wrap name)
+
+ _
+ (//.fail (text\compose "Code is not a local identifier: " (code.format ast)))))
+
+(def: #export wrong_syntax_error
+ (-> Name Text)
+ (|>> name\encode
+ (text\compose "Wrong syntax for ")))
+
+(macro: #export (with_gensyms tokens)
+ {#.doc (doc "Creates new identifiers 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 [_ (#.Tuple identifiers)] body))
+ (do {! //.monad}
+ [identifier_names (monad.map ! ..get_local_identifier identifiers)
+ #let [identifier_defs (list\join (list\map (: (-> Text (List Code))
+ (function (_ name) (list (code.identifier ["" name]) (` (gensym (~ (code.text name)))))))
+ identifier_names))]]
+ (wrap (list (` ((~! do) (~! //.monad)
+ [(~+ identifier_defs)]
+ (~ body))))))
+
+ _
+ (//.fail (..wrong_syntax_error (name_of ..with_gensyms)))))
+
+(def: #export (expand_1 token)
+ {#.doc "Works just like expand, except that it ensures that the output is a single Code token."}
+ (-> Code (Meta Code))
+ (do //.monad
+ [token+ (..expand token)]
+ (case token+
+ (^ (list token'))
+ (wrap token')
+
+ _
+ (//.fail "Macro expanded to more than 1 element."))))
+
+(template [<macro> <func>]
+ [(macro: #export (<macro> tokens)
+ {#.doc (doc "Performs a macro-expansion and logs the resulting code."
+ "You can either use the resulting code, or omit them."
+ "By omitting them, this macro produces nothing (just like the lux.comment macro)."
+ (<macro> #omit
+ (def: (foo bar baz)
+ (-> Int Int Int)
+ (int.+ bar baz))))}
+ (let [[module _] (name_of .._)
+ [_ short] (name_of <macro>)
+ macro_name [module short]]
+ (case (: (Maybe [Bit Code])
+ (case tokens
+ (^ (list [_ (#.Tag ["" "omit"])]
+ token))
+ (#.Some [#1 token])
+
+ (^ (list token))
+ (#.Some [#0 token])
+
+ _
+ #.None))
+ (#.Some [omit? token])
+ (do //.monad
+ [location //.location
+ output (<func> token)
+ #let [_ ("lux io log" ($_ text\compose (name\encode macro_name) " " (location.format location)))
+ _ (list\map (|>> code.format "lux io log")
+ output)
+ _ ("lux io log" "")]]
+ (wrap (if omit?
+ (list)
+ output)))
+
+ #.None
+ (//.fail (..wrong_syntax_error macro_name)))))]
+
+ [log_expand_once! expand_once]
+ [log_expand! expand]
+ [log_expand_all! expand_all]
+ )
diff --git a/stdlib/source/library/lux/macro/code.lux b/stdlib/source/library/lux/macro/code.lux
new file mode 100644
index 000000000..ec99f68a4
--- /dev/null
+++ b/stdlib/source/library/lux/macro/code.lux
@@ -0,0 +1,161 @@
+(.module:
+ [library
+ [lux (#- nat int rev)
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." product]
+ ["." bit]
+ ["." name]
+ ["." text ("#\." monoid equivalence)]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [math
+ [number
+ ["." nat]
+ ["." int]
+ ["." rev]
+ ["." frac]]]
+ [meta
+ ["." location]]]])
+
+## (type: (Code' w)
+## (#.Bit Bit)
+## (#.Nat Nat)
+## (#.Int Int)
+## (#.Rev Rev)
+## (#.Frac Frac)
+## (#.Text Text)
+## (#.Identifier Name)
+## (#.Tag Name)
+## (#.Form (List (w (Code' w))))
+## (#.Tuple (List (w (Code' w))))
+## (#.Record (List [(w (Code' w)) (w (Code' w))])))
+
+## (type: Code
+## (Ann Location (Code' (Ann Location))))
+
+(template [<name> <type> <tag>]
+ [(def: #export (<name> x)
+ (-> <type> Code)
+ [location.dummy (<tag> x)])]
+
+ [bit Bit #.Bit]
+ [nat Nat #.Nat]
+ [int Int #.Int]
+ [rev Rev #.Rev]
+ [frac Frac #.Frac]
+ [text Text #.Text]
+ [identifier Name #.Identifier]
+ [tag Name #.Tag]
+ [form (List Code) #.Form]
+ [tuple (List Code) #.Tuple]
+ [record (List [Code Code]) #.Record]
+ )
+
+(template [<name> <tag> <doc>]
+ [(def: #export (<name> name)
+ {#.doc <doc>}
+ (-> Text Code)
+ [location.dummy (<tag> ["" name])])]
+
+ [local_identifier #.Identifier "Produces a local identifier (an identifier with no module prefix)."]
+ [local_tag #.Tag "Produces a local tag (a tag with no module prefix)."])
+
+(implementation: #export equivalence
+ (Equivalence Code)
+
+ (def: (= x y)
+ (case [x y]
+ (^template [<tag> <eq>]
+ [[[_ (<tag> x')] [_ (<tag> y')]]
+ (\ <eq> = x' y')])
+ ([#.Bit bit.equivalence]
+ [#.Nat nat.equivalence]
+ [#.Int int.equivalence]
+ [#.Rev rev.equivalence]
+ [#.Frac frac.equivalence]
+ [#.Text text.equivalence]
+ [#.Identifier name.equivalence]
+ [#.Tag name.equivalence])
+
+ (^template [<tag>]
+ [[[_ (<tag> xs')] [_ (<tag> ys')]]
+ (\ (list.equivalence =) = xs' ys')])
+ ([#.Form]
+ [#.Tuple])
+
+ [[_ (#.Record xs')] [_ (#.Record ys')]]
+ (\ (list.equivalence (product.equivalence = =))
+ = xs' ys')
+
+ _
+ false)))
+
+(def: #export (format ast)
+ (-> Code Text)
+ (case ast
+ (^template [<tag> <struct>]
+ [[_ (<tag> value)]
+ (\ <struct> encode value)])
+ ([#.Bit bit.codec]
+ [#.Nat nat.decimal]
+ [#.Int int.decimal]
+ [#.Rev rev.decimal]
+ [#.Frac frac.decimal]
+ [#.Identifier name.codec])
+
+ [_ (#.Text value)]
+ (text.format value)
+
+ [_ (#.Tag name)]
+ (text\compose "#" (\ name.codec encode name))
+
+ (^template [<tag> <open> <close>]
+ [[_ (<tag> members)]
+ ($_ text\compose
+ <open>
+ (list\fold (function (_ next prev)
+ (let [next (format next)]
+ (if (text\= "" prev)
+ next
+ ($_ text\compose prev " " next))))
+ ""
+ members)
+ <close>)])
+ ([#.Form "(" ")"]
+ [#.Tuple "[" "]"])
+
+ [_ (#.Record pairs)]
+ ($_ text\compose
+ "{"
+ (list\fold (function (_ [left right] prev)
+ (let [next ($_ text\compose (format left) " " (format right))]
+ (if (text\= "" prev)
+ next
+ ($_ text\compose prev " " next))))
+ ""
+ pairs)
+ "}")
+ ))
+
+(def: #export (replace original substitute ast)
+ {#.doc "Replaces all code that looks like the 'original' with the 'substitute'."}
+ (-> Code Code Code Code)
+ (if (\ ..equivalence = original ast)
+ substitute
+ (case ast
+ (^template [<tag>]
+ [[location (<tag> parts)]
+ [location (<tag> (list\map (replace original substitute) parts))]])
+ ([#.Form]
+ [#.Tuple])
+
+ [location (#.Record parts)]
+ [location (#.Record (list\map (function (_ [left right])
+ [(replace original substitute left)
+ (replace original substitute right)])
+ parts))]
+
+ _
+ ast)))
diff --git a/stdlib/source/library/lux/macro/local.lux b/stdlib/source/library/lux/macro/local.lux
new file mode 100644
index 000000000..4eb9c35c6
--- /dev/null
+++ b/stdlib/source/library/lux/macro/local.lux
@@ -0,0 +1,106 @@
+(.module:
+ [library
+ [lux #*
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." product]
+ ["." text]
+ [collection
+ ["." list ("#\." functor)]
+ [dictionary
+ ["." plist (#+ PList)]]]]]]
+ ["." //
+ ["#." code]])
+
+(exception: #export (unknown_module {module Text})
+ (exception.report
+ ["Module" (text.format module)]))
+
+(template [<name>]
+ [(exception: #export (<name> {module Text} {definition Text})
+ (exception.report
+ ["Module" (text.format module)]
+ ["Definition" (text.format definition)]))]
+
+ [cannot_shadow_definition]
+ [unknown_definition]
+ )
+
+(def: (with_module name body)
+ (All [a] (-> Text (-> Module (Try [Module a])) (Meta a)))
+ (function (_ compiler)
+ (case (|> compiler (get@ #.modules) (plist.get name))
+ (#.Some module)
+ (case (body module)
+ (#try.Success [module' output])
+ (#try.Success [(update@ #.modules (plist.put name module') compiler)
+ output])
+
+ (#try.Failure error)
+ (#try.Failure error))
+
+ #.None
+ (exception.throw ..unknown_module [name]))))
+
+(def: (push_one [name macro])
+ (-> [Name Macro] (Meta Any))
+ (do meta.monad
+ [[module_name definition_name] (meta.normalize name)
+ #let [definition (: Global (#.Definition [false .Macro (' {}) macro]))
+ add_macro! (: (-> (PList Global) (PList Global))
+ (plist.put definition_name definition))]]
+ (..with_module module_name
+ (function (_ module)
+ (case (|> module (get@ #.definitions) (plist.get definition_name))
+ #.None
+ (#try.Success [(update@ #.definitions add_macro! module)
+ []])
+
+ (#.Some _)
+ (exception.throw ..cannot_shadow_definition [module_name definition_name]))))))
+
+(def: (pop_one name)
+ (-> Name (Meta Any))
+ (do meta.monad
+ [[module_name definition_name] (meta.normalize name)
+ #let [remove_macro! (: (-> (PList Global) (PList Global))
+ (plist.remove definition_name))]]
+ (..with_module module_name
+ (function (_ module)
+ (case (|> module (get@ #.definitions) (plist.get definition_name))
+ (#.Some _)
+ (#try.Success [(update@ #.definitions remove_macro! module)
+ []])
+
+ #.None
+ (exception.throw ..unknown_definition [module_name definition_name]))))))
+
+(def: (pop_all macros self)
+ (-> (List Name) Name Macro)
+ ("lux macro"
+ (function (_ _)
+ (do {! meta.monad}
+ [_ (monad.map ! ..pop_one macros)
+ _ (..pop_one self)
+ compiler meta.get_compiler]
+ (wrap (case (get@ #.expected compiler)
+ (#.Some _)
+ (list (' []))
+
+ #.None
+ (list)))))))
+
+(def: #export (push macros)
+ (-> (List [Name Macro]) (Meta Code))
+ (do meta.monad
+ [_ (monad.map meta.monad ..push_one macros)
+ seed meta.count
+ g!pop (//.gensym "pop")
+ _ (let [g!pop (: Name ["" (//code.format g!pop)])]
+ (..push_one [g!pop (..pop_all (list\map product.left macros) g!pop)]))]
+ (wrap (` ((~ g!pop))))))
diff --git a/stdlib/source/library/lux/macro/poly.lux b/stdlib/source/library/lux/macro/poly.lux
new file mode 100644
index 000000000..5ce420e7a
--- /dev/null
+++ b/stdlib/source/library/lux/macro/poly.lux
@@ -0,0 +1,128 @@
+(.module:
+ [library
+ [lux #*
+ ["." meta]
+ ["." type]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["p" parser
+ ["<.>" type (#+ Env)]
+ ["s" code]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text]
+ [collection
+ ["." list ("#\." fold functor)]
+ ["." dictionary]]]
+ [macro (#+ with_gensyms)
+ ["." code]
+ [syntax (#+ syntax:)
+ ["|.|" export]]]
+ [math
+ [number
+ ["n" nat]]]]])
+
+(syntax: #export (poly: {export |export|.parser}
+ {name s.local_identifier}
+ body)
+ (with_gensyms [g!_ g!type g!output]
+ (let [g!name (code.identifier ["" name])]
+ (wrap (.list (` ((~! syntax:) (~+ (|export|.format export)) ((~ g!name) {(~ g!type) (~! s.identifier)})
+ ((~! do) (~! meta.monad)
+ [(~ g!type) ((~! meta.find_type_def) (~ g!type))]
+ (case (: (.Either .Text .Code)
+ ((~! <type>.run) ((~! p.rec)
+ (function ((~ g!_) (~ g!name))
+ (~ body)))
+ (~ g!type)))
+ (#.Left (~ g!output))
+ ((~! meta.fail) (~ g!output))
+
+ (#.Right (~ g!output))
+ ((~' wrap) (.list (~ g!output))))))))))))
+
+(def: (common_poly_name? poly_func)
+ (-> Text Bit)
+ (text.contains? "?" poly_func))
+
+(def: (derivation_name poly args)
+ (-> Text (List Text) (Maybe Text))
+ (if (common_poly_name? poly)
+ (#.Some (list\fold (text.replace_once "?") poly args))
+ #.None))
+
+(syntax: #export (derived: {export |export|.parser}
+ {?name (p.maybe s.local_identifier)}
+ {[poly_func poly_args] (s.form (p.and s.identifier (p.many s.identifier)))}
+ {?custom_impl (p.maybe s.any)})
+ (do {! meta.monad}
+ [poly_args (monad.map ! meta.normalize poly_args)
+ name (case ?name
+ (#.Some name)
+ (wrap name)
+
+ (^multi #.None
+ [(derivation_name (product.right poly_func) (list\map product.right poly_args))
+ (#.Some derived_name)])
+ (wrap derived_name)
+
+ _
+ (p.fail "derived: was given no explicit name, and cannot generate one from given information."))
+ #let [impl (case ?custom_impl
+ (#.Some custom_impl)
+ custom_impl
+
+ #.None
+ (` ((~ (code.identifier poly_func)) (~+ (list\map code.identifier poly_args)))))]]
+ (wrap (.list (` (def: (~+ (|export|.format export))
+ (~ (code.identifier ["" name]))
+ {#.implementation? #1}
+ (~ impl)))))))
+
+(def: #export (to_code env type)
+ (-> Env Type Code)
+ (`` (case type
+ (#.Primitive name params)
+ (` (#.Primitive (~ (code.text name))
+ (list (~+ (list\map (to_code env) params)))))
+
+ (^template [<tag>]
+ [(<tag> idx)
+ (` (<tag> (~ (code.nat idx))))])
+ ([#.Var] [#.Ex])
+
+ (#.Parameter idx)
+ (let [idx (<type>.adjusted_idx env idx)]
+ (if (n.= 0 idx)
+ (|> (dictionary.get idx env) maybe.assume product.left (to_code env))
+ (` (.$ (~ (code.nat (dec idx)))))))
+
+ (#.Apply (#.Named [(~~ (static .prelude_module)) "Nothing"] _) (#.Parameter idx))
+ (let [idx (<type>.adjusted_idx env idx)]
+ (if (n.= 0 idx)
+ (|> (dictionary.get idx env) maybe.assume product.left (to_code env))
+ (undefined)))
+
+ (^template [<tag>]
+ [(<tag> left right)
+ (` (<tag> (~ (to_code env left))
+ (~ (to_code env right))))])
+ ([#.Function] [#.Apply])
+
+ (^template [<macro> <tag> <flattener>]
+ [(<tag> left right)
+ (` (<macro> (~+ (list\map (to_code env) (<flattener> type)))))])
+ ([| #.Sum type.flatten_variant]
+ [& #.Product type.flatten_tuple])
+
+ (#.Named name sub_type)
+ (code.identifier name)
+
+ (^template [<tag>]
+ [(<tag> scope body)
+ (` (<tag> (list (~+ (list\map (to_code env) scope)))
+ (~ (to_code env body))))])
+ ([#.UnivQ] [#.ExQ])
+ )))
diff --git a/stdlib/source/library/lux/macro/syntax.lux b/stdlib/source/library/lux/macro/syntax.lux
new file mode 100644
index 000000000..c2ddeefe5
--- /dev/null
+++ b/stdlib/source/library/lux/macro/syntax.lux
@@ -0,0 +1,129 @@
+(.module:
+ [library
+ [lux #*
+ ["." macro (#+ with_gensyms)]
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]
+ ["<>" parser
+ ["</>" code (#+ Parser)]]]
+ [data
+ ["." maybe]
+ ["." text ("#\." monoid)]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ [number
+ ["." nat]
+ ["." int]
+ ["." rev]
+ ["." frac]]]]]
+ [//
+ ["." code]])
+
+(def: (self_documenting binding parser)
+ (All [a] (-> Code (Parser a) (Parser a)))
+ (function (_ tokens)
+ (case (parser tokens)
+ (#try.Success [tokens output])
+ (#try.Success [tokens output])
+
+ (#try.Failure error)
+ (#try.Failure ($_ text\compose
+ "Failed to parse: " (code.format binding) text.new_line
+ error)))))
+
+(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'))))
+
+(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 Meta 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\compose "anon-class:"
+ (spaced (list (super_class_decl$ (maybe.default object_super_class super))
+ (with_brackets (spaced (list\map super_class_decl$ interfaces)))
+ (with_brackets (spaced (list\map constructor_arg$ constructor_args)))
+ (with_brackets (spaced (list\map (method_def$ id) methods))))))]
+ (wrap (list (` ((~ (code.text def_code)))))))))}
+ (let [[exported? tokens] (: [Bit (List Code)]
+ (case tokens
+ (^ (list& [_ (#.Tag ["" "export"])] tokens'))
+ [#1 tokens']
+
+ _
+ [#0 tokens]))
+ ?parts (: (Maybe [Text (List Code) Code Code])
+ (case tokens
+ (^ (list [_ (#.Form (list& [_ (#.Identifier ["" name])] args))]
+ body))
+ (#.Some name args (` {}) body)
+
+ (^ (list [_ (#.Form (list& [_ (#.Identifier ["" 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!error]
+ (do {! meta.monad}
+ [vars+parsers (monad.map !
+ (: (-> Code (Meta [Code Code]))
+ (function (_ arg)
+ (case arg
+ (^ [_ (#.Record (list [var parser]))])
+ (case var
+ [_ (#.Tag ["" "let"])]
+ (wrap [var parser])
+
+ _
+ (wrap [var
+ (` ((~! ..self_documenting) (' (~ var))
+ (~ parser)))]))
+
+ [_ (#.Identifier var_name)]
+ (wrap [arg
+ (` ((~! ..self_documenting) (' (~ arg))
+ (~! </>.any)))])
+
+ _
+ (meta.fail "Syntax pattern expects records or identifiers."))))
+ args)
+ this_module meta.current_module_name
+ #let [g!state (code.identifier ["" "*compiler*"])
+ error_msg (code.text (macro.wrong_syntax_error [this_module name]))
+ export_ast (: (List Code)
+ (if exported?
+ (list (' #export))
+ (list)))]]
+ (wrap (list (` (macro: (~+ export_ast) ((~ (code.identifier ["" name])) (~ g!tokens) (~ g!state))
+ (~ meta)
+ ({(#.Right (~ g!body))
+ ((~ g!body) (~ g!state))
+
+ (#.Left (~ g!error))
+ (#.Left ((~! text.join_with) (~! text.new_line) (list (~ error_msg) (~ g!error))))}
+ ((~! </>.run)
+ (: ((~! </>.Parser) (Meta (List Code)))
+ ((~! do) (~! <>.monad)
+ [(~+ (..join_pairs vars+parsers))]
+ ((~' wrap) (~ body))))
+ (~ g!tokens)))))))))
+
+ _
+ (meta.fail (macro.wrong_syntax_error (name_of ..syntax:))))))
diff --git a/stdlib/source/library/lux/macro/syntax/annotations.lux b/stdlib/source/library/lux/macro/syntax/annotations.lux
new file mode 100644
index 000000000..28f5a233e
--- /dev/null
+++ b/stdlib/source/library/lux/macro/syntax/annotations.lux
@@ -0,0 +1,42 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." name]
+ [collection
+ ["." list ("#\." functor)]]]
+ [macro
+ ["." code]]]])
+
+(type: #export Annotations
+ (List [Name Code]))
+
+(def: #export equivalence
+ (Equivalence Annotations)
+ (list.equivalence
+ (product.equivalence name.equivalence
+ code.equivalence)))
+
+(def: #export empty
+ Annotations
+ (list))
+
+(def: #export format
+ (-> Annotations Code)
+ (let [entry (product.apply code.tag function.identity)]
+ (|>> (list\map entry)
+ code.record)))
+
+(def: #export parser
+ (Parser Annotations)
+ (<code>.record
+ (<>.some
+ (<>.and <code>.tag
+ <code>.any))))
diff --git a/stdlib/source/library/lux/macro/syntax/check.lux b/stdlib/source/library/lux/macro/syntax/check.lux
new file mode 100644
index 000000000..bd4214eab
--- /dev/null
+++ b/stdlib/source/library/lux/macro/syntax/check.lux
@@ -0,0 +1,42 @@
+(.module:
+ [library
+ [lux #*
+ ["." meta]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." product]]
+ [macro
+ ["." code]]]])
+
+(def: extension
+ "lux check")
+
+(type: #export Check
+ {#type Code
+ #value Code})
+
+(def: #export equivalence
+ (Equivalence Check)
+ ($_ product.equivalence
+ code.equivalence
+ code.equivalence
+ ))
+
+(def: #export (format (^slots [#type #value]))
+ (-> Check Code)
+ (` ((~ (code.text ..extension))
+ (~ type)
+ (~ value))))
+
+(def: #export parser
+ (Parser Check)
+ (<| <code>.form
+ (<>.after (<code>.text! ..extension))
+ (<>.and <code>.any
+ <code>.any)))
diff --git a/stdlib/source/library/lux/macro/syntax/declaration.lux b/stdlib/source/library/lux/macro/syntax/declaration.lux
new file mode 100644
index 000000000..d1c7d94c6
--- /dev/null
+++ b/stdlib/source/library/lux/macro/syntax/declaration.lux
@@ -0,0 +1,47 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [control
+ ["<>" parser ("#\." monad)
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." text]
+ [collection
+ ["." list ("#\." functor)]]]
+ [macro
+ ["." code]]]])
+
+(type: #export Declaration
+ {#name Text
+ #arguments (List Text)})
+
+(def: #export equivalence
+ (Equivalence Declaration)
+ ($_ product.equivalence
+ text.equivalence
+ (list.equivalence text.equivalence)
+ ))
+
+(def: #export parser
+ {#.doc (doc "A parser for declaration syntax."
+ "Such as:"
+ quux
+ (foo bar baz))}
+ (Parser Declaration)
+ (<>.either (<>.and <code>.local_identifier
+ (<>\wrap (list)))
+ (<code>.form (<>.and <code>.local_identifier
+ (<>.some <code>.local_identifier)))))
+
+(def: #export (format value)
+ (-> Declaration Code)
+ (let [g!name (code.local_identifier (get@ #name value))]
+ (case (get@ #arguments value)
+ #.Nil
+ g!name
+
+ arguments
+ (` ((~ g!name) (~+ (list\map code.local_identifier arguments)))))))
diff --git a/stdlib/source/library/lux/macro/syntax/definition.lux b/stdlib/source/library/lux/macro/syntax/definition.lux
new file mode 100644
index 000000000..1e309a306
--- /dev/null
+++ b/stdlib/source/library/lux/macro/syntax/definition.lux
@@ -0,0 +1,141 @@
+(.module:
+ [library
+ [lux (#- Definition)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." sum]
+ ["." product]
+ ["." bit]
+ ["." name]
+ ["." text
+ ["%" format]]
+ [collection
+ ["." list]]]
+ ["." macro
+ ["." code]]
+ ["." meta
+ ["." location]]]]
+ ["." //
+ ["#." annotations (#+ Annotations)]
+ ["#." check (#+ Check)]])
+
+(type: #export Definition
+ {#name Text
+ #value (Either Check
+ Code)
+ #anns Annotations
+ #export? Bit})
+
+(def: #export equivalence
+ (Equivalence Definition)
+ ($_ product.equivalence
+ text.equivalence
+ ($_ sum.equivalence
+ //check.equivalence
+ code.equivalence
+ )
+ //annotations.equivalence
+ bit.equivalence
+ ))
+
+(def: extension
+ "lux def")
+
+(def: (format_tag [module short])
+ (-> Name Code)
+ (` [(~ (code.text module))
+ (~ (code.text short))]))
+
+(def: (format_annotations value)
+ (-> Annotations Code)
+ (case value
+ #.Nil
+ (` #.Nil)
+
+ (#.Cons [name value] tail)
+ (` (#.Cons [(~ (..format_tag name))
+ (~ value)]
+ (~ (format_annotations tail))))))
+
+(def: dummy
+ Code
+ (` {#.module (~ (code.text (get@ #.module location.dummy)))
+ #.line (~ (code.nat (get@ #.line location.dummy)))
+ #.column (~ (code.nat (get@ #.column location.dummy)))}))
+
+(def: #export (format (^slots [#name #value #anns #export?]))
+ (-> Definition Code)
+ (` ((~ (code.text ..extension))
+ (~ (code.local_identifier name))
+ (~ (case value
+ (#.Left check)
+ (//check.format check)
+
+ (#.Right value)
+ value))
+ [(~ ..dummy) (#.Record (~ (..format_annotations anns)))]
+ (~ (code.bit export?)))))
+
+(def: tag_parser
+ (Parser Name)
+ (<code>.tuple (<>.and <code>.text <code>.text)))
+
+(def: annotations_parser
+ (Parser Annotations)
+ (<>.rec
+ (function (_ recur)
+ ($_ <>.or
+ (<code>.tag! (name_of #.Nil))
+ (<code>.form (do <>.monad
+ [_ (<code>.tag! (name_of #.Cons))
+ [head tail] (<>.and (<code>.tuple (<>.and tag_parser <code>.any))
+ recur)]
+ (wrap [head tail])))
+ ))))
+
+(def: #export (parser compiler)
+ {#.doc "A reader that first macro-expands and then analyses the input Code, to ensure it's a definition."}
+ (-> Lux (Parser Definition))
+ (do {! <>.monad}
+ [raw <code>.any
+ me_raw (|> raw
+ macro.expand_all
+ (meta.run compiler)
+ <>.lift)]
+ (<| (<code>.local me_raw)
+ <code>.form
+ (<>.after (<code>.text! ..extension))
+ ($_ <>.and
+ <code>.local_identifier
+ (<>.or //check.parser
+ <code>.any)
+ (<| <code>.tuple
+ (<>.after <code>.any)
+ <code>.form
+ (<>.after (<code>.this! (` #.Record)))
+ ..annotations_parser)
+ <code>.bit
+ ))))
+
+(exception: #export (lacks_type! {definition Definition})
+ (exception.report
+ ["Definition" (%.code (..format definition))]))
+
+(def: #export (typed compiler)
+ {#.doc "Only works for typed definitions."}
+ (-> Lux (Parser Definition))
+ (do <>.monad
+ [definition (..parser compiler)
+ _ (case (get@ #value definition)
+ (#.Left _)
+ (wrap [])
+
+ (#.Right _)
+ (<>.lift (exception.throw ..lacks_type! [definition])))]
+ (wrap definition)))
diff --git a/stdlib/source/library/lux/macro/syntax/export.lux b/stdlib/source/library/lux/macro/syntax/export.lux
new file mode 100644
index 000000000..d76aa6fcc
--- /dev/null
+++ b/stdlib/source/library/lux/macro/syntax/export.lux
@@ -0,0 +1,21 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ ["<>" parser ("#\." monad)
+ ["<.>" code (#+ Parser)]]]]])
+
+(def: token
+ (' #export))
+
+(def: #export (format exported?)
+ (-> Bit (List Code))
+ (if exported?
+ (list ..token)
+ (list)))
+
+(def: #export parser
+ (Parser Bit)
+ (<>.either (<>.after (<code>.this! ..token)
+ (<>\wrap true))
+ (<>\wrap false)))
diff --git a/stdlib/source/library/lux/macro/syntax/input.lux b/stdlib/source/library/lux/macro/syntax/input.lux
new file mode 100644
index 000000000..9307322d9
--- /dev/null
+++ b/stdlib/source/library/lux/macro/syntax/input.lux
@@ -0,0 +1,38 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [control
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." product]]
+ [macro
+ ["." code]]]])
+
+(type: #export Input
+ {#binding Code
+ #type Code})
+
+(def: #export equivalence
+ (Equivalence Input)
+ ($_ product.equivalence
+ code.equivalence
+ code.equivalence
+ ))
+
+(def: #export (format value)
+ (-> Input Code)
+ (code.record
+ (list [(get@ #binding value)
+ (get@ #type value)])))
+
+(def: #export parser
+ {#.doc "Parser for the common typed-argument syntax used by many macros."}
+ (Parser Input)
+ (<code>.record
+ ($_ <>.and
+ <code>.any
+ <code>.any
+ )))
diff --git a/stdlib/source/library/lux/macro/syntax/type/variable.lux b/stdlib/source/library/lux/macro/syntax/type/variable.lux
new file mode 100644
index 000000000..e73020c42
--- /dev/null
+++ b/stdlib/source/library/lux/macro/syntax/type/variable.lux
@@ -0,0 +1,28 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [control
+ [parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." text]]
+ [macro
+ ["." code]]]])
+
+(type: #export Variable
+ Text)
+
+(def: #export equivalence
+ (Equivalence Variable)
+ text.equivalence)
+
+(def: #export format
+ (-> Variable Code)
+ code.local_identifier)
+
+(def: #export parser
+ {#.doc "Parser for the common type variable/parameter used by many macros."}
+ (Parser Variable)
+ <code>.local_identifier)
diff --git a/stdlib/source/library/lux/macro/template.lux b/stdlib/source/library/lux/macro/template.lux
new file mode 100644
index 000000000..c489703fc
--- /dev/null
+++ b/stdlib/source/library/lux/macro/template.lux
@@ -0,0 +1,185 @@
+(.module:
+ [library
+ [lux (#- let)
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["<>" parser ("#\." functor)
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." bit ("#\." codec)]
+ ["." text]
+ [collection
+ ["." list ("#\." monad)]
+ ["." dictionary (#+ Dictionary)]]]
+ [math
+ [number
+ ["." nat ("#\." decimal)]
+ ["." int ("#\." decimal)]
+ ["." rev ("#\." decimal)]
+ ["." frac ("#\." decimal)]]]]]
+ ["." //
+ [syntax (#+ syntax:)]
+ ["." code]
+ ["." local]])
+
+(syntax: #export (splice {parts (<code>.tuple (<>.some <code>.any))})
+ (wrap parts))
+
+(syntax: #export (count {parts (<code>.tuple (<>.some <code>.any))})
+ (wrap (list (code.nat (list.size parts)))))
+
+(syntax: #export (with_locals {locals (<code>.tuple (<>.some <code>.local_identifier))}
+ body)
+ (do {! meta.monad}
+ [g!locals (|> locals
+ (list\map //.gensym)
+ (monad.seq !))]
+ (wrap (list (` (.with_expansions [(~+ (|> (list.zip/2 locals g!locals)
+ (list\map (function (_ [name identifier])
+ (list (code.local_identifier name) (as_is identifier))))
+ list\join))]
+ (~ body)))))))
+
+(def: (name_side module_side? parser)
+ (-> Bit (Parser Name) (Parser Text))
+ (do <>.monad
+ [[module short] parser]
+ (wrap (if module_side?
+ (case module
+ "" short
+ _ module)
+ short))))
+
+(def: (snippet module_side?)
+ (-> Bit (Parser Text))
+ (.let [full_identifier (..name_side module_side? <code>.identifier)
+ full_tag (..name_side module_side? <code>.tag)]
+ ($_ <>.either
+ <code>.text
+ (if module_side?
+ full_identifier
+ (<>.either <code>.local_identifier
+ full_identifier))
+ (if module_side?
+ full_tag
+ (<>.either <code>.local_tag
+ full_tag))
+ (<>\map bit\encode <code>.bit)
+ (<>\map nat\encode <code>.nat)
+ (<>\map int\encode <code>.int)
+ (<>\map rev\encode <code>.rev)
+ (<>\map frac\encode <code>.frac)
+ )))
+
+(def: (part module_side?)
+ (-> Bit (Parser (List Text)))
+ (<code>.tuple (<>.many (..snippet module_side?))))
+
+(syntax: #export (text {simple (..part false)})
+ (wrap (list (|> simple (text.join_with "") code.text))))
+
+(template [<name> <simple> <complex>]
+ [(syntax: #export (<name> {name (<>.or (<>.and (..part true) (..part false))
+ (..part false))})
+ (case name
+ (#.Left [simple complex])
+ (wrap (list (<complex> [(text.join_with "" simple)
+ (text.join_with "" complex)])))
+
+ (#.Right simple)
+ (wrap (list (|> simple (text.join_with "") <simple>)))))]
+
+ [identifier code.local_identifier code.identifier]
+ [tag code.local_tag code.tag]
+ )
+
+(type: Environment
+ (Dictionary Text Code))
+
+(def: (apply env template)
+ (-> Environment Code Code)
+ (case template
+ [_ (#.Identifier "" name)]
+ (case (dictionary.get name env)
+ (#.Some substitute)
+ substitute
+
+ #.None
+ template)
+
+ (^template [<tag>]
+ [[meta (<tag> elems)]
+ [meta (<tag> (list\map (apply env) elems))]])
+ ([#.Tuple]
+ [#.Form])
+
+ [meta (#.Record members)]
+ [meta (#.Record (list\map (: (-> [Code Code] [Code Code])
+ (function (_ [key value])
+ [(apply env key)
+ (apply env value)]))
+ members))]
+
+ _
+ template))
+
+(type: Local
+ {#name Text
+ #parameters (List Text)
+ #template (List Code)})
+
+(exception: #export (irregular_arguments {expected Nat} {actual Nat})
+ (exception.report
+ ["Expected" (\ nat.decimal encode expected)]
+ ["Actual" (\ nat.decimal encode actual)]))
+
+(def: (macro (^slots [#parameters #template]))
+ (-> Local Macro)
+ ("lux macro"
+ (function (_ inputs compiler)
+ (.let [parameters_count (list.size parameters)
+ inputs_count (list.size inputs)]
+ (if (nat.= parameters_count inputs_count)
+ (.let [environment (: Environment
+ (|> (list.zip/2 parameters inputs)
+ (dictionary.from_list text.hash)))]
+ (#.Right [compiler (list\map (..apply environment) template)]))
+ (exception.throw ..irregular_arguments [parameters_count inputs_count]))))))
+
+(def: local
+ (Parser Local)
+ (do <>.monad
+ [[name parameters] (<code>.form (<>.and <code>.local_identifier
+ (<>.many <code>.local_identifier)))
+ template (<code>.tuple (<>.some <code>.any))]
+ (wrap {#name name
+ #parameters parameters
+ #template template})))
+
+(syntax: #export (let {locals (<code>.tuple (<>.some ..local))}
+ body)
+ (do meta.monad
+ [here_name meta.current_module_name
+ expression? (: (Meta Bit)
+ (function (_ lux)
+ (#try.Success [lux (case (get@ #.expected lux)
+ #.None
+ false
+
+ (#.Some _)
+ true)])))
+ g!pop (local.push (list\map (function (_ local)
+ [[here_name (get@ #name local)]
+ (..macro local)])
+ locals))]
+ (if expression?
+ (//.with_gensyms [g!body]
+ (wrap (list (` (.let [(~ g!body) (~ body)]
+ (exec (~ g!pop)
+ (~ g!body)))))))
+ (wrap (list body
+ g!pop)))))
diff --git a/stdlib/source/library/lux/math.lux b/stdlib/source/library/lux/math.lux
new file mode 100644
index 000000000..0070bcfa3
--- /dev/null
+++ b/stdlib/source/library/lux/math.lux
@@ -0,0 +1,394 @@
+(.module: {#.doc "Common mathematical constants and functions."}
+ [library
+ [lux #*
+ ["@" target]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]]]]])
+
+(template [<name> <value> <doc>]
+ [(def: #export <name>
+ {#.doc <doc>}
+ <value>)]
+
+ [e +2.7182818284590452354 "The base of the natural logarithm."]
+ [pi +3.14159265358979323846 "The ratio of a circle's circumference to its diameter."]
+ [tau +6.28318530717958647692 "The ratio of a circle's circumference to its radius."]
+ )
+
+(for {@.old
+ (as_is (template [<name> <method>]
+ [(def: #export (<name> input)
+ (-> Frac Frac)
+ (<method> input))]
+
+ [cos "jvm invokestatic:java.lang.Math:cos:double"]
+ [sin "jvm invokestatic:java.lang.Math:sin:double"]
+ [tan "jvm invokestatic:java.lang.Math:tan:double"]
+
+ [acos "jvm invokestatic:java.lang.Math:acos:double"]
+ [asin "jvm invokestatic:java.lang.Math:asin:double"]
+ [atan "jvm invokestatic:java.lang.Math:atan:double"]
+
+ [exp "jvm invokestatic:java.lang.Math:exp:double"]
+ [log "jvm invokestatic:java.lang.Math:log:double"]
+
+ [ceil "jvm invokestatic:java.lang.Math:ceil:double"]
+ [floor "jvm invokestatic:java.lang.Math:floor:double"]
+ )
+ (def: #export (pow param subject)
+ (-> Frac Frac Frac)
+ ("jvm invokestatic:java.lang.Math:pow:double,double" subject param)))
+
+ @.jvm
+ (as_is (template: (!double value)
+ (|> value
+ (:as (primitive "java.lang.Double"))
+ "jvm object cast"))
+
+ (template: (!frac value)
+ (|> value
+ "jvm object cast"
+ (: (primitive "java.lang.Double"))
+ (:as Frac)))
+
+ (template [<name> <method>]
+ [(def: #export <name>
+ (-> Frac Frac)
+ (|>> !double
+ ["D"]
+ ("jvm member invoke static" [] "java.lang.Math" <method> [])
+ !frac))]
+
+ [cos "cos"]
+ [sin "sin"]
+ [tan "tan"]
+
+ [acos "acos"]
+ [asin "asin"]
+ [atan "atan"]
+
+ [exp "exp"]
+ [log "log"]
+
+ [ceil "ceil"]
+ [floor "floor"]
+
+ [root/2 "sqrt"]
+ [root/3 "cbrt"]
+ )
+
+ (def: #export (pow param subject)
+ (-> Frac Frac Frac)
+ (|> ("jvm member invoke static" [] "java.lang.Math" "pow" []
+ ["D" (!double subject)] ["D" (!double param)])
+ !frac)))
+
+ @.js
+ (as_is (template [<name> <method>]
+ [(def: #export <name>
+ (-> Frac Frac)
+ (|>> ("js apply" ("js constant" <method>))
+ (:as Frac)))]
+
+ [cos "Math.cos"]
+ [sin "Math.sin"]
+ [tan "Math.tan"]
+
+ [acos "Math.acos"]
+ [asin "Math.asin"]
+ [atan "Math.atan"]
+
+ [exp "Math.exp"]
+ [log "Math.log"]
+
+ [ceil "Math.ceil"]
+ [floor "Math.floor"]
+
+ [root/2 "Math.sqrt"]
+ [root/3 "Math.cbrt"]
+ )
+
+ (def: #export (pow param subject)
+ (-> Frac Frac Frac)
+ (:as Frac ("js apply" ("js constant" "Math.pow") subject param))))
+
+ @.python
+ (as_is (template [<name> <method>]
+ [(def: #export <name>
+ (-> Frac Frac)
+ (|>> ("python object do" <method> ("python import" "math"))
+ (:as Frac)))]
+
+ [cos "cos"]
+ [sin "sin"]
+ [tan "tan"]
+
+ [acos "acos"]
+ [asin "asin"]
+ [atan "atan"]
+
+ [exp "exp"]
+ [log "log"]
+
+ [ceil "ceil"]
+ [floor "floor"]
+
+ [root/2 "sqrt"]
+ )
+
+ (def: #export (pow param subject)
+ (-> Frac Frac Frac)
+ (:as Frac ("python object do" "pow" ("python import" "math") subject param)))
+
+ (def: #export root/3
+ (-> Frac Frac)
+ (..pow ("lux f64 /" +3.0 +1.0))))
+
+ @.lua
+ (as_is (template [<name> <method>]
+ [(def: #export <name>
+ (-> Frac Frac)
+ (|>> ("lua apply" ("lua constant" <method>))
+ (:as Frac)))]
+
+ [cos "math.cos"]
+ [sin "math.sin"]
+ [tan "math.tan"]
+
+ [acos "math.acos"]
+ [asin "math.asin"]
+ [atan "math.atan"]
+
+ [exp "math.exp"]
+ [log "math.log"]
+
+ [ceil "math.ceil"]
+ [floor "math.floor"]
+
+ [root/2 "math.sqrt"]
+ )
+
+ (def: #export (pow param subject)
+ (-> Frac Frac Frac)
+ ("lua power" param subject))
+
+ (def: #export root/3
+ (-> Frac Frac)
+ (..pow ("lux f64 /" +3.0 +1.0))))
+
+ @.ruby
+ (as_is (template [<name> <method>]
+ [(def: #export <name>
+ (-> Frac Frac)
+ (|>> ("ruby apply" ("ruby constant" <method>))
+ (:as Frac)))]
+
+ [cos "Math.cos"]
+ [sin "Math.sin"]
+ [tan "Math.tan"]
+
+ [acos "Math.acos"]
+ [asin "Math.asin"]
+ [atan "Math.atan"]
+
+ [exp "Math.exp"]
+ [log "Math.log"]
+
+ [root/2 "Math.sqrt"]
+ [root/3 "Math.cbrt"]
+ )
+
+ (template [<name> <method>]
+ [(def: #export <name>
+ (-> Frac Frac)
+ (|>> ("ruby object do" <method>)
+ (:as Int)
+ ("lux i64 f64")))]
+
+ [ceil "ceil"]
+ [floor "floor"]
+ )
+
+ (def: #export (pow param subject)
+ (-> Frac Frac Frac)
+ (:as Frac ("ruby object do" "**" subject param))))
+
+ @.php
+ (as_is (template [<name> <method>]
+ [(def: #export <name>
+ (-> Frac Frac)
+ (|>> ("php apply" ("php constant" <method>))
+ (:as Frac)))]
+
+ [cos "cos"]
+ [sin "sin"]
+ [tan "tan"]
+
+ [acos "acos"]
+ [asin "asin"]
+ [atan "atan"]
+
+ [exp "exp"]
+ [log "log"]
+
+ [ceil "ceil"]
+ [floor "floor"]
+
+ [root/2 "sqrt"]
+ )
+
+ (def: #export (pow param subject)
+ (-> Frac Frac Frac)
+ (:as Frac ("php apply" ("php constant" "pow") subject param)))
+
+ (def: #export root/3
+ (-> Frac Frac)
+ (..pow ("lux f64 /" +3.0 +1.0))))
+
+ @.scheme
+ (as_is (template [<name> <method>]
+ [(def: #export <name>
+ (-> Frac Frac)
+ (|>> ("scheme apply" ("scheme constant" <method>))
+ (:as Frac)))]
+
+ [cos "cos"]
+ [sin "sin"]
+ [tan "tan"]
+
+ [acos "acos"]
+ [asin "asin"]
+ [atan "atan"]
+
+ [exp "exp"]
+ [log "log"]
+
+ [ceil "ceiling"]
+ [floor "floor"]
+
+ [root/2 "sqrt"]
+ )
+
+ (def: #export (pow param subject)
+ (-> Frac Frac Frac)
+ (:as Frac ("scheme apply" ("scheme constant" "expt") subject param)))
+
+ (def: #export root/3
+ (-> Frac Frac)
+ (..pow ("lux f64 /" +3.0 +1.0))))
+ })
+
+(def: #export (round input)
+ (-> Frac Frac)
+ (let [floored (floor input)
+ diff ("lux f64 -" floored input)]
+ (cond ("lux f64 <" diff +0.5)
+ ("lux f64 +" +1.0 floored)
+
+ ("lux f64 <" -0.5 diff)
+ ("lux f64 +" -1.0 floored)
+
+ ## else
+ floored)))
+
+(def: #export (atan/2 x y)
+ (-> Frac Frac Frac)
+ (cond ("lux f64 <" x +0.0)
+ (..atan ("lux f64 /" x y))
+
+ ("lux f64 <" +0.0 x)
+ (if (or ("lux f64 <" y +0.0)
+ ("lux f64 =" +0.0 y))
+ (|> y ("lux f64 /" x) atan ("lux f64 +" pi))
+ (|> y ("lux f64 /" x) atan ("lux f64 -" pi)))
+
+ ## ("lux f64 =" +0.0 x)
+ (cond ("lux f64 <" y +0.0)
+ (|> pi ("lux f64 /" +2.0))
+
+ ("lux f64 <" +0.0 y)
+ (|> pi ("lux f64 /" -2.0))
+
+ ## ("lux f64 =" +0.0 y)
+ ("lux f64 /" +0.0 +0.0))))
+
+(def: #export (log' base input)
+ (-> Frac Frac Frac)
+ ("lux f64 /"
+ (..log base)
+ (..log input)))
+
+(def: #export (factorial n)
+ (-> Nat Nat)
+ (loop [acc 1
+ n n]
+ (if (n.<= 1 n)
+ acc
+ (recur (n.* n acc) (dec n)))))
+
+(def: #export (hypotenuse catA catB)
+ (-> Frac Frac Frac)
+ (..pow +0.5 ("lux f64 +"
+ (..pow +2.0 catA)
+ (..pow +2.0 catB))))
+
+## Hyperbolic functions
+## https://en.wikipedia.org/wiki/Hyperbolic_function#Definitions
+(template [<name> <comp> <inverse>]
+ [(def: #export (<name> x)
+ (-> Frac Frac)
+ (|> (..exp x) (<comp> (..exp ("lux f64 *" -1.0 x))) ("lux f64 /" +2.0)))
+
+ (def: #export (<inverse> x)
+ (-> Frac Frac)
+ (|> +2.0 ("lux f64 /" (|> (..exp x) (<comp> (..exp ("lux f64 *" -1.0 x)))))))]
+
+ [sinh "lux f64 -" csch]
+ [cosh "lux f64 +" sech]
+ )
+
+(template [<name> <top> <bottom>]
+ [(def: #export (<name> x)
+ (-> Frac Frac)
+ (let [e+ (exp x)
+ e- (exp ("lux f64 *" -1.0 x))
+ sinh' (|> e+ ("lux f64 -" e-))
+ cosh' (|> e+ ("lux f64 +" e-))]
+ (|> <top> ("lux f64 /" <bottom>))))]
+
+ [tanh sinh' cosh']
+ [coth cosh' sinh']
+ )
+
+## https://en.wikipedia.org/wiki/Inverse_hyperbolic_functions#Definitions_in_terms_of_logarithms
+(template [<name> <comp>]
+ [(def: #export (<name> x)
+ (-> Frac Frac)
+ (|> x (pow +2.0) (<comp> +1.0) (pow +0.5) ("lux f64 +" x) log))]
+
+ [asinh "lux f64 +"]
+ [acosh "lux f64 -"]
+ )
+
+(template [<name> <base> <diff>]
+ [(def: #export (<name> x)
+ (-> Frac Frac)
+ (let [x+ (|> <base> ("lux f64 +" <diff>))
+ x- (|> <base> ("lux f64 -" <diff>))]
+ (|> x+ ("lux f64 /" x-) log ("lux f64 /" +2.0))))]
+
+ [atanh +1.0 x]
+ [acoth x +1.0]
+ )
+
+(template [<name> <op>]
+ [(def: #export (<name> x)
+ (-> Frac Frac)
+ (let [x^2 (|> x (pow +2.0))]
+ (|> +1.0 (<op> x^2) (pow +0.5) ("lux f64 +" +1.0) ("lux f64 /" x) log)))]
+
+ [asech "lux f64 -"]
+ [acsch "lux f64 +"]
+ )
diff --git a/stdlib/source/library/lux/math/infix.lux b/stdlib/source/library/lux/math/infix.lux
new file mode 100644
index 000000000..a8fd881aa
--- /dev/null
+++ b/stdlib/source/library/lux/math/infix.lux
@@ -0,0 +1,96 @@
+(.module: {#.doc "Common mathematical constants and functions."}
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["<>" parser ("#\." functor)
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." product]
+ [collection
+ ["." list ("#\." fold)]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]]]]])
+
+(type: #rec Infix
+ (#Const Code)
+ (#Call (List Code))
+ (#Unary Code Infix)
+ (#Binary Infix Code Infix))
+
+(def: infix^
+ (Parser Infix)
+ (<| <>.rec (function (_ infix^))
+ ($_ <>.or
+ ($_ <>.either
+ (<>\map code.bit <code>.bit)
+ (<>\map code.nat <code>.nat)
+ (<>\map code.int <code>.int)
+ (<>\map code.rev <code>.rev)
+ (<>\map code.frac <code>.frac)
+ (<>\map code.text <code>.text)
+ (<>\map code.identifier <code>.identifier)
+ (<>\map code.tag <code>.tag))
+ (<code>.form (<>.many <code>.any))
+ (<code>.tuple (<>.and <code>.any infix^))
+ (<code>.tuple ($_ <>.either
+ (do <>.monad
+ [_ (<code>.this! (' #and))
+ init_subject infix^
+ init_op <code>.any
+ init_param infix^
+ steps (<>.some (<>.and <code>.any infix^))]
+ (wrap (product.right (list\fold (function (_ [op param] [subject [_subject _op _param]])
+ [param [(#Binary _subject _op _param)
+ (` and)
+ (#Binary subject op param)]])
+ [init_param [init_subject init_op init_param]]
+ steps))))
+ (do <>.monad
+ [init_subject infix^
+ init_op <code>.any
+ init_param infix^
+ steps (<>.some (<>.and <code>.any infix^))]
+ (wrap (list\fold (function (_ [op param] [_subject _op _param])
+ [(#Binary _subject _op _param) op param])
+ [init_subject init_op init_param]
+ steps)))
+ ))
+ )))
+
+(def: (to_prefix infix)
+ (-> Infix Code)
+ (case infix
+ (#Const value)
+ value
+
+ (#Call parts)
+ (code.form parts)
+
+ (#Unary op subject)
+ (` ((~ op) (~ (to_prefix subject))))
+
+ (#Binary left op right)
+ (` ((~ op) (~ (to_prefix right)) (~ (to_prefix left))))
+ ))
+
+(syntax: #export (infix {expr infix^})
+ {#.doc (doc "Infix math syntax."
+ (infix [x i.* +10])
+ (infix [[x i.+ y] i.* [x i.- y]])
+ (infix [sin [x i.+ y]])
+ (infix [[x n.< y] and [y n.< z]])
+ (infix [#and x n.< y n.< z])
+ (infix [(n.* 3 9) gcd 450])
+
+ "The rules for infix syntax are simple."
+ "If you want your binary function to work well with it."
+ "Then take the argument to the right (y) as your first argument,"
+ "and take the argument to the left (x) as your second argument.")}
+ (wrap (list (..to_prefix expr))))
diff --git a/stdlib/source/library/lux/math/logic/continuous.lux b/stdlib/source/library/lux/math/logic/continuous.lux
new file mode 100644
index 000000000..631219671
--- /dev/null
+++ b/stdlib/source/library/lux/math/logic/continuous.lux
@@ -0,0 +1,40 @@
+(.module:
+ [library
+ [lux (#- false true or and not)
+ [abstract
+ [monoid (#+ Monoid)]]
+ [math
+ [number
+ ["r" rev ("#\." interval)]]]]])
+
+(def: #export false Rev r\bottom)
+(def: #export true Rev r\top)
+
+(template [<name> <chooser> <monoid> <identity>]
+ [(def: #export <name>
+ (-> Rev Rev Rev)
+ <chooser>)
+
+ (implementation: #export <monoid>
+ (Monoid Rev)
+
+ (def: identity <identity>)
+ (def: compose <name>))]
+
+ [or r.max disjunction ..false]
+ [and r.min conjunction ..true]
+ )
+
+(def: #export (not input)
+ (-> Rev Rev)
+ (r.- input ..true))
+
+(def: #export (implies consequent antecedent)
+ (-> Rev Rev Rev)
+ (or (not antecedent)
+ consequent))
+
+(def: #export (= left right)
+ (-> Rev Rev Rev)
+ (and (or (not left) right)
+ (or left (not right))))
diff --git a/stdlib/source/library/lux/math/logic/fuzzy.lux b/stdlib/source/library/lux/math/logic/fuzzy.lux
new file mode 100644
index 000000000..c1815f3db
--- /dev/null
+++ b/stdlib/source/library/lux/math/logic/fuzzy.lux
@@ -0,0 +1,132 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [predicate (#+ Predicate)]
+ [functor
+ ["." contravariant]]]
+ [data
+ [collection
+ ["." list]
+ ["." set (#+ Set)]]]
+ [math
+ [number
+ ["/" rev]]]]]
+ ["." // #_
+ ["#" continuous]])
+
+(type: #export (Fuzzy a)
+ (-> a Rev))
+
+(implementation: #export functor
+ (contravariant.Functor Fuzzy)
+
+ (def: (map f fb)
+ (|>> f fb)))
+
+(template [<name> <verdict>]
+ [(def: #export <name>
+ Fuzzy
+ (function (_ _)
+ <verdict>))]
+
+ [empty //.false]
+ [full //.true]
+ )
+
+(def: #export (membership set elem)
+ (All [a] (-> (Fuzzy a) a Rev))
+ (set elem))
+
+(template [<set_composition> <membership_composition>]
+ [(def: #export (<set_composition> left right)
+ (All [a] (-> (Fuzzy a) (Fuzzy a) (Fuzzy a)))
+ (function (_ elem)
+ (<membership_composition> (left elem)
+ (right elem))))]
+
+ [union //.or]
+ [intersection //.and]
+ )
+
+(def: #export (complement set)
+ (All [a] (-> (Fuzzy a) (Fuzzy a)))
+ (|>> set //.not))
+
+(def: #export (difference sub base)
+ (All [a] (-> (Fuzzy a) (Fuzzy a) (Fuzzy a)))
+ (..intersection (..complement sub) base))
+
+(def: #export (from_predicate predicate)
+ (All [a] (-> (Predicate a) (Fuzzy a)))
+ (function (_ elem)
+ (if (predicate elem)
+ //.true
+ //.false)))
+
+(def: #export (to_predicate treshold set)
+ (All [a] (-> Rev (Fuzzy a) (Predicate a)))
+ (function (_ elem)
+ (/.> treshold (set elem))))
+
+(def: #export from_set
+ (All [a] (-> (Set a) (Fuzzy a)))
+ (|>> set.member? ..from_predicate))
+
+(def: (ascending from to)
+ (-> Rev Rev (Fuzzy Rev))
+ (let [measure (/.- from to)]
+ (function (_ elem)
+ (cond (/.< from elem)
+ ## below
+ //.false
+
+ (/.< to elem)
+ ## in the middle...
+ (|> elem
+ (/.- from)
+ (/./ measure))
+
+ ## above
+ //.true))))
+
+(def: (descending from to)
+ (-> Rev Rev (Fuzzy Rev))
+ (..complement (..ascending from to)))
+
+(def: #export (gradient from to)
+ (-> Rev Rev (Fuzzy Rev))
+ (if (/.< to from)
+ (..ascending from to)
+ (..descending from to)))
+
+(template: (!sort_2 <low> <high>)
+ (if (/.> <low> <high>)
+ [<low> <high>]
+ [<high> <low>]))
+
+(def: #export (triangle bottom middle top)
+ (-> Rev Rev Rev (Fuzzy Rev))
+ (let [[low_0 high_0] (!sort_2 bottom middle)
+ [bottom' high_1] (!sort_2 low_0 top)
+ [middle' top'] (!sort_2 high_0 high_1)]
+ (..intersection (..ascending bottom' middle')
+ (..descending middle' top'))))
+
+(def: #export (trapezoid bottom middle_bottom middle_top top)
+ (-> Rev Rev Rev Rev (Fuzzy Rev))
+ (let [[low_0 high_0] (!sort_2 bottom middle_bottom)
+ [low_1 high_1] (!sort_2 middle_top top)
+ [bottom' middle_0] (!sort_2 low_0 low_1)
+ [middle_1 top'] (!sort_2 high_0 high_1)
+ [middle_bottom' middle_top'] (!sort_2 middle_0 middle_1)]
+ (..intersection (..ascending bottom' middle_bottom')
+ (..descending middle_top' top'))))
+
+(def: #export (cut treshold set)
+ (All [a] (-> Rev (Fuzzy a) (Fuzzy a)))
+ (function (_ elem)
+ (let [membership (set elem)]
+ (if (/.< treshold membership)
+ //.false
+ (|> membership (/.- treshold) (/.* //.true))))))
diff --git a/stdlib/source/library/lux/math/modular.lux b/stdlib/source/library/lux/math/modular.lux
new file mode 100644
index 000000000..679666580
--- /dev/null
+++ b/stdlib/source/library/lux/math/modular.lux
@@ -0,0 +1,157 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]
+ [monoid (#+ Monoid)]
+ [codec (#+ Codec)]
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<.>" text (#+ Parser)]
+ ["<.>" code]]]
+ [data
+ ["." product]
+ ["." text ("#\." monoid)]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number
+ ["i" int ("#\." decimal)]]]
+ [type
+ abstract]]]
+ ["." // #_
+ ["#" modulus (#+ Modulus)]])
+
+(abstract: #export (Mod m)
+ {#modulus (Modulus m)
+ #value Int}
+
+ {#.doc "A number under a modulus."}
+
+ (def: #export (modular modulus value)
+ (All [%] (-> (Modulus %) Int (Mod %)))
+ (:abstraction {#modulus modulus
+ #value (i.mod (//.divisor modulus) value)}))
+
+ (template [<name> <type> <side>]
+ [(def: #export <name>
+ (All [%] (-> (Mod %) <type>))
+ (|>> :representation <side>))]
+
+ [modulus (Modulus %) product.left]
+ [value Int product.right]
+ )
+
+ (exception: #export [%] (incorrect_modulus {modulus (Modulus %)}
+ {parsed Int})
+ (exception.report
+ ["Expected" (i\encode (//.divisor modulus))]
+ ["Actual" (i\encode parsed)]))
+
+ (def: separator
+ " mod ")
+
+ (def: intL
+ (Parser Int)
+ (<>.codec i.decimal
+ (<text>.and (<text>.one_of "-+") (<text>.many <text>.decimal))))
+
+ (implementation: #export (codec expected)
+ (All [%] (-> (Modulus %) (Codec Text (Mod %))))
+
+ (def: (encode modular)
+ (let [[_ value] (:representation modular)]
+ ($_ text\compose
+ (i\encode value)
+ ..separator
+ (i\encode (//.divisor expected)))))
+
+ (def: decode
+ (<text>.run
+ (do <>.monad
+ [[value _ actual] ($_ <>.and intL (<text>.this ..separator) intL)
+ _ (<>.assert (exception.construct ..incorrect_modulus [expected actual])
+ (i.= (//.divisor expected) actual))]
+ (wrap (..modular expected value))))))
+
+ (template [<name> <op>]
+ [(def: #export (<name> reference subject)
+ (All [%] (-> (Mod %) (Mod %) Bit))
+ (let [[_ reference] (:representation reference)
+ [_ subject] (:representation subject)]
+ (<op> reference subject)))]
+
+ [= i.=]
+ [< i.<]
+ [<= i.<=]
+ [> i.>]
+ [>= i.>=]
+ )
+
+ (implementation: #export equivalence
+ (All [%] (Equivalence (Mod %)))
+
+ (def: = ..=))
+
+ (implementation: #export order
+ (All [%] (Order (Mod %)))
+
+ (def: &equivalence ..equivalence)
+ (def: < ..<))
+
+ (template [<name> <op>]
+ [(def: #export (<name> param subject)
+ (All [%] (-> (Mod %) (Mod %) (Mod %)))
+ (let [[modulus param] (:representation param)
+ [_ subject] (:representation subject)]
+ (:abstraction {#modulus modulus
+ #value (|> subject
+ (<op> param)
+ (i.mod (//.divisor modulus)))})))]
+
+ [+ i.+]
+ [- i.-]
+ [* i.*]
+ )
+
+ (template [<composition> <identity> <monoid>]
+ [(implementation: #export (<monoid> modulus)
+ (All [%] (-> (Modulus %) (Monoid (Mod %))))
+
+ (def: identity
+ (..modular modulus <identity>))
+ (def: compose
+ <composition>))]
+
+ [..+ +0 addition]
+ [..* +1 multiplication]
+ )
+
+ (def: #export (inverse modular)
+ (All [%] (-> (Mod %) (Maybe (Mod %))))
+ (let [[modulus value] (:representation modular)
+ [[vk mk] gcd] (i.extended_gcd value (//.divisor modulus))]
+ (case gcd
+ +1 (#.Some (..modular modulus vk))
+ _ #.None)))
+ )
+
+(exception: #export [r% s%] (moduli_are_not_equal {reference (Modulus r%)}
+ {subject (Modulus s%)})
+ (exception.report
+ ["Reference" (i\encode (//.divisor reference))]
+ ["Subject" (i\encode (//.divisor subject))]))
+
+(def: #export (adapter reference subject)
+ (All [r% s%]
+ (-> (Modulus r%) (Modulus s%)
+ (Try (-> (Mod s%) (Mod r%)))))
+ (if (//.= reference subject)
+ (#try.Success (|>> ..value
+ (..modular reference)))
+ (exception.throw ..moduli_are_not_equal [reference subject])))
diff --git a/stdlib/source/library/lux/math/modulus.lux b/stdlib/source/library/lux/math/modulus.lux
new file mode 100644
index 000000000..fa654a408
--- /dev/null
+++ b/stdlib/source/library/lux/math/modulus.lux
@@ -0,0 +1,56 @@
+(.module:
+ [library
+ [lux #*
+ ["." meta]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ [parser
+ ["<.>" code]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number
+ ["i" int]]]
+ [type
+ abstract]]])
+
+(exception: #export zero_cannot_be_a_modulus)
+
+(abstract: #export (Modulus m)
+ Int
+
+ {#.doc (doc "A number used as a modulus in modular arithmetic."
+ "It cannot be 0.")}
+
+ (def: #export (modulus value)
+ (Ex [m] (-> Int (Try (Modulus m))))
+ (if (i.= +0 value)
+ (exception.throw ..zero_cannot_be_a_modulus [])
+ (#try.Success (:abstraction value))))
+
+ (def: #export divisor
+ (All [m] (-> (Modulus m) Int))
+ (|>> :representation))
+
+ (def: #export (= reference subject)
+ (All [r s] (-> (Modulus r) (Modulus s) Bit))
+ (i.= (:representation reference)
+ (:representation subject)))
+
+ (def: #export (congruent? modulus reference subject)
+ (All [m] (-> (Modulus m) Int Int Bit))
+ (|> subject
+ (i.- reference)
+ (i.% (:representation modulus))
+ (i.= +0)))
+ )
+
+(syntax: #export (literal {divisor <code>.int})
+ (meta.lift
+ (do try.monad
+ [_ (..modulus divisor)]
+ (wrap (list (` ((~! try.assume) (..modulus (~ (code.int divisor))))))))))
diff --git a/stdlib/source/library/lux/math/number.lux b/stdlib/source/library/lux/math/number.lux
new file mode 100644
index 000000000..506fde750
--- /dev/null
+++ b/stdlib/source/library/lux/math/number.lux
@@ -0,0 +1,87 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [codec (#+ Codec)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ ["." text]]]]
+ ["." / #_
+ ["#." nat]
+ ["#." int]
+ ["#." rev]
+ ["#." frac]])
+
+(macro: (encoding_doc tokens state)
+ (case tokens
+ (^ (list [location (#.Text encoding)] example_1 example_2))
+ (let [encoding ($_ "lux text concat"
+ "Given syntax for a "
+ encoding
+ " number, generates a Nat, an Int, a Rev or a Frac.")
+ separators "Allows for the presence of commas among the digits."
+ description [location (#.Text ($_ "lux text concat" encoding " " separators))]]
+ (#try.Success [state (list (` (doc (~ description)
+ (~ example_1)
+ (~ example_2))))]))
+
+ _
+ (#try.Failure "Wrong syntax for 'encoding_doc'.")))
+
+(def: separator
+ ",")
+
+(def: (separator_prefixed? number)
+ (-> Text Bit)
+ (case ("lux text index" 0 ..separator number)
+ (#.Some 0)
+ #1
+
+ _
+ #0))
+
+(def: clean_separators
+ (-> Text Text)
+ (text.replace_all ..separator ""))
+
+(template [<macro> <nat> <int> <rev> <frac> <error> <doc>]
+ [(macro: #export (<macro> tokens state)
+ {#.doc <doc>}
+ (case tokens
+ (#.Cons [meta (#.Text repr')] #.Nil)
+ (if (..separator_prefixed? repr')
+ (#try.Failure <error>)
+ (let [repr (..clean_separators repr')]
+ (case (\ <nat> decode repr)
+ (#try.Success value)
+ (#try.Success [state (list [meta (#.Nat value)])])
+
+ (^multi (#try.Failure _)
+ [(\ <int> decode repr) (#try.Success value)])
+ (#try.Success [state (list [meta (#.Int value)])])
+
+ (^multi (#try.Failure _)
+ [(\ <rev> decode repr) (#try.Success value)])
+ (#try.Success [state (list [meta (#.Rev value)])])
+
+ (^multi (#try.Failure _)
+ [(\ <frac> decode repr) (#try.Success value)])
+ (#try.Success [state (list [meta (#.Frac value)])])
+
+ _
+ (#try.Failure <error>))))
+
+ _
+ (#try.Failure <error>)))]
+
+ [bin /nat.binary /int.binary /rev.binary /frac.binary
+ "Invalid binary syntax."
+ (encoding_doc "binary" (bin "11001001") (bin "11,00,10,01"))]
+ [oct /nat.octal /int.octal /rev.octal /frac.octal
+ "Invalid octal syntax."
+ (encoding_doc "octal" (oct "615243") (oct "615,243"))]
+ [hex /nat.hex /int.hex /rev.hex /frac.hex
+ "Invalid hexadecimal syntax."
+ (encoding_doc "hexadecimal" (hex "deadBEEF") (hex "dead,BEEF"))]
+ )
diff --git a/stdlib/source/library/lux/math/number/complex.lux b/stdlib/source/library/lux/math/number/complex.lux
new file mode 100644
index 000000000..cc2c6a4f1
--- /dev/null
+++ b/stdlib/source/library/lux/math/number/complex.lux
@@ -0,0 +1,316 @@
+(.module: {#.doc "Complex arithmetic."}
+ [library
+ [lux #*
+ ["." math]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [codec (#+ Codec)]
+ ["M" monad (#+ Monad do)]]
+ [control
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." maybe]
+ [collection
+ ["." list ("#\." functor)]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number
+ ["n" nat]
+ ["f" frac]
+ ["." int]]]]])
+
+(type: #export Complex
+ {#real Frac
+ #imaginary Frac})
+
+(syntax: #export (complex real {?imaginary (<>.maybe <code>.any)})
+ {#.doc (doc "Complex literals."
+ (complex real imaginary)
+ "The imaginary part can be omitted if it's 0."
+ (complex real))}
+ (wrap (list (` {#..real (~ real)
+ #..imaginary (~ (maybe.default (' +0.0)
+ ?imaginary))}))))
+
+(def: #export i
+ (..complex +0.0 +1.0))
+
+(def: #export +one
+ (..complex +1.0 +0.0))
+
+(def: #export -one
+ (..complex -1.0 +0.0))
+
+(def: #export zero
+ (..complex +0.0 +0.0))
+
+(def: #export (not_a_number? complex)
+ (or (f.not_a_number? (get@ #real complex))
+ (f.not_a_number? (get@ #imaginary complex))))
+
+(def: #export (= param input)
+ (-> Complex Complex Bit)
+ (and (f.= (get@ #real param)
+ (get@ #real input))
+ (f.= (get@ #imaginary param)
+ (get@ #imaginary input))))
+
+(template [<name> <op>]
+ [(def: #export (<name> param input)
+ (-> Complex Complex Complex)
+ {#real (<op> (get@ #real param)
+ (get@ #real input))
+ #imaginary (<op> (get@ #imaginary param)
+ (get@ #imaginary input))})]
+
+ [+ f.+]
+ [- f.-]
+ )
+
+(implementation: #export equivalence
+ (Equivalence Complex)
+
+ (def: = ..=))
+
+(template [<name> <transform>]
+ [(def: #export <name>
+ (-> Complex Complex)
+ (|>> (update@ #real <transform>)
+ (update@ #imaginary <transform>)))]
+
+ [negate f.negate]
+ [signum f.signum]
+ )
+
+(def: #export conjugate
+ (-> Complex Complex)
+ (update@ #imaginary f.negate))
+
+(def: #export (*' param input)
+ (-> Frac Complex Complex)
+ {#real (f.* param
+ (get@ #real input))
+ #imaginary (f.* param
+ (get@ #imaginary input))})
+
+(def: #export (* param input)
+ (-> Complex Complex Complex)
+ {#real (f.- (f.* (get@ #imaginary param)
+ (get@ #imaginary input))
+ (f.* (get@ #real param)
+ (get@ #real input)))
+ #imaginary (f.+ (f.* (get@ #real param)
+ (get@ #imaginary input))
+ (f.* (get@ #imaginary param)
+ (get@ #real input)))})
+
+(def: #export (/ param input)
+ (-> Complex Complex Complex)
+ (let [(^slots [#real #imaginary]) param]
+ (if (f.< (f.abs imaginary)
+ (f.abs real))
+ (let [quot (f./ imaginary real)
+ denom (|> real (f.* quot) (f.+ imaginary))]
+ {#real (|> (get@ #real input) (f.* quot) (f.+ (get@ #imaginary input)) (f./ denom))
+ #imaginary (|> (get@ #imaginary input) (f.* quot) (f.- (get@ #real input)) (f./ denom))})
+ (let [quot (f./ real imaginary)
+ denom (|> imaginary (f.* quot) (f.+ real))]
+ {#real (|> (get@ #imaginary input) (f.* quot) (f.+ (get@ #real input)) (f./ denom))
+ #imaginary (|> (get@ #imaginary input) (f.- (f.* quot (get@ #real input))) (f./ denom))}))))
+
+(def: #export (/' param subject)
+ (-> Frac Complex Complex)
+ (let [(^slots [#real #imaginary]) subject]
+ {#real (f./ param real)
+ #imaginary (f./ param imaginary)}))
+
+(def: #export (% param input)
+ (-> Complex Complex Complex)
+ (let [scaled (/ param input)
+ quotient (|> scaled
+ (update@ #real math.floor)
+ (update@ #imaginary math.floor))]
+ (- (* quotient param)
+ input)))
+
+(def: #export (cos subject)
+ (-> Complex Complex)
+ (let [(^slots [#real #imaginary]) subject]
+ {#real (f.* (math.cosh imaginary)
+ (math.cos real))
+ #imaginary (f.negate (f.* (math.sinh imaginary)
+ (math.sin real)))}))
+
+(def: #export (cosh subject)
+ (-> Complex Complex)
+ (let [(^slots [#real #imaginary]) subject]
+ {#real (f.* (math.cos imaginary)
+ (math.cosh real))
+ #imaginary (f.* (math.sin imaginary)
+ (math.sinh real))}))
+
+(def: #export (sin subject)
+ (-> Complex Complex)
+ (let [(^slots [#real #imaginary]) subject]
+ {#real (f.* (math.cosh imaginary)
+ (math.sin real))
+ #imaginary (f.* (math.sinh imaginary)
+ (math.cos real))}))
+
+(def: #export (sinh subject)
+ (-> Complex Complex)
+ (let [(^slots [#real #imaginary]) subject]
+ {#real (f.* (math.cos imaginary)
+ (math.sinh real))
+ #imaginary (f.* (math.sin imaginary)
+ (math.cosh real))}))
+
+(def: #export (tan subject)
+ (-> Complex Complex)
+ (let [(^slots [#real #imaginary]) subject
+ r2 (f.* +2.0 real)
+ i2 (f.* +2.0 imaginary)
+ d (f.+ (math.cos r2) (math.cosh i2))]
+ {#real (f./ d (math.sin r2))
+ #imaginary (f./ d (math.sinh i2))}))
+
+(def: #export (tanh subject)
+ (-> Complex Complex)
+ (let [(^slots [#real #imaginary]) subject
+ r2 (f.* +2.0 real)
+ i2 (f.* +2.0 imaginary)
+ d (f.+ (math.cosh r2) (math.cos i2))]
+ {#real (f./ d (math.sinh r2))
+ #imaginary (f./ d (math.sin i2))}))
+
+(def: #export (abs subject)
+ (-> Complex Frac)
+ (let [(^slots [#real #imaginary]) subject]
+ (if (f.< (f.abs imaginary)
+ (f.abs real))
+ (if (f.= +0.0 imaginary)
+ (f.abs real)
+ (let [q (f./ imaginary real)]
+ (f.* (math.pow +0.5 (f.+ +1.0 (f.* q q)))
+ (f.abs imaginary))))
+ (if (f.= +0.0 real)
+ (f.abs imaginary)
+ (let [q (f./ real imaginary)]
+ (f.* (math.pow +0.5 (f.+ +1.0 (f.* q q)))
+ (f.abs real)))))))
+
+(def: #export (exp subject)
+ (-> Complex Complex)
+ (let [(^slots [#real #imaginary]) subject
+ r_exp (math.exp real)]
+ {#real (f.* r_exp (math.cos imaginary))
+ #imaginary (f.* r_exp (math.sin imaginary))}))
+
+(def: #export (log subject)
+ (-> Complex Complex)
+ (let [(^slots [#real #imaginary]) subject]
+ {#real (|> subject ..abs math.log)
+ #imaginary (math.atan/2 real imaginary)}))
+
+(template [<name> <type> <op>]
+ [(def: #export (<name> param input)
+ (-> <type> Complex Complex)
+ (|> input log (<op> param) exp))]
+
+ [pow Complex ..*]
+ [pow' Frac ..*']
+ )
+
+(def: (copy_sign sign magnitude)
+ (-> Frac Frac Frac)
+ (f.* (f.signum sign) magnitude))
+
+(def: #export (root/2 input)
+ (-> Complex Complex)
+ (let [(^slots [#real #imaginary]) input
+ t (|> input ..abs (f.+ (f.abs real)) (f./ +2.0) (math.pow +0.5))]
+ (if (f.>= +0.0 real)
+ {#real t
+ #imaginary (f./ (f.* +2.0 t)
+ imaginary)}
+ {#real (f./ (f.* +2.0 t)
+ (f.abs imaginary))
+ #imaginary (f.* t (..copy_sign imaginary +1.0))})))
+
+(def: (root/2-1z input)
+ (-> Complex Complex)
+ (|> (complex +1.0) (- (* input input)) ..root/2))
+
+(def: #export (reciprocal (^slots [#real #imaginary]))
+ (-> Complex Complex)
+ (if (f.< (f.abs imaginary)
+ (f.abs real))
+ (let [q (f./ imaginary real)
+ scale (f./ (|> real (f.* q) (f.+ imaginary))
+ +1.0)]
+ {#real (f.* q scale)
+ #imaginary (f.negate scale)})
+ (let [q (f./ real imaginary)
+ scale (f./ (|> imaginary (f.* q) (f.+ real))
+ +1.0)]
+ {#real scale
+ #imaginary (|> scale f.negate (f.* q))})))
+
+(def: #export (acos input)
+ (-> Complex Complex)
+ (|> input
+ (..+ (|> input ..root/2-1z (..* ..i)))
+ ..log
+ (..* (..negate ..i))))
+
+(def: #export (asin input)
+ (-> Complex Complex)
+ (|> input
+ ..root/2-1z
+ (..+ (..* ..i input))
+ ..log
+ (..* (..negate ..i))))
+
+(def: #export (atan input)
+ (-> Complex Complex)
+ (|> input
+ (..+ ..i)
+ (../ (..- input ..i))
+ ..log
+ (..* (../ (..complex +2.0) ..i))))
+
+(def: #export (argument (^slots [#real #imaginary]))
+ (-> Complex Frac)
+ (math.atan/2 real imaginary))
+
+(def: #export (roots nth input)
+ (-> Nat Complex (List Complex))
+ (if (n.= 0 nth)
+ (list)
+ (let [r_nth (|> nth .int int.frac)
+ nth_root_of_abs (|> input ..abs (math.pow (f./ r_nth +1.0)))
+ nth_phi (|> input ..argument (f./ r_nth))
+ slice (|> math.pi (f.* +2.0) (f./ r_nth))]
+ (|> (list.indices nth)
+ (list\map (function (_ nth')
+ (let [inner (|> nth' .int int.frac
+ (f.* slice)
+ (f.+ nth_phi))
+ real (f.* nth_root_of_abs
+ (math.cos inner))
+ imaginary (f.* nth_root_of_abs
+ (math.sin inner))]
+ {#real real
+ #imaginary imaginary})))))))
+
+(def: #export (approximately? margin_of_error standard value)
+ (-> Frac Complex Complex Bit)
+ (and (f.approximately? margin_of_error
+ (get@ #..real standard)
+ (get@ #..real value))
+ (f.approximately? margin_of_error
+ (get@ #..imaginary standard)
+ (get@ #..imaginary value))))
diff --git a/stdlib/source/library/lux/math/number/frac.lux b/stdlib/source/library/lux/math/number/frac.lux
new file mode 100644
index 000000000..f6f01192e
--- /dev/null
+++ b/stdlib/source/library/lux/math/number/frac.lux
@@ -0,0 +1,447 @@
+(.module:
+ [library
+ [lux (#- nat int rev)
+ ["@" target]
+ [abstract
+ [hash (#+ Hash)]
+ [monoid (#+ Monoid)]
+ [equivalence (#+ Equivalence)]
+ [codec (#+ Codec)]
+ [predicate (#+ Predicate)]
+ [order (#+ Order)]
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ ["." maybe]
+ ["." text]]]]
+ ["." // #_
+ ["#." i64]
+ ["#." nat]
+ ["#." int]
+ ["#." rev]
+ ["/#" //]])
+
+(def: #export (= reference sample)
+ {#.doc "Frac(tion) equivalence."}
+ (-> Frac Frac Bit)
+ ("lux f64 =" reference sample))
+
+(def: #export (< reference sample)
+ {#.doc "Frac(tion) less-than."}
+ (-> Frac Frac Bit)
+ ("lux f64 <" reference sample))
+
+(def: #export (<= reference sample)
+ {#.doc "Frac(tion) less-than or equal."}
+ (-> Frac Frac Bit)
+ (or ("lux f64 <" reference sample)
+ ("lux f64 =" reference sample)))
+
+(def: #export (> reference sample)
+ {#.doc "Frac(tion) greater-than."}
+ (-> Frac Frac Bit)
+ ("lux f64 <" sample reference))
+
+(def: #export (>= reference sample)
+ {#.doc "Frac(tion) greater-than or equal."}
+ (-> Frac Frac Bit)
+ (or ("lux f64 <" sample reference)
+ ("lux f64 =" sample reference)))
+
+(template [<comparison> <name>]
+ [(def: #export <name>
+ (Predicate Frac)
+ (<comparison> +0.0))]
+
+ [..> positive?]
+ [..< negative?]
+ [..= zero?]
+ )
+
+(template [<name> <op> <doc>]
+ [(def: #export (<name> param subject)
+ {#.doc <doc>}
+ (-> Frac Frac Frac)
+ (<op> param subject))]
+
+ [+ "lux f64 +" "Frac(tion) addition."]
+ [- "lux f64 -" "Frac(tion) substraction."]
+ [* "lux f64 *" "Frac(tion) multiplication."]
+ [/ "lux f64 /" "Frac(tion) division."]
+ [% "lux f64 %" "Frac(tion) remainder."]
+ )
+
+(def: #export (/% param subject)
+ (-> Frac Frac [Frac Frac])
+ [(../ param subject)
+ (..% param subject)])
+
+(def: #export negate
+ (-> Frac Frac)
+ (..* -1.0))
+
+(def: #export (abs x)
+ (-> Frac Frac)
+ (if (..< +0.0 x)
+ (..* -1.0 x)
+ x))
+
+(def: #export (signum x)
+ (-> Frac Frac)
+ (cond (..= +0.0 x) +0.0
+ (..< +0.0 x) -1.0
+ ## else
+ +1.0))
+
+(def: min_exponent -1022)
+(def: max_exponent (//int.frac +1023))
+
+(template [<name> <test> <doc>]
+ [(def: #export (<name> left right)
+ {#.doc <doc>}
+ (-> Frac Frac Frac)
+ (if (<test> right left)
+ left
+ right))]
+
+ [min ..< "Frac(tion) minimum."]
+ [max ..> "Frac(tion) minimum."]
+ )
+
+(def: #export nat
+ (-> Frac Nat)
+ (|>> "lux f64 i64" .nat))
+
+(def: #export int
+ (-> Frac Int)
+ (|>> "lux f64 i64"))
+
+(def: mantissa_size Nat 52)
+(def: exponent_size Nat 11)
+
+(def: frac_denominator
+ (|> -1
+ ("lux i64 right-shift" ..exponent_size)
+ "lux i64 f64"))
+
+(def: #export rev
+ (-> Frac Rev)
+ (|>> ..abs
+ (..% +1.0)
+ (..* ..frac_denominator)
+ "lux f64 i64"
+ ("lux i64 left-shift" ..exponent_size)))
+
+(implementation: #export equivalence
+ (Equivalence Frac)
+
+ (def: = ..=))
+
+(implementation: #export order
+ (Order Frac)
+
+ (def: &equivalence ..equivalence)
+ (def: < ..<))
+
+(def: #export smallest
+ Frac
+ (///.pow (//int.frac (//int.- (.int ..mantissa_size) ..min_exponent))
+ +2.0))
+
+(def: #export biggest
+ Frac
+ (let [f2^-52 (///.pow (//nat.frac (//nat.- ..mantissa_size 0)) +2.0)
+ f2^+1023 (///.pow ..max_exponent +2.0)]
+ (|> +2.0
+ (..- f2^-52)
+ (..* f2^+1023))))
+
+(template [<name> <compose> <identity>]
+ [(implementation: #export <name>
+ (Monoid Frac)
+
+ (def: identity <identity>)
+ (def: compose <compose>))]
+
+ [addition ..+ +0.0]
+ [multiplication ..* +1.0]
+ [minimum ..min ..biggest]
+ [maximum ..max (..* -1.0 ..biggest)]
+ )
+
+(template [<name> <numerator> <doc>]
+ [(def: #export <name>
+ {#.doc <doc>}
+ Frac
+ (../ +0.0 <numerator>))]
+
+ [not_a_number +0.0 "Not a number."]
+ [positive_infinity +1.0 "Positive infinity."]
+ )
+
+(def: #export negative_infinity
+ {#.doc "Negative infinity."}
+ Frac
+ (..* -1.0 ..positive_infinity))
+
+(def: #export (not_a_number? number)
+ {#.doc "Tests whether a frac is actually not-a-number."}
+ (-> Frac Bit)
+ (not (..= number number)))
+
+(def: #export (number? value)
+ (-> Frac Bit)
+ (not (or (..not_a_number? value)
+ (..= ..positive_infinity value)
+ (..= ..negative_infinity value))))
+
+(implementation: #export decimal
+ (Codec Text Frac)
+
+ (def: (encode x)
+ (case x
+ -0.0 (let [output ("lux f64 encode" x)]
+ (if (text.starts_with? "-" output)
+ output
+ ("lux text concat" "+" output)))
+ _ (if (..< +0.0 x)
+ ("lux f64 encode" x)
+ ("lux text concat" "+" ("lux f64 encode" x)))))
+
+ (def: (decode input)
+ (case ("lux f64 decode" [input])
+ (#.Some value)
+ (#try.Success value)
+
+ #.None
+ (#try.Failure "Could not decode Frac"))))
+
+(def: log/2
+ (-> Frac Frac)
+ (|>> ///.log
+ (../ (///.log +2.0))))
+
+(def: double_bias Nat 1023)
+
+(def: exponent_mask (//i64.mask ..exponent_size))
+
+(def: exponent_offset ..mantissa_size)
+(def: sign_offset (//nat.+ ..exponent_size ..exponent_offset))
+
+(template [<cast> <hex> <name>]
+ [(def: <name> (|> <hex> (\ //nat.hex decode) try.assume <cast>))]
+
+ [.i64 "FFF8000000000000" not_a_number_bits]
+ [.i64 "7FF0000000000000" positive_infinity_bits]
+ [.i64 "FFF0000000000000" negative_infinity_bits]
+ [.i64 "0000000000000000" positive_zero_bits]
+ [.i64 "8000000000000000" negative_zero_bits]
+ [.nat "7FF" special_exponent_bits]
+ )
+
+(def: smallest_exponent
+ (..log/2 ..smallest))
+
+(def: #export (to_bits input)
+ (-> Frac I64)
+ (.i64 (cond (..not_a_number? input)
+ ..not_a_number_bits
+
+ (..= positive_infinity input)
+ ..positive_infinity_bits
+
+ (..= negative_infinity input)
+ ..negative_infinity_bits
+
+ (..= +0.0 input)
+ (let [reciprocal (../ input +1.0)]
+ (if (..= positive_infinity reciprocal)
+ ## Positive zero
+ ..positive_zero_bits
+ ## Negative zero
+ ..negative_zero_bits))
+
+ ## else
+ (let [sign_bit (if (..< -0.0 input)
+ 1
+ 0)
+ input (..abs input)
+ exponent (|> input
+ ..log/2
+ ///.floor
+ (..min ..max_exponent))
+ min_gap (..- (//int.frac ..min_exponent) exponent)
+ power (|> (//nat.frac ..mantissa_size)
+ (..+ (..min +0.0 min_gap))
+ (..- exponent))
+ max_gap (..- ..max_exponent power)
+ mantissa (|> input
+ (..* (///.pow (..min ..max_exponent power) +2.0))
+ (..* (if (..> +0.0 max_gap)
+ (///.pow max_gap +2.0)
+ +1.0)))
+ exponent_bits (|> (if (..< +0.0 min_gap)
+ (|> (..int exponent)
+ (//int.- (..int min_gap))
+ dec)
+ (..int exponent))
+ (//int.+ (.int ..double_bias))
+ (//i64.and ..exponent_mask))
+ mantissa_bits (..int mantissa)]
+ ($_ //i64.or
+ (//i64.left_shift ..sign_offset sign_bit)
+ (//i64.left_shift ..exponent_offset exponent_bits)
+ (//i64.clear ..mantissa_size mantissa_bits)))
+ )))
+
+(template [<getter> <size> <offset>]
+ [(def: <getter>
+ (-> (I64 Any) I64)
+ (let [mask (|> 1 (//i64.left_shift <size>) dec (//i64.left_shift <offset>))]
+ (|>> (//i64.and mask) (//i64.right_shift <offset>) .i64)))]
+
+ [mantissa ..mantissa_size 0]
+ [exponent ..exponent_size ..mantissa_size]
+ [sign 1 ..sign_offset]
+ )
+
+(def: #export (from_bits input)
+ (-> I64 Frac)
+ (case [(: Nat (..exponent input))
+ (: Nat (..mantissa input))
+ (: Nat (..sign input))]
+ (^ [(static ..special_exponent_bits) 0 0])
+ ..positive_infinity
+
+ (^ [(static ..special_exponent_bits) 0 1])
+ ..negative_infinity
+
+ (^ [(static ..special_exponent_bits) _ _])
+ ..not_a_number
+
+ ## Positive zero
+ [0 0 0] +0.0
+ ## Negative zero
+ [0 0 1] (..* -1.0 +0.0)
+
+ [E M S]
+ (let [sign (if (//nat.= 0 S)
+ +1.0
+ -1.0)
+ [mantissa power] (if (//nat.< ..mantissa_size E)
+ [(if (//nat.= 0 E)
+ M
+ (//i64.set ..mantissa_size M))
+ (|> E
+ (//nat.- ..double_bias)
+ .int
+ (//int.max ..min_exponent)
+ (//int.- (.int ..mantissa_size)))]
+ [(//i64.set ..mantissa_size M)
+ (|> E (//nat.- ..double_bias) (//nat.- ..mantissa_size) .int)])
+ exponent (///.pow (//int.frac power) +2.0)]
+ (|> (//nat.frac mantissa)
+ (..* exponent)
+ (..* sign)))))
+
+(def: (split_exponent codec representation)
+ (-> (Codec Text Nat) Text (Try [Text Int]))
+ (case [("lux text index" 0 "e+" representation)
+ ("lux text index" 0 "E+" representation)
+ ("lux text index" 0 "e-" representation)
+ ("lux text index" 0 "E-" representation)]
+ (^template [<factor> <patterns>]
+ [<patterns>
+ (do try.monad
+ [#let [after_offset (//nat.+ 2 split_index)
+ after_length (//nat.- after_offset ("lux text size" representation))]
+ exponent (|> representation
+ ("lux text clip" after_offset after_length)
+ (\ codec decode))]
+ (wrap [("lux text clip" 0 split_index representation)
+ (//int.* <factor> (.int exponent))]))])
+ ([+1 (^or [(#.Some split_index) #.None #.None #.None]
+ [#.None (#.Some split_index) #.None #.None])]
+ [-1 (^or [#.None #.None (#.Some split_index) #.None]
+ [#.None #.None #.None (#.Some split_index)])])
+
+ _
+ (#try.Success [representation +0])))
+
+(template [<struct> <nat> <int> <error>]
+ [(implementation: #export <struct>
+ (Codec Text Frac)
+
+ (def: (encode value)
+ (let [bits (..to_bits value)
+ mantissa (..mantissa bits)
+ exponent (//int.- (.int ..double_bias) (..exponent bits))
+ sign (..sign bits)]
+ ($_ "lux text concat"
+ (case (.nat sign)
+ 1 "-"
+ 0 "+"
+ _ (undefined))
+ (\ <nat> encode (.nat mantissa))
+ ".0E"
+ (\ <int> encode exponent))))
+
+ (def: (decode representation)
+ (let [negative? (text.starts_with? "-" representation)
+ positive? (text.starts_with? "+" representation)]
+ (if (or negative? positive?)
+ (do {! try.monad}
+ [[mantissa exponent] (..split_exponent <nat> representation)
+ [whole decimal] (case ("lux text index" 0 "." mantissa)
+ (#.Some split_index)
+ (do !
+ [#let [after_offset (inc split_index)
+ after_length (//nat.- after_offset ("lux text size" mantissa))]
+ decimal (|> mantissa
+ ("lux text clip" after_offset after_length)
+ (\ <nat> decode))]
+ (wrap [("lux text clip" 0 split_index mantissa)
+ decimal]))
+
+ #.None
+ (#try.Failure ("lux text concat" <error> representation)))
+ #let [whole ("lux text clip" 1 (dec ("lux text size" whole)) whole)]
+ mantissa (\ <nat> decode (case decimal
+ 0 whole
+ _ ("lux text concat" whole (\ <nat> encode decimal))))
+ #let [sign (if negative? 1 0)]]
+ (wrap (..from_bits
+ ($_ //i64.or
+ (//i64.left_shift ..sign_offset (.i64 sign))
+ (//i64.left_shift ..mantissa_size (.i64 (//int.+ (.int ..double_bias) exponent)))
+ (//i64.clear ..mantissa_size (.i64 mantissa))))))
+ (#try.Failure ("lux text concat" <error> representation))))))]
+
+ [binary //nat.binary //int.binary "Invalid binary syntax: "]
+ [octal //nat.octal //int.octal "Invalid octaladecimal syntax: "]
+ [hex //nat.hex //int.hex "Invalid hexadecimal syntax: "]
+ )
+
+(implementation: #export hash
+ (Hash Frac)
+
+ (def: &equivalence ..equivalence)
+ (def: hash ..to_bits))
+
+(def: #export (approximately? margin_of_error standard value)
+ (-> Frac Frac Frac Bit)
+ (|> value
+ (..- standard)
+ ..abs
+ (..< margin_of_error)))
+
+(def: #export (mod divisor dividend)
+ (All [m] (-> Frac Frac Frac))
+ (let [remainder (..% divisor dividend)]
+ (if (or (and (..< +0.0 divisor)
+ (..> +0.0 remainder))
+ (and (..> +0.0 divisor)
+ (..< +0.0 remainder)))
+ (..+ divisor remainder)
+ remainder)))
diff --git a/stdlib/source/library/lux/math/number/i16.lux b/stdlib/source/library/lux/math/number/i16.lux
new file mode 100644
index 000000000..a35300c11
--- /dev/null
+++ b/stdlib/source/library/lux/math/number/i16.lux
@@ -0,0 +1,24 @@
+(.module:
+ [library
+ [lux (#- i64)
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." maybe]]
+ [type (#+ :by_example)]]]
+ [//
+ ["." i64 (#+ Sub)]])
+
+(def: sub (maybe.assume (i64.sub 16)))
+
+(def: #export I16
+ (:by_example [size]
+ (Sub size)
+ ..sub
+
+ (I64 size)))
+
+(def: #export equivalence (Equivalence I16) (\ ..sub &equivalence))
+(def: #export width Nat (\ ..sub width))
+(def: #export i16 (-> I64 I16) (\ ..sub narrow))
+(def: #export i64 (-> I16 I64) (\ ..sub widen))
diff --git a/stdlib/source/library/lux/math/number/i32.lux b/stdlib/source/library/lux/math/number/i32.lux
new file mode 100644
index 000000000..a0ecfabc2
--- /dev/null
+++ b/stdlib/source/library/lux/math/number/i32.lux
@@ -0,0 +1,24 @@
+(.module:
+ [library
+ [lux (#- i64)
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." maybe]]
+ [type (#+ :by_example)]]]
+ [//
+ ["." i64 (#+ Sub)]])
+
+(def: sub (maybe.assume (i64.sub 32)))
+
+(def: #export I32
+ (:by_example [size]
+ (Sub size)
+ ..sub
+
+ (I64 size)))
+
+(def: #export equivalence (Equivalence I32) (\ ..sub &equivalence))
+(def: #export width Nat (\ ..sub width))
+(def: #export i32 (-> I64 I32) (\ ..sub narrow))
+(def: #export i64 (-> I32 I64) (\ ..sub widen))
diff --git a/stdlib/source/library/lux/math/number/i64.lux b/stdlib/source/library/lux/math/number/i64.lux
new file mode 100644
index 000000000..357b36557
--- /dev/null
+++ b/stdlib/source/library/lux/math/number/i64.lux
@@ -0,0 +1,214 @@
+(.module:
+ [library
+ [lux (#- and or not false true)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]
+ [monoid (#+ Monoid)]]
+ [control
+ ["." try]]]]
+ [//
+ ["n" nat]])
+
+(def: #export bits_per_byte
+ 8)
+
+(def: #export bytes_per_i64
+ 8)
+
+(def: #export width
+ Nat
+ (n.* ..bits_per_byte
+ ..bytes_per_i64))
+
+(template [<parameter_type> <name> <op> <doc>]
+ [(def: #export (<name> parameter subject)
+ {#.doc <doc>}
+ (All [s] (-> <parameter_type> (I64 s) (I64 s)))
+ (<op> parameter subject))]
+
+ [(I64 Any) or "lux i64 or" "Bitwise or."]
+ [(I64 Any) xor "lux i64 xor" "Bitwise xor."]
+ [(I64 Any) and "lux i64 and" "Bitwise and."]
+
+ [Nat left_shift "lux i64 left-shift" "Bitwise left-shift."]
+ [Nat right_shift "lux i64 right-shift" "Unsigned/logic bitwise right-shift."]
+ )
+
+(type: #export Mask
+ I64)
+
+(def: #export (bit position)
+ (-> Nat Mask)
+ (|> 1 .i64 (..left_shift (n.% ..width position))))
+
+(def: #export sign
+ Mask
+ (..bit (dec ..width)))
+
+(def: #export not
+ {#.doc "Bitwise negation."}
+ (All [s] (-> (I64 s) (I64 s)))
+ (..xor (.i64 (dec 0))))
+
+(def: #export false
+ Mask
+ (.i64 0))
+
+(def: #export true
+ Mask
+ (..not ..false))
+
+(def: #export (mask amount_of_bits)
+ (-> Nat Mask)
+ (case amount_of_bits
+ 0 ..false
+ bits (case (n.% ..width bits)
+ 0 ..true
+ bits (|> 1 .i64 (..left_shift (n.% ..width bits)) .dec))))
+
+(def: (add_shift shift value)
+ (-> Nat Nat Nat)
+ (|> value (right_shift shift) (n.+ value)))
+
+(def: #export (count subject)
+ {#.doc "Count the number of 1s in a bit-map."}
+ (-> (I64 Any) Nat)
+ (let [count' (n.- (|> subject (right_shift 1) (..and 6148914691236517205) i64)
+ (i64 subject))]
+ (|> count'
+ (right_shift 2) (..and 3689348814741910323) (n.+ (..and 3689348814741910323 count'))
+ (add_shift 4) (..and 1085102592571150095)
+ (add_shift 8)
+ (add_shift 16)
+ (add_shift 32)
+ (..and 127))))
+
+(def: #export (clear idx input)
+ {#.doc "Clear bit at given index."}
+ (All [s] (-> Nat (I64 s) (I64 s)))
+ (|> idx ..bit ..not (..and input)))
+
+(template [<name> <op> <doc>]
+ [(def: #export (<name> idx input)
+ {#.doc <doc>}
+ (All [s] (-> Nat (I64 s) (I64 s)))
+ (|> idx ..bit (<op> input)))]
+
+ [set ..or "Set bit at given index."]
+ [flip ..xor "Flip bit at given index."]
+ )
+
+(def: #export (set? idx input)
+ (-> Nat (I64 Any) Bit)
+ (|> input (:as I64) (..and (..bit idx)) (n.= 0) .not))
+
+(def: #export (clear? idx input)
+ (-> Nat (I64 Any) Bit)
+ (.not (..set? idx input)))
+
+(template [<name> <forward> <backward>]
+ [(def: #export (<name> distance input)
+ (All [s] (-> Nat (I64 s) (I64 s)))
+ (..or (<forward> distance input)
+ (<backward> (n.- (n.% ..width distance) ..width) input)))]
+
+ [rotate_left ..left_shift ..right_shift]
+ [rotate_right ..right_shift ..left_shift]
+ )
+
+(def: #export (region size offset)
+ (-> Nat Nat Mask)
+ (..left_shift offset (..mask size)))
+
+(implementation: #export equivalence
+ (All [a] (Equivalence (I64 a)))
+
+ (def: (= reference sample)
+ ("lux i64 =" reference sample)))
+
+(implementation: #export hash
+ (All [a] (Hash (I64 a)))
+
+ (def: &equivalence ..equivalence)
+
+ (def: hash .nat))
+
+(template [<monoid> <identity> <compose>]
+ [(implementation: #export <monoid>
+ (All [a] (Monoid (I64 a)))
+
+ (def: identity <identity>)
+ (def: compose <compose>))]
+
+ [disjunction ..false ..or]
+ [conjunction ..true ..and]
+ )
+
+(def: #export reverse
+ (All [a] (-> (I64 a) (I64 a)))
+ (let [swapper (: (-> Nat (All [a] (-> (I64 a) (I64 a))))
+ (function (_ power)
+ (let [size (..left_shift power 1)
+ repetitions (: (-> Nat Text Text)
+ (function (_ times char)
+ (loop [iterations 1
+ output char]
+ (if (n.< times iterations)
+ (recur (inc iterations)
+ ("lux text concat" char output))
+ output))))
+ pattern (repetitions (n./ (n.+ size size) ..width)
+ ("lux text concat"
+ (repetitions size "1")
+ (repetitions size "0")))
+
+ high (try.assume (\ n.binary decode pattern))
+ low (..rotate_right size high)]
+ (function (_ value)
+ (..or (..right_shift size (..and high value))
+ (..left_shift size (..and low value)))))))
+
+ swap/01 (swapper 0)
+ swap/02 (swapper 1)
+ swap/04 (swapper 2)
+ swap/08 (swapper 3)
+ swap/16 (swapper 4)
+ swap/32 (swapper 5)]
+ (|>> swap/32
+ swap/16
+ swap/08
+ swap/04
+ swap/02
+ swap/01)))
+
+(interface: #export (Sub size)
+ (: (Equivalence (I64 size))
+ &equivalence)
+ (: Nat
+ width)
+ (: (-> I64 (I64 size))
+ narrow)
+ (: (-> (I64 size) I64)
+ widen))
+
+(def: #export (sub width)
+ (Ex [size] (-> Nat (Maybe (Sub size))))
+ (if (.and (n.> 0 width)
+ (n.< ..width width))
+ (let [sign_shift (n.- width ..width)
+ sign (..bit (dec width))
+ mantissa (..mask (dec width))
+ co_mantissa (..xor (.i64 -1) mantissa)]
+ (#.Some (: Sub
+ (implementation
+ (def: &equivalence ..equivalence)
+ (def: width width)
+ (def: (narrow value)
+ (..or (|> value (..and ..sign) (..right_shift sign_shift))
+ (|> value (..and mantissa))))
+ (def: (widen value)
+ (.i64 (case (.nat (..and sign value))
+ 0 value
+ _ (..or co_mantissa value))))))))
+ #.None))
diff --git a/stdlib/source/library/lux/math/number/i8.lux b/stdlib/source/library/lux/math/number/i8.lux
new file mode 100644
index 000000000..2e8fc0cf1
--- /dev/null
+++ b/stdlib/source/library/lux/math/number/i8.lux
@@ -0,0 +1,24 @@
+(.module:
+ [library
+ [lux (#- i64)
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." maybe]]
+ [type (#+ :by_example)]]]
+ [//
+ ["." i64 (#+ Sub)]])
+
+(def: sub (maybe.assume (i64.sub 8)))
+
+(def: #export I8
+ (:by_example [size]
+ (Sub size)
+ ..sub
+
+ (I64 size)))
+
+(def: #export equivalence (Equivalence I8) (\ ..sub &equivalence))
+(def: #export width Nat (\ ..sub width))
+(def: #export i8 (-> I64 I8) (\ ..sub narrow))
+(def: #export i64 (-> I8 I64) (\ ..sub widen))
diff --git a/stdlib/source/library/lux/math/number/int.lux b/stdlib/source/library/lux/math/number/int.lux
new file mode 100644
index 000000000..c72c31e16
--- /dev/null
+++ b/stdlib/source/library/lux/math/number/int.lux
@@ -0,0 +1,260 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [hash (#+ Hash)]
+ [enum (#+ Enum)]
+ [interval (#+ Interval)]
+ [monoid (#+ Monoid)]
+ [equivalence (#+ Equivalence)]
+ [codec (#+ Codec)]
+ [predicate (#+ Predicate)]
+ ["." order (#+ Order)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ [text (#+ Char)]
+ ["." maybe]]]]
+ ["." // #_
+ ["#." nat]
+ ["#." i64]])
+
+(def: #export (= reference sample)
+ {#.doc "Int(eger) equivalence."}
+ (-> Int Int Bit)
+ ("lux i64 =" reference sample))
+
+(def: #export (< reference sample)
+ {#.doc "Int(eger) less-than."}
+ (-> Int Int Bit)
+ ("lux i64 <" reference sample))
+
+(def: #export (<= reference sample)
+ {#.doc "Int(eger) less-than or equal."}
+ (-> Int Int Bit)
+ (if ("lux i64 <" reference sample)
+ #1
+ ("lux i64 =" reference sample)))
+
+(def: #export (> reference sample)
+ {#.doc "Int(eger) greater-than."}
+ (-> Int Int Bit)
+ ("lux i64 <" sample reference))
+
+(def: #export (>= reference sample)
+ {#.doc "Int(eger) greater-than or equal."}
+ (-> Int Int Bit)
+ (if ("lux i64 <" sample reference)
+ #1
+ ("lux i64 =" reference sample)))
+
+(template [<comparison> <name>]
+ [(def: #export <name>
+ (Predicate Int)
+ (<comparison> +0))]
+
+ [..> positive?]
+ [..< negative?]
+ [..= zero?]
+ )
+
+(template [<name> <test> <doc>]
+ [(def: #export (<name> left right)
+ {#.doc <doc>}
+ (-> Int Int Int)
+ (if (<test> right left)
+ left
+ right))]
+
+ [min ..< "Int(eger) minimum."]
+ [max ..> "Int(eger) maximum."]
+ )
+
+(template [<name> <op> <doc>]
+ [(def: #export (<name> param subject)
+ {#.doc <doc>}
+ (-> Int Int Int)
+ (<op> param subject))]
+
+ [+ "lux i64 +" "Int(eger) addition."]
+ [- "lux i64 -" "Int(eger) substraction."]
+ [* "lux i64 *" "Int(eger) multiplication."]
+ [/ "lux i64 /" "Int(eger) division."]
+ [% "lux i64 %" "Int(eger) remainder."]
+ )
+
+(def: #export (/% param subject)
+ (-> Int Int [Int Int])
+ [(../ param subject)
+ (..% param subject)])
+
+(def: #export (negate value)
+ (-> Int Int)
+ (..- value +0))
+
+(def: #export (abs x)
+ (-> Int Int)
+ (if (..< +0 x)
+ (..* -1 x)
+ x))
+
+(def: #export (signum x)
+ (-> Int Int)
+ (cond (..= +0 x) +0
+ (..< +0 x) -1
+ ## else
+ +1))
+
+## https://rob.conery.io/2018/08/21/mod-and-remainder-are-not-the-same/
+(def: #export (mod divisor dividend)
+ (All [m] (-> Int Int Int))
+ (let [remainder (..% divisor dividend)]
+ (if (or (and (..< +0 divisor)
+ (..> +0 remainder))
+ (and (..> +0 divisor)
+ (..< +0 remainder)))
+ (..+ divisor remainder)
+ remainder)))
+
+(def: #export even?
+ (-> Int Bit)
+ (|>> (..% +2) ("lux i64 =" +0)))
+
+(def: #export odd?
+ (-> Int Bit)
+ (|>> ..even? not))
+
+(def: #export (gcd a b)
+ {#.doc "Greatest Common Divisor."}
+ (-> Int Int Int)
+ (case b
+ +0 a
+ _ (gcd b (..% b a))))
+
+(def: #export (co-prime? a b)
+ (-> Int Int Bit)
+ (..= +1 (..gcd a b)))
+
+## https://en.wikipedia.org/wiki/Extended_Euclidean_algorithm
+(def: #export (extended_gcd a b)
+ {#.doc "Extended euclidean algorithm."}
+ (-> Int Int [[Int Int] Int])
+ (loop [x +1 x1 +0
+ y +0 y1 +1
+ a1 a b1 b]
+ (case b1
+ +0 [[x y] a1]
+ _ (let [q (/ b1 a1)]
+ (recur x1 (- (* q x1) x)
+ y1 (- (* q y1) y)
+ b1 (- (* q b1) a1))))))
+
+(def: #export (lcm a b)
+ {#.doc "Least Common Multiple."}
+ (-> Int Int Int)
+ (case [a b]
+ (^or [_ +0] [+0 _])
+ +0
+
+ _
+ (|> a (/ (gcd a b)) (* b))
+ ))
+
+(def: #export frac
+ (-> Int Frac)
+ (|>> "lux i64 f64"))
+
+(implementation: #export equivalence
+ (Equivalence Int)
+
+ (def: = ..=))
+
+(implementation: #export order
+ (Order Int)
+
+ (def: &equivalence ..equivalence)
+ (def: < ..<))
+
+(implementation: #export enum
+ (Enum Int)
+
+ (def: &order ..order)
+ (def: succ inc)
+ (def: pred dec))
+
+## TODO: Find out why the numeric literals fail during JS compilation.
+(implementation: #export interval
+ (Interval Int)
+
+ (def: &enum ..enum)
+ (def: top
+ ## +9,223,372,036,854,775,807
+ (let [half (//i64.left_shift 62 +1)]
+ (+ half
+ (dec half))))
+ (def: bottom
+ ## -9,223,372,036,854,775,808
+ (//i64.left_shift 63 +1)))
+
+(template [<name> <compose> <identity>]
+ [(implementation: #export <name>
+ (Monoid Int)
+
+ (def: identity <identity>)
+ (def: compose <compose>))]
+
+ [addition ..+ +0]
+ [multiplication ..* +1]
+ [maximum ..max (\ ..interval bottom)]
+ [minimum ..min (\ ..interval top)]
+ )
+
+(def: -sign "-")
+(def: +sign "+")
+
+(template [<struct> <codec> <error>]
+ [(implementation: #export <struct>
+ (Codec Text Int)
+
+ (def: (encode value)
+ (if (..< +0 value)
+ (|> value inc ..negate .nat inc (\ <codec> encode) ("lux text concat" ..-sign))
+ (|> value .nat (\ <codec> encode) ("lux text concat" ..+sign))))
+
+ (def: (decode repr)
+ (let [input_size ("lux text size" repr)]
+ (if (//nat.> 1 input_size)
+ (case ("lux text clip" 0 1 repr)
+ (^ (static ..+sign))
+ (|> repr
+ ("lux text clip" 1 (dec input_size))
+ (\ <codec> decode)
+ (\ try.functor map .int))
+
+ (^ (static ..-sign))
+ (|> repr
+ ("lux text clip" 1 (dec input_size))
+ (\ <codec> decode)
+ (\ try.functor map (|>> dec .int ..negate dec)))
+
+ _
+ (#try.Failure <error>))
+ (#try.Failure <error>)))))]
+
+ [binary //nat.binary "Invalid binary syntax for Int: "]
+ [octal //nat.octal "Invalid octal syntax for Int: "]
+ [decimal //nat.decimal "Invalid syntax for Int: "]
+ [hex //nat.hex "Invalid hexadecimal syntax for Int: "]
+ )
+
+(implementation: #export hash
+ (Hash Int)
+
+ (def: &equivalence ..equivalence)
+ (def: hash .nat))
+
+(def: #export (right_shift parameter subject)
+ {#.doc "Signed/arithmetic bitwise right-shift."}
+ (-> Nat Int Int)
+ (//i64.or (//i64.and //i64.sign subject)
+ (//i64.right_shift parameter subject)))
diff --git a/stdlib/source/library/lux/math/number/nat.lux b/stdlib/source/library/lux/math/number/nat.lux
new file mode 100644
index 000000000..52e252c84
--- /dev/null
+++ b/stdlib/source/library/lux/math/number/nat.lux
@@ -0,0 +1,380 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [hash (#+ Hash)]
+ [enum (#+ Enum)]
+ [interval (#+ Interval)]
+ [monoid (#+ Monoid)]
+ [equivalence (#+ Equivalence)]
+ [codec (#+ Codec)]
+ ["." order (#+ Order)]]
+ [control
+ ["." function]
+ ["." try (#+ Try)]]
+ [data
+ ["." maybe]]]])
+
+(template [<extension> <output> <name> <documentation>]
+ [(def: #export (<name> parameter subject)
+ {#.doc <documentation>}
+ (-> Nat Nat <output>)
+ (<extension> parameter subject))]
+
+ ["lux i64 =" Bit = "Nat(ural) equivalence."]
+ ["lux i64 +" Nat + "Nat(ural) addition."]
+ ["lux i64 -" Nat - "Nat(ural) substraction."]
+ )
+
+(def: high
+ (-> (I64 Any) I64)
+ (|>> ("lux i64 right-shift" 32)))
+
+(def: low
+ (-> (I64 Any) I64)
+ (let [mask (|> 1 ("lux i64 left-shift" 32) ("lux i64 -" 1))]
+ (|>> ("lux i64 and" mask))))
+
+(def: #export (< reference sample)
+ {#.doc "Nat(ural) less-than."}
+ (-> Nat Nat Bit)
+ (let [referenceH (..high reference)
+ sampleH (..high sample)]
+ (if ("lux i64 <" referenceH sampleH)
+ #1
+ (if ("lux i64 =" referenceH sampleH)
+ ("lux i64 <"
+ (..low reference)
+ (..low sample))
+ #0))))
+
+(def: #export (<= reference sample)
+ {#.doc "Nat(ural) less-than or equal."}
+ (-> Nat Nat Bit)
+ (if (..< reference sample)
+ #1
+ ("lux i64 =" reference sample)))
+
+(def: #export (> reference sample)
+ {#.doc "Nat(ural) greater-than."}
+ (-> Nat Nat Bit)
+ (..< sample reference))
+
+(def: #export (>= reference sample)
+ {#.doc "Nat(ural) greater-than or equal."}
+ (-> Nat Nat Bit)
+ (if (..< sample reference)
+ #1
+ ("lux i64 =" reference sample)))
+
+(template [<name> <test> <doc>]
+ [(def: #export (<name> left right)
+ {#.doc <doc>}
+ (-> Nat Nat Nat)
+ (if (<test> right left)
+ left
+ right))]
+
+ [min ..< "Nat(ural) minimum."]
+ [max ..> "Nat(ural) maximum."]
+ )
+
+(def: #export (* parameter subject)
+ {#.doc "Nat(ural) multiplication."}
+ (-> Nat Nat Nat)
+ (:as Nat
+ ("lux i64 *"
+ (:as Int parameter)
+ (:as Int subject))))
+
+(def: #export (/ parameter subject)
+ {#.doc "Nat(ural) division."}
+ (-> Nat Nat Nat)
+ (if ("lux i64 <" +0 (:as Int parameter))
+ (if (..< parameter subject)
+ 0
+ 1)
+ (let [quotient (|> subject
+ ("lux i64 right-shift" 1)
+ ("lux i64 /" (:as Int parameter))
+ ("lux i64 left-shift" 1))
+ flat ("lux i64 *"
+ (:as Int parameter)
+ (:as Int quotient))
+ remainder ("lux i64 -" flat subject)]
+ (if (..< parameter remainder)
+ quotient
+ ("lux i64 +" 1 quotient)))))
+
+(def: #export (/% parameter subject)
+ {#.doc "Nat(ural) [division remainder]."}
+ (-> Nat Nat [Nat Nat])
+ (let [quotient (../ parameter subject)
+ flat ("lux i64 *"
+ (:as Int parameter)
+ (:as Int quotient))]
+ [quotient ("lux i64 -" flat subject)]))
+
+(def: #export (% parameter subject)
+ {#.doc "Nat(ural) remainder."}
+ (-> Nat Nat Nat)
+ (let [flat ("lux i64 *"
+ (:as Int parameter)
+ (:as Int (../ parameter subject)))]
+ ("lux i64 -" flat subject)))
+
+(def: #export (gcd a b)
+ {#.doc "Greatest Common Divisor."}
+ (-> Nat Nat Nat)
+ (case b
+ 0 a
+ _ (gcd b (..% b a))))
+
+(def: #export (co-prime? a b)
+ (-> Nat Nat Bit)
+ (..= 1 (..gcd a b)))
+
+(def: #export (lcm a b)
+ {#.doc "Least Common Multiple."}
+ (-> Nat Nat Nat)
+ (case [a b]
+ (^or [_ 0] [0 _])
+ 0
+
+ _
+ (|> a (../ (..gcd a b)) (..* b))))
+
+(def: #export even?
+ (-> Nat Bit)
+ (|>> (..% 2) ("lux i64 =" 0)))
+
+(def: #export odd?
+ (-> Nat Bit)
+ (|>> ..even? not))
+
+(def: #export frac
+ (-> Nat Frac)
+ (|>> .int "lux i64 f64"))
+
+(implementation: #export equivalence
+ (Equivalence Nat)
+
+ (def: = ..=))
+
+(implementation: #export order
+ (Order Nat)
+
+ (def: &equivalence ..equivalence)
+ (def: < ..<))
+
+(implementation: #export enum
+ (Enum Nat)
+
+ (def: &order ..order)
+ (def: succ inc)
+ (def: pred dec))
+
+(implementation: #export interval
+ (Interval Nat)
+
+ (def: &enum ..enum)
+ (def: top (dec 0))
+ (def: bottom 0))
+
+(template [<name> <compose> <identity>]
+ [(implementation: #export <name>
+ (Monoid Nat)
+
+ (def: identity <identity>)
+ (def: compose <compose>))]
+
+ [addition ..+ 0]
+ [multiplication ..* 1]
+ [minimum ..min (\ ..interval top)]
+ [maximum ..max (\ ..interval bottom)]
+ )
+
+(def: (binary-character value)
+ (-> Nat Text)
+ (case value
+ 0 "0"
+ 1 "1"
+ _ (undefined)))
+
+(def: (binary-value digit)
+ (-> Nat (Maybe Nat))
+ (case digit
+ (^ (char "0")) (#.Some 0)
+ (^ (char "1")) (#.Some 1)
+ _ #.None))
+
+(def: (octal-character value)
+ (-> Nat Text)
+ (case value
+ 0 "0"
+ 1 "1"
+ 2 "2"
+ 3 "3"
+ 4 "4"
+ 5 "5"
+ 6 "6"
+ 7 "7"
+ _ (undefined)))
+
+(def: (octal-value digit)
+ (-> Nat (Maybe Nat))
+ (case digit
+ (^ (char "0")) (#.Some 0)
+ (^ (char "1")) (#.Some 1)
+ (^ (char "2")) (#.Some 2)
+ (^ (char "3")) (#.Some 3)
+ (^ (char "4")) (#.Some 4)
+ (^ (char "5")) (#.Some 5)
+ (^ (char "6")) (#.Some 6)
+ (^ (char "7")) (#.Some 7)
+ _ #.None))
+
+(def: (decimal-character value)
+ (-> Nat Text)
+ (case value
+ 0 "0"
+ 1 "1"
+ 2 "2"
+ 3 "3"
+ 4 "4"
+ 5 "5"
+ 6 "6"
+ 7 "7"
+ 8 "8"
+ 9 "9"
+ _ (undefined)))
+
+(def: (decimal-value digit)
+ (-> Nat (Maybe Nat))
+ (case digit
+ (^ (char "0")) (#.Some 0)
+ (^ (char "1")) (#.Some 1)
+ (^ (char "2")) (#.Some 2)
+ (^ (char "3")) (#.Some 3)
+ (^ (char "4")) (#.Some 4)
+ (^ (char "5")) (#.Some 5)
+ (^ (char "6")) (#.Some 6)
+ (^ (char "7")) (#.Some 7)
+ (^ (char "8")) (#.Some 8)
+ (^ (char "9")) (#.Some 9)
+ _ #.None))
+
+(def: (hexadecimal-character value)
+ (-> Nat Text)
+ (case value
+ 0 "0"
+ 1 "1"
+ 2 "2"
+ 3 "3"
+ 4 "4"
+ 5 "5"
+ 6 "6"
+ 7 "7"
+ 8 "8"
+ 9 "9"
+ 10 "A"
+ 11 "B"
+ 12 "C"
+ 13 "D"
+ 14 "E"
+ 15 "F"
+ _ (undefined)))
+
+(def: (hexadecimal-value digit)
+ (-> Nat (Maybe Nat))
+ (case digit
+ (^template [<character> <number>]
+ [(^ (char <character>)) (#.Some <number>)])
+ (["0" 0] ["1" 1] ["2" 2] ["3" 3] ["4" 4]
+ ["5" 5] ["6" 6] ["7" 7] ["8" 8] ["9" 9])
+
+ (^template [<lower> <upper> <number>]
+ [(^or (^ (char <lower>)) (^ (char <upper>))) (#.Some <number>)])
+ (["a" "A" 10] ["b" "B" 11] ["c" "C" 12]
+ ["d" "D" 13] ["e" "E" 14] ["f" "F" 15])
+ _ #.None))
+
+(template [<shift> <struct> <to-character> <to-value> <error>]
+ [(implementation: #export <struct>
+ (Codec Text Nat)
+
+ (def: encode
+ (let [mask (|> 1 ("lux i64 left-shift" <shift>) dec)]
+ (function (_ value)
+ (loop [input value
+ output ""]
+ (let [output' ("lux text concat"
+ (<to-character> ("lux i64 and" mask input))
+ output)]
+ (case (: Nat ("lux i64 right-shift" <shift> input))
+ 0
+ output'
+
+ input'
+ (recur input' output')))))))
+
+ (def: (decode repr)
+ (let [input-size ("lux text size" repr)]
+ (if (..> 0 input-size)
+ (loop [idx 0
+ output 0]
+ (if (..< input-size idx)
+ (case (<to-value> ("lux text char" idx repr))
+ (#.Some digit-value)
+ (recur (inc idx)
+ (|> output
+ ("lux i64 left-shift" <shift>)
+ ("lux i64 or" digit-value)))
+
+ _
+ (#try.Failure ("lux text concat" <error> repr)))
+ (#try.Success output)))
+ (#try.Failure ("lux text concat" <error> repr))))))]
+
+ [1 binary binary-character binary-value "Invalid binary syntax for Nat: "]
+ [3 octal octal-character octal-value "Invalid octal syntax for Nat: "]
+ [4 hex hexadecimal-character hexadecimal-value "Invalid hexadecimal syntax for Nat: "]
+ )
+
+(implementation: #export decimal
+ (Codec Text Nat)
+
+ (def: (encode value)
+ (loop [input value
+ output ""]
+ (let [digit (decimal-character (..% 10 input))
+ output' ("lux text concat" digit output)]
+ (case (../ 10 input)
+ 0
+ output'
+
+ input'
+ (recur input' output')))))
+
+ (def: (decode repr)
+ (let [input-size ("lux text size" repr)]
+ (with_expansions [<failure> (#try.Failure ("lux text concat" "Invalid decimal syntax for Nat: " repr))]
+ (if (..> 0 input-size)
+ (loop [idx 0
+ output 0]
+ (if (..< input-size idx)
+ (case (decimal-value ("lux text char" idx repr))
+ #.None
+ <failure>
+
+ (#.Some digit-value)
+ (recur (inc idx)
+ (|> output (..* 10) (..+ digit-value))))
+ (#try.Success output)))
+ <failure>)))))
+
+(implementation: #export hash
+ (Hash Nat)
+
+ (def: &equivalence ..equivalence)
+ (def: hash function.identity))
diff --git a/stdlib/source/library/lux/math/number/ratio.lux b/stdlib/source/library/lux/math/number/ratio.lux
new file mode 100644
index 000000000..ecfdf30a0
--- /dev/null
+++ b/stdlib/source/library/lux/math/number/ratio.lux
@@ -0,0 +1,162 @@
+(.module:
+ {#.doc "Rational numbers."}
+ [library
+ [lux (#- nat)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]
+ [monoid (#+ Monoid)]
+ [codec (#+ Codec)]
+ [monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try]
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text ("#\." monoid)]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]]]]
+ [//
+ ["n" nat ("#\." decimal)]])
+
+(type: #export Ratio
+ {#numerator Nat
+ #denominator Nat})
+
+(def: #export (nat value)
+ (-> Ratio (Maybe Nat))
+ (case (get@ #denominator value)
+ 1 (#.Some (get@ #numerator value))
+ _ #.None))
+
+(def: (normalize (^slots [#numerator #denominator]))
+ (-> Ratio Ratio)
+ (let [common (n.gcd numerator denominator)]
+ {#numerator (n./ common numerator)
+ #denominator (n./ common denominator)}))
+
+(syntax: #export (ratio numerator {?denominator (<>.maybe <code>.any)})
+ {#.doc (doc "Rational literals."
+ (ratio numerator denominator)
+ "The denominator can be omitted if it's 1."
+ (ratio numerator))}
+ (wrap (list (` ((~! ..normalize) {#..numerator (~ numerator)
+ #..denominator (~ (maybe.default (' 1)
+ ?denominator))})))))
+
+(def: #export (= parameter subject)
+ (-> Ratio Ratio Bit)
+ (and (n.= (get@ #numerator parameter)
+ (get@ #numerator subject))
+ (n.= (get@ #denominator parameter)
+ (get@ #denominator subject))))
+
+(implementation: #export equivalence
+ (Equivalence Ratio)
+
+ (def: = ..=))
+
+(def: (equalize parameter subject)
+ (-> Ratio Ratio [Nat Nat])
+ [(n.* (get@ #denominator subject)
+ (get@ #numerator parameter))
+ (n.* (get@ #denominator parameter)
+ (get@ #numerator subject))])
+
+(def: #export (< parameter subject)
+ (-> Ratio Ratio Bit)
+ (let [[parameter' subject'] (..equalize parameter subject)]
+ (n.< parameter' subject')))
+
+(def: #export (<= parameter subject)
+ (-> Ratio Ratio Bit)
+ (or (< parameter subject)
+ (= parameter subject)))
+
+(def: #export (> parameter subject)
+ (-> Ratio Ratio Bit)
+ (..< subject parameter))
+
+(def: #export (>= parameter subject)
+ (-> Ratio Ratio Bit)
+ (or (> parameter subject)
+ (= parameter subject)))
+
+(implementation: #export order
+ (Order Ratio)
+
+ (def: &equivalence ..equivalence)
+ (def: < ..<))
+
+(def: #export (+ parameter subject)
+ (-> Ratio Ratio Ratio)
+ (let [[parameter' subject'] (..equalize parameter subject)]
+ (normalize [(n.+ parameter' subject')
+ (n.* (get@ #denominator parameter)
+ (get@ #denominator subject))])))
+
+(def: #export (- parameter subject)
+ (-> Ratio Ratio Ratio)
+ (let [[parameter' subject'] (..equalize parameter subject)]
+ (normalize [(n.- parameter' subject')
+ (n.* (get@ #denominator parameter)
+ (get@ #denominator subject))])))
+
+(def: #export (* parameter subject)
+ (-> Ratio Ratio Ratio)
+ (normalize [(n.* (get@ #numerator parameter)
+ (get@ #numerator subject))
+ (n.* (get@ #denominator parameter)
+ (get@ #denominator subject))]))
+
+(def: #export (/ parameter subject)
+ (-> Ratio Ratio Ratio)
+ (let [[parameter' subject'] (..equalize parameter subject)]
+ (normalize [subject' parameter'])))
+
+(def: #export (% parameter subject)
+ (-> Ratio Ratio Ratio)
+ (let [[parameter' subject'] (..equalize parameter subject)
+ quot (n./ parameter' subject')]
+ (..- (update@ #numerator (n.* quot) parameter)
+ subject)))
+
+(def: #export (reciprocal (^slots [#numerator #denominator]))
+ (-> Ratio Ratio)
+ {#numerator denominator
+ #denominator numerator})
+
+(def: separator ":")
+
+(implementation: #export codec
+ (Codec Text Ratio)
+
+ (def: (encode (^slots [#numerator #denominator]))
+ ($_ text\compose (n\encode numerator) ..separator (n\encode denominator)))
+
+ (def: (decode input)
+ (case (text.split_with ..separator input)
+ (#.Some [num denom])
+ (do try.monad
+ [numerator (n\decode num)
+ denominator (n\decode denom)]
+ (wrap (normalize {#numerator numerator
+ #denominator denominator})))
+
+ #.None
+ (#.Left (text\compose "Invalid syntax for ratio: " input)))))
+
+(template [<identity> <compose> <name>]
+ [(implementation: #export <name>
+ (Monoid Ratio)
+
+ (def: identity (..ratio <identity>))
+ (def: compose <compose>))]
+
+ [0 ..+ addition]
+ [1 ..* multiplication]
+ )
diff --git a/stdlib/source/library/lux/math/number/rev.lux b/stdlib/source/library/lux/math/number/rev.lux
new file mode 100644
index 000000000..431f44ed1
--- /dev/null
+++ b/stdlib/source/library/lux/math/number/rev.lux
@@ -0,0 +1,463 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [hash (#+ Hash)]
+ [enum (#+ Enum)]
+ [interval (#+ Interval)]
+ [monoid (#+ Monoid)]
+ [equivalence (#+ Equivalence)]
+ [codec (#+ Codec)]
+ [order (#+ Order)]]
+ [control
+ ["." try]]
+ [data
+ ["." maybe]
+ [collection
+ ["." array (#+ Array)]]]]]
+ ["." // #_
+ ["#." i64]
+ ["#." nat]
+ ["#." int]])
+
+(template [<power> <name>]
+ [(def: #export <name>
+ Rev
+ (.rev (//i64.left_shift (//nat.- <power> //i64.width) 1)))]
+
+ [01 /2]
+ [02 /4]
+ [03 /8]
+ [04 /16]
+ [05 /32]
+ [06 /64]
+ [07 /128]
+ [08 /256]
+ [09 /512]
+ [10 /1024]
+ [11 /2048]
+ [12 /4096]
+ )
+
+(def: #export (= reference sample)
+ {#.doc "Rev(olution) equivalence."}
+ (-> Rev Rev Bit)
+ ("lux i64 =" reference sample))
+
+(def: #export (< reference sample)
+ {#.doc "Rev(olution) less-than."}
+ (-> Rev Rev Bit)
+ (//nat.< (.nat reference) (.nat sample)))
+
+(def: #export (<= reference sample)
+ {#.doc "Rev(olution) less-than or equal."}
+ (-> Rev Rev Bit)
+ (if (//nat.< (.nat reference) (.nat sample))
+ true
+ ("lux i64 =" reference sample)))
+
+(def: #export (> reference sample)
+ {#.doc "Rev(olution) greater-than."}
+ (-> Rev Rev Bit)
+ (..< sample reference))
+
+(def: #export (>= reference sample)
+ {#.doc "Rev(olution) greater-than or equal."}
+ (-> Rev Rev Bit)
+ (if (..< sample reference)
+ true
+ ("lux i64 =" reference sample)))
+
+(template [<name> <test> <doc>]
+ [(def: #export (<name> left right)
+ {#.doc <doc>}
+ (-> Rev Rev Rev)
+ (if (<test> right left)
+ left
+ right))]
+
+ [min ..< "Rev(olution) minimum."]
+ [max ..> "Rev(olution) maximum."]
+ )
+
+(template [<name> <op> <doc>]
+ [(def: #export (<name> param subject)
+ {#.doc <doc>}
+ (-> Rev Rev Rev)
+ (<op> param subject))]
+
+ [+ "lux i64 +" "Rev(olution) addition."]
+ [- "lux i64 -" "Rev(olution) substraction."]
+ )
+
+(def: high
+ (-> (I64 Any) I64)
+ (|>> ("lux i64 right-shift" 32)))
+
+(def: low
+ (-> (I64 Any) I64)
+ (let [mask (|> 1 ("lux i64 left-shift" 32) ("lux i64 -" 1))]
+ (|>> ("lux i64 and" mask))))
+
+(def: #export (* param subject)
+ {#.doc "Rev(olution) multiplication."}
+ (-> Rev Rev Rev)
+ (let [subjectH (..high subject)
+ subjectL (..low subject)
+ paramH (..high param)
+ paramL (..low param)
+ bottom (|> subjectL
+ ("lux i64 *" paramL)
+ ("lux i64 right-shift" 32))
+ middle ("lux i64 +"
+ ("lux i64 *" paramL subjectH)
+ ("lux i64 *" paramH subjectL))
+ top ("lux i64 *" subjectH paramH)]
+ (|> bottom
+ ("lux i64 +" middle)
+ ..high
+ ("lux i64 +" top))))
+
+(def: even_one (//i64.rotate_right 1 1))
+(def: odd_one (dec 0))
+
+(def: (even_reciprocal numerator)
+ (-> Nat Nat)
+ (//nat./ (//i64.right_shift 1 numerator)
+ ..even_one))
+
+(def: (odd_reciprocal numerator)
+ (-> Nat Nat)
+ (//nat./ numerator ..odd_one))
+
+(with_expansions [<least_significant_bit> 1]
+ (def: #export (reciprocal numerator)
+ {#.doc "Rev(olution) reciprocal of a Nat(ural)."}
+ (-> Nat Rev)
+ (.rev (case (: Nat ("lux i64 and" <least_significant_bit> numerator))
+ 0 (..even_reciprocal numerator)
+ _ (..odd_reciprocal numerator))))
+
+ (def: #export (/ param subject)
+ {#.doc "Rev(olution) division."}
+ (-> Rev Rev Rev)
+ (if ("lux i64 =" +0 param)
+ (error! "Cannot divide Rev by zero!")
+ (let [reciprocal (case (: Nat ("lux i64 and" <least_significant_bit> param))
+ 0 (..even_reciprocal (.nat param))
+ _ (..odd_reciprocal (.nat param)))]
+ (.rev (//nat.* reciprocal (.nat subject)))))))
+
+(template [<operator> <name> <output> <output_type> <documentation>]
+ [(def: #export (<name> param subject)
+ {#.doc <documentation>}
+ (-> Rev Rev <output_type>)
+ (<output> (<operator> (.nat param) (.nat subject))))]
+
+ [//nat.% % .rev Rev "Rev(olution) remainder."]
+ [//nat./ ratio |> Nat "Ratio between two rev(olution)s."]
+ )
+
+(template [<operator> <name>]
+ [(def: #export (<name> scale subject)
+ (-> Nat Rev Rev)
+ (.rev (<operator> (.nat scale) (.nat subject))))]
+
+ [//nat.* up]
+ [//nat./ down]
+ )
+
+(def: #export (/% param subject)
+ (-> Rev Rev [Rev Rev])
+ [(../ param subject)
+ (..% param subject)])
+
+(def: mantissa
+ (-> (I64 Any) Frac)
+ (|>> ("lux i64 right-shift" 11)
+ "lux i64 f64"))
+
+(def: frac_denominator
+ (..mantissa -1))
+
+(def: #export frac
+ (-> Rev Frac)
+ (|>> ..mantissa ("lux f64 /" ..frac_denominator)))
+
+(implementation: #export equivalence
+ (Equivalence Rev)
+
+ (def: = ..=))
+
+(implementation: #export hash
+ (Hash Rev)
+
+ (def: &equivalence ..equivalence)
+ (def: hash .nat))
+
+(implementation: #export order
+ (Order Rev)
+
+ (def: &equivalence ..equivalence)
+ (def: < ..<))
+
+(implementation: #export enum
+ (Enum Rev)
+
+ (def: &order ..order)
+ (def: succ inc)
+ (def: pred dec))
+
+(implementation: #export interval
+ (Interval Rev)
+
+ (def: &enum ..enum)
+ (def: top (.rev -1))
+ (def: bottom (.rev 0)))
+
+(template [<name> <compose> <identity>]
+ [(implementation: #export <name>
+ (Monoid Rev)
+
+ (def: identity (\ interval <identity>))
+ (def: compose <compose>))]
+
+ [addition ..+ bottom]
+ [maximum ..max bottom]
+ [minimum ..min top]
+ )
+
+(def: (de_prefix input)
+ (-> Text Text)
+ ("lux text clip" 1 (dec ("lux text size" input)) input))
+
+(template [<struct> <codec> <char_bit_size> <error>]
+ [(with_expansions [<error_output> (as_is (#try.Failure ("lux text concat" <error> repr)))]
+ (implementation: #export <struct>
+ (Codec Text Rev)
+
+ (def: (encode value)
+ (let [raw_output (\ <codec> encode (.nat value))
+ max_num_chars (//nat.+ (//nat./ <char_bit_size> //i64.width)
+ (case (//nat.% <char_bit_size> //i64.width)
+ 0 0
+ _ 1))
+ raw_size ("lux text size" raw_output)
+ zero_padding (: Text
+ (loop [zeroes_left (: Nat (//nat.- raw_size max_num_chars))
+ output (: Text "")]
+ (if (//nat.= 0 zeroes_left)
+ output
+ (recur (dec zeroes_left)
+ ("lux text concat" "0" output)))))]
+ (|> raw_output
+ ("lux text concat" zero_padding)
+ ("lux text concat" "."))))
+
+ (def: (decode repr)
+ (let [repr_size ("lux text size" repr)]
+ (if (//nat.> 1 repr_size)
+ (case ("lux text char" 0 repr)
+ (^ (char "."))
+ (case (\ <codec> decode (de_prefix repr))
+ (#try.Success output)
+ (#try.Success (.rev output))
+
+ _
+ <error_output>)
+
+ _
+ <error_output>)
+ <error_output>)))))]
+
+ [binary //nat.binary 1 "Invalid binary syntax: "]
+ [octal //nat.octal 3 "Invalid octal syntax: "]
+ [hex //nat.hex 4 "Invalid hexadecimal syntax: "]
+ )
+
+## The following code allows one to encode/decode Rev numbers as text.
+## This is not a simple algorithm, and it requires subverting the Rev
+## abstraction a bit.
+## It takes into account the fact that Rev numbers are represented by
+## Lux as 64-bit integers.
+## A valid way to model them is as Lux's Nat type.
+## This is a somewhat hackish way to do things, but it allows one to
+## write the encoding/decoding algorithm once, in pure Lux, rather
+## than having to implement it on the compiler for every platform
+## targeted by Lux.
+(type: Digits (Array Nat))
+
+(def: (digits::new _)
+ (-> Any Digits)
+ (array.new //i64.width))
+
+(def: (digits::get idx digits)
+ (-> Nat Digits Nat)
+ (|> digits (array.read idx) (maybe.default 0)))
+
+(def: digits::put
+ (-> Nat Nat Digits Digits)
+ array.write!)
+
+(def: (prepend left right)
+ (-> Text Text Text)
+ ("lux text concat" left right))
+
+(def: (digits::times_5! idx output)
+ (-> Nat Digits Digits)
+ (loop [idx idx
+ carry 0
+ output output]
+ (if (//int.>= +0 (.int idx))
+ (let [raw (|> (digits::get idx output)
+ (//nat.* 5)
+ (//nat.+ carry))]
+ (recur (dec idx)
+ (//nat./ 10 raw)
+ (digits::put idx (//nat.% 10 raw) output)))
+ output)))
+
+(def: (digits::power power)
+ (-> Nat Digits)
+ (loop [times power
+ output (|> (digits::new [])
+ (digits::put power 1))]
+ (if (//int.>= +0 (.int times))
+ (recur (dec times)
+ (digits::times_5! power output))
+ output)))
+
+(def: (digits::format digits)
+ (-> Digits Text)
+ (loop [idx (dec //i64.width)
+ all_zeroes? true
+ output ""]
+ (if (//int.>= +0 (.int idx))
+ (let [digit (digits::get idx digits)]
+ (if (and (//nat.= 0 digit)
+ all_zeroes?)
+ (recur (dec idx) true output)
+ (recur (dec idx)
+ false
+ ("lux text concat"
+ (\ //nat.decimal encode digit)
+ output))))
+ (if all_zeroes?
+ "0"
+ output))))
+
+(def: (digits::+ param subject)
+ (-> Digits Digits Digits)
+ (loop [idx (dec //i64.width)
+ carry 0
+ output (digits::new [])]
+ (if (//int.>= +0 (.int idx))
+ (let [raw ($_ //nat.+
+ carry
+ (digits::get idx param)
+ (digits::get idx subject))]
+ (recur (dec idx)
+ (//nat./ 10 raw)
+ (digits::put idx (//nat.% 10 raw) output)))
+ output)))
+
+(def: (text_to_digits input)
+ (-> Text (Maybe Digits))
+ (let [length ("lux text size" input)]
+ (if (//nat.<= //i64.width length)
+ (loop [idx 0
+ output (digits::new [])]
+ (if (//nat.< length idx)
+ (case ("lux text index" 0 ("lux text clip" idx 1 input) "0123456789")
+ #.None
+ #.None
+
+ (#.Some digit)
+ (recur (inc idx)
+ (digits::put idx digit output)))
+ (#.Some output)))
+ #.None)))
+
+(def: (digits::< param subject)
+ (-> Digits Digits Bit)
+ (loop [idx 0]
+ (and (//nat.< //i64.width idx)
+ (let [pd (digits::get idx param)
+ sd (digits::get idx subject)]
+ (if (//nat.= pd sd)
+ (recur (inc idx))
+ (//nat.< pd sd))))))
+
+(def: (digits::-!' idx param subject)
+ (-> Nat Nat Digits Digits)
+ (let [sd (digits::get idx subject)]
+ (if (//nat.>= param sd)
+ (digits::put idx (//nat.- param sd) subject)
+ (let [diff (|> sd
+ (//nat.+ 10)
+ (//nat.- param))]
+ (|> subject
+ (digits::put idx diff)
+ (digits::-!' (dec idx) 1))))))
+
+(def: (digits::-! param subject)
+ (-> Digits Digits Digits)
+ (loop [idx (dec //i64.width)
+ output subject]
+ (if (//int.>= +0 (.int idx))
+ (recur (dec idx)
+ (digits::-!' idx (digits::get idx param) output))
+ output)))
+
+(implementation: #export decimal
+ (Codec Text Rev)
+
+ (def: (encode input)
+ (case (.nat input)
+ 0
+ ".0"
+
+ input
+ (let [last_idx (dec //i64.width)]
+ (loop [idx last_idx
+ digits (digits::new [])]
+ (if (//int.>= +0 (.int idx))
+ (if (//i64.set? idx input)
+ (let [digits' (digits::+ (digits::power (//nat.- idx last_idx))
+ digits)]
+ (recur (dec idx)
+ digits'))
+ (recur (dec idx)
+ digits))
+ ("lux text concat" "." (digits::format digits))
+ )))))
+
+ (def: (decode input)
+ (let [dotted? (case ("lux text index" 0 "." input)
+ (#.Some 0)
+ true
+
+ _
+ false)
+ within_limits? (//nat.<= (inc //i64.width)
+ ("lux text size" input))]
+ (if (and dotted? within_limits?)
+ (case (text_to_digits (de_prefix input))
+ (#.Some digits)
+ (loop [digits digits
+ idx 0
+ output 0]
+ (if (//nat.< //i64.width idx)
+ (let [power (digits::power idx)]
+ (if (digits::< power digits)
+ ## Skip power
+ (recur digits (inc idx) output)
+ (recur (digits::-! power digits)
+ (inc idx)
+ (//i64.set (//nat.- idx (dec //i64.width)) output))))
+ (#try.Success (.rev output))))
+
+ #.None
+ (#try.Failure ("lux text concat" "Wrong syntax for Rev: " input)))
+ (#try.Failure ("lux text concat" "Wrong syntax for Rev: " input))))
+ ))
diff --git a/stdlib/source/library/lux/math/random.lux b/stdlib/source/library/lux/math/random.lux
new file mode 100644
index 000000000..8b555e21d
--- /dev/null
+++ b/stdlib/source/library/lux/math/random.lux
@@ -0,0 +1,400 @@
+(.module: {#.doc "Pseudo-random number generation (PRNG) algorithms."}
+ [library
+ [lux (#- or and list i64 nat int rev char)
+ [abstract
+ [hash (#+ Hash)]
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ ["." monad (#+ Monad do)]]
+ [data
+ ["." text (#+ Char) ("#\." monoid)
+ ["." unicode #_
+ ["#" set]]]
+ [collection
+ ["." list ("#\." fold)]
+ ["." array (#+ Array)]
+ ["." dictionary (#+ Dictionary)]
+ ["." queue (#+ Queue)]
+ ["." set (#+ Set)]
+ ["." stack (#+ Stack)]
+ ["." row (#+ Row)]
+ [tree
+ ["." finger (#+ Tree)]]]]
+ [math
+ [number (#+ hex)
+ ["n" nat]
+ ["i" int]
+ ["f" frac]
+ ["r" ratio]
+ ["c" complex]
+ ["." i64]]]
+ ["." time (#+ Time)
+ ["." instant (#+ Instant)]
+ ["." date (#+ Date)]
+ ["." duration (#+ Duration)]
+ ["." month (#+ Month)]
+ ["." day (#+ Day)]]
+ [type
+ [refinement (#+ Refiner Refined)]]]])
+
+(type: #export #rec PRNG
+ {#.doc "An abstract way to represent any PRNG."}
+ (-> Any [PRNG I64]))
+
+(type: #export (Random a)
+ {#.doc "A producer of random values based on a PRNG."}
+ (-> PRNG [PRNG a]))
+
+(implementation: #export functor
+ (Functor Random)
+
+ (def: (map f fa)
+ (function (_ state)
+ (let [[state' a] (fa state)]
+ [state' (f a)]))))
+
+(implementation: #export apply
+ (Apply Random)
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (function (_ state)
+ (let [[state' f] (ff state)
+ [state'' a] (fa state')]
+ [state'' (f a)]))))
+
+(implementation: #export monad
+ (Monad Random)
+
+ (def: &functor ..functor)
+
+ (def: (wrap a)
+ (function (_ state)
+ [state a]))
+
+ (def: (join ffa)
+ (function (_ state)
+ (let [[state' fa] (ffa state)]
+ (fa state')))))
+
+(def: #export (filter pred gen)
+ {#.doc "Retries the generator until the output satisfies a predicate."}
+ (All [a] (-> (-> a Bit) (Random a) (Random a)))
+ (do ..monad
+ [sample gen]
+ (if (pred sample)
+ (wrap sample)
+ (filter pred gen))))
+
+(def: #export (one check random)
+ (All [a b]
+ (-> (-> a (Maybe b)) (Random a) (Random b)))
+ (do ..monad
+ [sample random]
+ (case (check sample)
+ (#.Some output)
+ (wrap output)
+
+ #.None
+ (one check random))))
+
+(def: #export (refine refiner gen)
+ {#.doc "Retries the generator until the output can be refined."}
+ (All [t r] (-> (Refiner t r) (Random t) (Random (Refined t r))))
+ (do ..monad
+ [sample gen]
+ (case (refiner sample)
+ (#.Some refined)
+ (wrap refined)
+
+ #.None
+ (refine refiner gen))))
+
+(def: #export bit
+ (Random Bit)
+ (function (_ prng)
+ (let [[prng output] (prng [])]
+ [prng (|> output (i64.and 1) (n.= 1))])))
+
+(def: #export i64
+ (Random I64)
+ (function (_ prng)
+ (let [[prng left] (prng [])
+ [prng right] (prng [])]
+ [prng (|> left
+ (i64.left_shift 32)
+ ("lux i64 +" right))])))
+
+(template [<name> <type> <cast>]
+ [(def: #export <name>
+ (Random <type>)
+ (\ ..monad map <cast> ..i64))]
+
+ [nat Nat .nat]
+ [int Int .int]
+ [rev Rev .rev]
+ )
+
+(def: #export frac
+ (Random Frac)
+ (\ ..monad map (|>> .i64 f.from_bits) ..nat))
+
+(def: #export safe_frac
+ (Random Frac)
+ (let [mantissa_range (.int (i64.left_shift 53 1))
+ mantissa_max (i.frac (dec mantissa_range))]
+ (\ ..monad map
+ (|>> (i.% mantissa_range)
+ i.frac
+ (f./ mantissa_max))
+ ..int)))
+
+(def: #export (char set)
+ (-> unicode.Set (Random Char))
+ (let [[start end] (unicode.range set)
+ size (n.- start end)
+ in_range (: (-> Char Char)
+ (|>> (n.% size) (n.+ start)))]
+ (|> ..nat
+ (\ ..monad map in_range)
+ (..filter (unicode.member? set)))))
+
+(def: #export (text char_gen size)
+ (-> (Random Char) Nat (Random Text))
+ (if (n.= 0 size)
+ (\ ..monad wrap "")
+ (do ..monad
+ [x char_gen
+ xs (text char_gen (dec size))]
+ (wrap (text\compose (text.from_code x) xs)))))
+
+(template [<name> <set>]
+ [(def: #export <name>
+ (-> Nat (Random Text))
+ (..text (..char <set>)))]
+
+ [unicode unicode.character]
+ [ascii unicode.ascii]
+ [ascii/alpha unicode.ascii/alpha]
+ [ascii/alpha_num unicode.ascii/alpha_num]
+ [ascii/numeric unicode.ascii/numeric]
+ [ascii/upper unicode.ascii/upper]
+ [ascii/lower unicode.ascii/lower]
+ )
+
+(template [<name> <type> <ctor> <gen>]
+ [(def: #export <name>
+ (Random <type>)
+ (do ..monad
+ [left <gen>
+ right <gen>]
+ (wrap (<ctor> left right))))]
+
+ [ratio r.Ratio r.ratio ..nat]
+ [complex c.Complex c.complex ..safe_frac]
+ )
+
+(def: #export (and left right)
+ {#.doc "Sequencing combinator."}
+ (All [a b] (-> (Random a) (Random b) (Random [a b])))
+ (do ..monad
+ [=left left
+ =right right]
+ (wrap [=left =right])))
+
+(def: #export (or left right)
+ {#.doc "Heterogeneous alternative combinator."}
+ (All [a b] (-> (Random a) (Random b) (Random (| a b))))
+ (do {! ..monad}
+ [? bit]
+ (if ?
+ (do !
+ [=left left]
+ (wrap (0 #0 =left)))
+ (do !
+ [=right right]
+ (wrap (0 #1 =right))))))
+
+(def: #export (either left right)
+ {#.doc "Homogeneous alternative combinator."}
+ (All [a] (-> (Random a) (Random a) (Random a)))
+ (do ..monad
+ [? bit]
+ (if ?
+ left
+ right)))
+
+(def: #export (rec gen)
+ {#.doc "A combinator for producing recursive random generators."}
+ (All [a] (-> (-> (Random a) (Random a)) (Random a)))
+ (function (_ state)
+ (let [gen' (gen (rec gen))]
+ (gen' state))))
+
+(def: #export (maybe value_gen)
+ (All [a] (-> (Random a) (Random (Maybe a))))
+ (do {! ..monad}
+ [some? bit]
+ (if some?
+ (do !
+ [value value_gen]
+ (wrap (#.Some value)))
+ (wrap #.None))))
+
+(template [<name> <type> <zero> <plus>]
+ [(def: #export (<name> size value_gen)
+ (All [a] (-> Nat (Random a) (Random (<type> a))))
+ (if (n.> 0 size)
+ (do ..monad
+ [x value_gen
+ xs (<name> (dec size) value_gen)]
+ (wrap (<plus> x xs)))
+ (\ ..monad wrap <zero>)))]
+
+ [list List (.list) #.Cons]
+ [row Row row.empty row.add]
+ )
+
+(template [<name> <type> <ctor>]
+ [(def: #export (<name> size value_gen)
+ (All [a] (-> Nat (Random a) (Random (<type> a))))
+ (do ..monad
+ [values (list size value_gen)]
+ (wrap (|> values <ctor>))))]
+
+ [array Array array.from_list]
+ [queue Queue queue.from_list]
+ [stack Stack (list\fold stack.push stack.empty)]
+ )
+
+(def: #export (set Hash<a> size value_gen)
+ (All [a] (-> (Hash a) Nat (Random a) (Random (Set a))))
+ (if (n.> 0 size)
+ (do {! ..monad}
+ [xs (set Hash<a> (dec size) value_gen)]
+ (loop [_ []]
+ (do !
+ [x value_gen
+ #let [xs+ (set.add x xs)]]
+ (if (n.= size (set.size xs+))
+ (wrap xs+)
+ (recur [])))))
+ (\ ..monad wrap (set.new Hash<a>))))
+
+(def: #export (dictionary Hash<a> size key_gen value_gen)
+ (All [k v] (-> (Hash k) Nat (Random k) (Random v) (Random (Dictionary k v))))
+ (if (n.> 0 size)
+ (do {! ..monad}
+ [kv (dictionary Hash<a> (dec size) key_gen value_gen)]
+ (loop [_ []]
+ (do !
+ [k key_gen
+ v value_gen
+ #let [kv+ (dictionary.put k v kv)]]
+ (if (n.= size (dictionary.size kv+))
+ (wrap kv+)
+ (recur [])))))
+ (\ ..monad wrap (dictionary.new Hash<a>))))
+
+(def: #export instant
+ (Random Instant)
+ (\ ..monad map instant.from_millis ..int))
+
+(def: #export date
+ (Random Date)
+ (\ ..monad map instant.date ..instant))
+
+(def: #export time
+ (Random Time)
+ (\ ..monad map instant.time ..instant))
+
+(def: #export duration
+ (Random Duration)
+ (\ ..monad map duration.from_millis ..int))
+
+(def: #export month
+ (Random Month)
+ (let [(^open "\.") ..monad]
+ (..either (..either (..either (\wrap #month.January)
+ (..either (\wrap #month.February)
+ (\wrap #month.March)))
+ (..either (\wrap #month.April)
+ (..either (\wrap #month.May)
+ (\wrap #month.June))))
+ (..either (..either (\wrap #month.July)
+ (..either (\wrap #month.August)
+ (\wrap #month.September)))
+ (..either (\wrap #month.October)
+ (..either (\wrap #month.November)
+ (\wrap #month.December)))))))
+
+(def: #export day
+ (Random Day)
+ (let [(^open "\.") ..monad]
+ (..either (..either (\wrap #day.Sunday)
+ (..either (\wrap #day.Monday)
+ (\wrap #day.Tuesday)))
+ (..either (..either (\wrap #day.Wednesday)
+ (\wrap #day.Thursday))
+ (..either (\wrap #day.Friday)
+ (\wrap #day.Saturday))))))
+
+(def: #export (run prng calc)
+ (All [a] (-> PRNG (Random a) [PRNG a]))
+ (calc prng))
+
+(def: #export (prng update return)
+ (All [a] (-> (-> a a) (-> a I64) (-> a PRNG)))
+ (function (recur state)
+ (function (_ _)
+ [(recur (update state))
+ (return state)])))
+
+(def: #export (pcg32 [increase seed])
+ {#.doc (doc "An implementation of the PCG32 algorithm."
+ "For more information, please see: http://www.pcg-random.org/")}
+ (-> [(I64 Any) (I64 Any)] PRNG)
+ (let [magic 6364136223846793005]
+ (function (_ _)
+ [(|> seed .nat (n.* magic) ("lux i64 +" increase) [increase] pcg32)
+ (let [rot (|> seed .i64 (i64.right_shift 59))]
+ (|> seed
+ (i64.right_shift 18)
+ (i64.xor seed)
+ (i64.right_shift 27)
+ (i64.rotate_right rot)
+ .i64))])))
+
+(def: #export (xoroshiro_128+ [s0 s1])
+ {#.doc (doc "An implementation of the Xoroshiro128+ algorithm."
+ "For more information, please see: http://xoroshiro.di.unimi.it/")}
+ (-> [(I64 Any) (I64 Any)] PRNG)
+ (function (_ _)
+ [(let [s01 (i64.xor s0 s1)]
+ (xoroshiro_128+ [(|> s0
+ (i64.rotate_left 55)
+ (i64.xor s01)
+ (i64.xor (i64.left_shift 14 s01)))
+ (i64.rotate_left 36 s01)]))
+ ("lux i64 +" s0 s1)]))
+
+## https://en.wikipedia.org/wiki/Xorshift#Initialization
+## http://xorshift.di.unimi.it/splitmix64.c
+(def: #export split_mix_64
+ {#.doc (doc "An implementation of the SplitMix64 algorithm.")}
+ (-> Nat PRNG)
+ (let [twist (: (-> Nat Nat Nat)
+ (function (_ shift value)
+ (i64.xor (i64.right_shift shift value)
+ value)))
+ mix n.*]
+ (..prng (n.+ (hex "9E,37,79,B9,7F,4A,7C,15"))
+ (|>> (twist 30)
+ (mix (hex "BF,58,47,6D,1C,E4,E5,B9"))
+
+ (twist 27)
+ (mix (hex "94,D0,49,BB,13,31,11,EB"))
+
+ (twist 31)
+ .i64))))
diff --git a/stdlib/source/library/lux/meta.lux b/stdlib/source/library/lux/meta.lux
new file mode 100644
index 000000000..b86100325
--- /dev/null
+++ b/stdlib/source/library/lux/meta.lux
@@ -0,0 +1,568 @@
+(.module: {#.doc "Functions for extracting information from the state of the compiler."}
+ [library
+ [lux #*
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ ["." monad (#+ Monad do)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text ("#\." monoid equivalence)]
+ ["." name ("#\." codec equivalence)]
+ [collection
+ ["." list ("#\." monoid monad)]
+ [dictionary
+ ["." plist]]]]
+ [macro
+ ["." code]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]]]]]
+ [/
+ ["." location]])
+
+## (type: (Meta a)
+## (-> Lux (Try [Lux a])))
+
+(implementation: #export functor
+ (Functor Meta)
+
+ (def: (map f fa)
+ (function (_ compiler)
+ (case (fa compiler)
+ (#try.Failure msg)
+ (#try.Failure msg)
+
+ (#try.Success [compiler' a])
+ (#try.Success [compiler' (f a)])))))
+
+(implementation: #export apply
+ (Apply Meta)
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (function (_ compiler)
+ (case (ff compiler)
+ (#try.Success [compiler' f])
+ (case (fa compiler')
+ (#try.Success [compiler'' a])
+ (#try.Success [compiler'' (f a)])
+
+ (#try.Failure msg)
+ (#try.Failure msg))
+
+ (#try.Failure msg)
+ (#try.Failure msg)))))
+
+(implementation: #export monad
+ (Monad Meta)
+
+ (def: &functor ..functor)
+
+ (def: (wrap x)
+ (function (_ compiler)
+ (#try.Success [compiler x])))
+
+ (def: (join mma)
+ (function (_ compiler)
+ (case (mma compiler)
+ (#try.Failure msg)
+ (#try.Failure msg)
+
+ (#try.Success [compiler' ma])
+ (ma compiler')))))
+
+(def: #export (run' compiler action)
+ (All [a] (-> Lux (Meta a) (Try [Lux a])))
+ (action compiler))
+
+(def: #export (run compiler action)
+ (All [a] (-> Lux (Meta a) (Try a)))
+ (case (action compiler)
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success [_ output])
+ (#try.Success output)))
+
+(def: #export (either left right)
+ {#.doc "Pick whichever computation succeeds."}
+ (All [a] (-> (Meta a) (Meta a) (Meta a)))
+ (function (_ compiler)
+ (case (left compiler)
+ (#try.Failure error)
+ (right compiler)
+
+ (#try.Success [compiler' output])
+ (#try.Success [compiler' output]))))
+
+(def: #export (assert message test)
+ {#.doc "Fails with the given message if the test is #0."}
+ (-> Text Bit (Meta Any))
+ (function (_ compiler)
+ (if test
+ (#try.Success [compiler []])
+ (#try.Failure message))))
+
+(def: #export (fail error)
+ {#.doc "Fails with the given error message."}
+ (All [a]
+ (-> Text (Meta a)))
+ (function (_ state)
+ (#try.Failure (location.with (get@ #.location state) error))))
+
+(def: #export (find_module name)
+ (-> Text (Meta Module))
+ (function (_ compiler)
+ (case (plist.get name (get@ #.modules compiler))
+ (#.Some module)
+ (#try.Success [compiler module])
+
+ _
+ (#try.Failure ($_ text\compose "Unknown module: " name)))))
+
+(def: #export current_module_name
+ (Meta Text)
+ (function (_ compiler)
+ (case (get@ #.current_module compiler)
+ (#.Some current_module)
+ (#try.Success [compiler current_module])
+
+ _
+ (#try.Failure "No current module."))))
+
+(def: #export current_module
+ (Meta Module)
+ (let [(^open "\.") ..monad]
+ (|> ..current_module_name
+ (\map ..find_module)
+ \join)))
+
+(def: (macro_type? type)
+ (-> Type Bit)
+ (`` (case type
+ (#.Named [(~~ (static .prelude_module)) "Macro"] (#.Primitive "#Macro" #.Nil))
+ true
+
+ _
+ false)))
+
+(def: #export (normalize name)
+ {#.doc (doc "If given a name without a module prefix, gives it the current module's name as prefix."
+ "Otherwise, returns the name as-is.")}
+ (-> Name (Meta Name))
+ (case name
+ ["" name]
+ (do ..monad
+ [module_name ..current_module_name]
+ (wrap [module_name name]))
+
+ _
+ (\ ..monad wrap name)))
+
+(def: (find_macro' modules this_module module name)
+ (-> (List [Text Module]) Text Text Text
+ (Maybe Macro))
+ (do maybe.monad
+ [$module (plist.get module modules)
+ definition (: (Maybe Global)
+ (|> (: Module $module)
+ (get@ #.definitions)
+ (plist.get name)))]
+ (case definition
+ (#.Alias [r_module r_name])
+ (find_macro' modules this_module r_module r_name)
+
+ (#.Definition [exported? def_type def_anns def_value])
+ (if (macro_type? def_type)
+ (#.Some (:as Macro def_value))
+ #.None))))
+
+(def: #export (find_macro full_name)
+ (-> Name (Meta (Maybe Macro)))
+ (do ..monad
+ [[module name] (normalize full_name)]
+ (: (Meta (Maybe Macro))
+ (function (_ compiler)
+ (let [macro (case (..current_module_name compiler)
+ (#try.Failure error)
+ #.None
+
+ (#try.Success [_ this_module])
+ (find_macro' (get@ #.modules compiler) this_module module name))]
+ (#try.Success [compiler macro]))))))
+
+(def: #export count
+ (Meta Nat)
+ (function (_ compiler)
+ (#try.Success [(update@ #.seed inc compiler)
+ (get@ #.seed compiler)])))
+
+(def: #export (module_exists? module)
+ (-> Text (Meta Bit))
+ (function (_ compiler)
+ (#try.Success [compiler (case (plist.get module (get@ #.modules compiler))
+ (#.Some _)
+ #1
+
+ #.None
+ #0)])))
+
+(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_type_var idx bindings)
+ (-> Nat (List [Nat (Maybe Type)]) (Maybe Type))
+ (case bindings
+ #.Nil
+ #.None
+
+ (#.Cons [var bound] bindings')
+ (if (n.= idx var)
+ bound
+ (find_type_var idx bindings'))))
+
+(def: (clean_type type)
+ (-> Type (Meta Type))
+ (case type
+ (#.Var var)
+ (function (_ compiler)
+ (case (|> compiler
+ (get@ [#.type_context #.var_bindings])
+ (find_type_var var))
+ (^or #.None (#.Some (#.Var _)))
+ (#try.Success [compiler type])
+
+ (#.Some type')
+ (#try.Success [compiler type'])))
+
+ _
+ (\ ..monad wrap type)))
+
+(def: #export (find_var_type name)
+ {#.doc "Looks-up the type of a local variable somewhere in the environment."}
+ (-> Text (Meta Type))
+ (function (_ compiler)
+ (let [test (: (-> [Text [Type Any]] Bit)
+ (|>> product.left (text\= name)))]
+ (case (do maybe.monad
+ [scope (list.find (function (_ env)
+ (or (list.any? test (: (List [Text [Type Any]])
+ (get@ [#.locals #.mappings] env)))
+ (list.any? test (: (List [Text [Type Any]])
+ (get@ [#.captured #.mappings] env)))))
+ (get@ #.scopes compiler))
+ [_ [type _]] (try_both (list.find test)
+ (: (List [Text [Type Any]])
+ (get@ [#.locals #.mappings] scope))
+ (: (List [Text [Type Any]])
+ (get@ [#.captured #.mappings] scope)))]
+ (wrap type))
+ (#.Some var_type)
+ ((clean_type var_type) compiler)
+
+ #.None
+ (#try.Failure ($_ text\compose "Unknown variable: " name))))))
+
+(def: #export (find_def name)
+ {#.doc "Looks-up a definition's whole data in the available modules (including the current one)."}
+ (-> Name (Meta Global))
+ (do ..monad
+ [name (normalize name)
+ #let [[normal_module normal_short] name]]
+ (function (_ compiler)
+ (case (: (Maybe Global)
+ (do maybe.monad
+ [(^slots [#.definitions]) (|> compiler
+ (get@ #.modules)
+ (plist.get normal_module))]
+ (plist.get normal_short definitions)))
+ (#.Some definition)
+ (#try.Success [compiler definition])
+
+ _
+ (let [current_module (|> compiler (get@ #.current_module) (maybe.default "???"))
+ separator ($_ text\compose text.new_line " ")]
+ (#try.Failure ($_ text\compose
+ "Unknown definition: " (name\encode name) text.new_line
+ " Current module: " current_module text.new_line
+ (case (plist.get current_module (get@ #.modules compiler))
+ (#.Some this_module)
+ (let [candidates (|> compiler
+ (get@ #.modules)
+ (list\map (function (_ [module_name module])
+ (|> module
+ (get@ #.definitions)
+ (list.all (function (_ [def_name global])
+ (case global
+ (#.Definition [exported? _ _ _])
+ (if (and exported?
+ (text\= normal_short def_name))
+ (#.Some (name\encode [module_name def_name]))
+ #.None)
+
+ (#.Alias _)
+ #.None))))))
+ list.concat
+ (text.join_with separator))
+ imports (|> this_module
+ (get@ #.imports)
+ (text.join_with separator))
+ aliases (|> this_module
+ (get@ #.module_aliases)
+ (list\map (function (_ [alias real]) ($_ text\compose alias " => " real)))
+ (text.join_with separator))]
+ ($_ text\compose
+ " Candidates: " candidates text.new_line
+ " Imports: " imports text.new_line
+ " Aliases: " aliases text.new_line))
+
+ _
+ "")
+ " All known modules: " (|> compiler (get@ #.modules) (list\map product.left) (text.join_with separator)) text.new_line)))))))
+
+(def: #export (find_export name)
+ {#.doc "Looks-up a definition's type in the available modules (including the current one)."}
+ (-> Name (Meta Definition))
+ (do ..monad
+ [definition (..find_def name)]
+ (case definition
+ (#.Left de_aliased)
+ (fail ($_ text\compose
+ "Aliases are not considered exports: "
+ (name\encode name)))
+
+ (#.Right definition)
+ (let [[exported? def_type def_data def_value] definition]
+ (if exported?
+ (wrap definition)
+ (fail ($_ text\compose "Definition is not an export: " (name\encode name))))))))
+
+(def: #export (find_def_type name)
+ {#.doc "Looks-up a definition's type in the available modules (including the current one)."}
+ (-> Name (Meta Type))
+ (do ..monad
+ [definition (find_def name)]
+ (case definition
+ (#.Left de_aliased)
+ (find_def_type de_aliased)
+
+ (#.Right [exported? def_type def_data def_value])
+ (clean_type def_type))))
+
+(def: #export (find_type name)
+ {#.doc "Looks-up the type of either a local variable or a definition."}
+ (-> Name (Meta Type))
+ (do ..monad
+ [#let [[_ _name] name]]
+ (case name
+ ["" _name]
+ (either (find_var_type _name)
+ (find_def_type name))
+
+ _
+ (find_def_type name))))
+
+(def: #export (find_type_def name)
+ {#.doc "Finds the value of a type definition (such as Int, Any or Lux)."}
+ (-> Name (Meta Type))
+ (do ..monad
+ [definition (find_def name)]
+ (case definition
+ (#.Left de_aliased)
+ (find_type_def de_aliased)
+
+ (#.Right [exported? def_type def_data def_value])
+ (let [type_to_code (`` ("lux in-module" (~~ (static .prelude_module)) .type_to_code))]
+ (if (or (is? .Type def_type)
+ (\ code.equivalence =
+ (type_to_code .Type)
+ (type_to_code def_type)))
+ (wrap (:as Type def_value))
+ (..fail ($_ text\compose "Definition is not a type: " (name\encode name))))))))
+
+(def: #export (globals module)
+ {#.doc "The entire list of globals in a module (including the non-exported/private ones)."}
+ (-> Text (Meta (List [Text Global])))
+ (function (_ compiler)
+ (case (plist.get module (get@ #.modules compiler))
+ #.None
+ (#try.Failure ($_ text\compose "Unknown module: " module))
+
+ (#.Some module)
+ (#try.Success [compiler (get@ #.definitions module)]))))
+
+(def: #export (definitions module)
+ {#.doc "The entire list of definitions in a module (including the non-exported/private ones)."}
+ (-> Text (Meta (List [Text Definition])))
+ (\ ..monad map
+ (list.all (function (_ [name global])
+ (case global
+ (#.Left de_aliased)
+ #.None
+
+ (#.Right definition)
+ (#.Some [name definition]))))
+ (..globals module)))
+
+(def: #export (exports module_name)
+ {#.doc "All the exported definitions in a module."}
+ (-> Text (Meta (List [Text Definition])))
+ (do ..monad
+ [constants (..definitions module_name)]
+ (wrap (do list.monad
+ [[name [exported? def_type def_data def_value]] constants]
+ (if exported?
+ (wrap [name [exported? def_type def_data def_value]])
+ (list))))))
+
+(def: #export modules
+ {#.doc "All the available modules (including the current one)."}
+ (Meta (List [Text Module]))
+ (function (_ compiler)
+ (|> compiler
+ (get@ #.modules)
+ [compiler]
+ #try.Success)))
+
+(def: #export (tags_of type_name)
+ {#.doc "All the tags associated with a type definition."}
+ (-> Name (Meta (Maybe (List Name))))
+ (do ..monad
+ [#let [[module name] type_name]
+ module (find_module module)]
+ (case (plist.get name (get@ #.types module))
+ (#.Some [tags _])
+ (wrap (#.Some tags))
+
+ _
+ (wrap #.None))))
+
+(def: #export location
+ {#.doc "The location of the current expression being analyzed."}
+ (Meta Location)
+ (function (_ compiler)
+ (#try.Success [compiler (get@ #.location compiler)])))
+
+(def: #export expected_type
+ {#.doc "The expected type of the current expression being analyzed."}
+ (Meta Type)
+ (function (_ compiler)
+ (case (get@ #.expected compiler)
+ (#.Some type)
+ (#try.Success [compiler type])
+
+ #.None
+ (#try.Failure "Not expecting any type."))))
+
+(def: #export (imported_modules module_name)
+ {#.doc "All the modules imported by a specified module."}
+ (-> Text (Meta (List Text)))
+ (do ..monad
+ [(^slots [#.imports]) (..find_module module_name)]
+ (wrap imports)))
+
+(def: #export (imported_by? import module)
+ (-> Text Text (Meta Bit))
+ (do ..monad
+ [(^slots [#.imports]) (..find_module module)]
+ (wrap (list.any? (text\= import) imports))))
+
+(def: #export (imported? import)
+ (-> Text (Meta Bit))
+ (\ ..functor map
+ (|>> (get@ #.imports) (list.any? (text\= import)))
+ ..current_module))
+
+(def: #export (resolve_tag tag)
+ {#.doc "Given a tag, finds out what is its index, its related tag-list and its associated type."}
+ (-> Name (Meta [Nat (List Name) Type]))
+ (do ..monad
+ [#let [[module name] tag]
+ =module (..find_module module)
+ this_module_name ..current_module_name
+ imported! (..imported? module)]
+ (case (plist.get name (get@ #.tags =module))
+ (#.Some [idx tag_list exported? type])
+ (if (or (text\= this_module_name module)
+ (and imported! exported?))
+ (wrap [idx tag_list type])
+ (..fail ($_ text\compose "Cannot access tag: " (name\encode tag) " from module " this_module_name)))
+
+ _
+ (..fail ($_ text\compose
+ "Unknown tag: " (name\encode tag) text.new_line
+ " Known tags: " (|> =module
+ (get@ #.tags)
+ (list\map (|>> product.left [module] name\encode (text.prefix text.new_line)))
+ (text.join_with ""))
+ )))))
+
+(def: #export (tag_lists module)
+ {#.doc "All the tag-lists defined in a module, with their associated types."}
+ (-> Text (Meta (List [(List Name) Type])))
+ (do ..monad
+ [=module (..find_module module)
+ this_module_name ..current_module_name]
+ (wrap (|> (get@ #.types =module)
+ (list.filter (function (_ [type_name [tag_list exported? type]])
+ (or exported?
+ (text\= this_module_name module))))
+ (list\map (function (_ [type_name [tag_list exported? type]])
+ [tag_list type]))))))
+
+(def: #export locals
+ {#.doc "All the local variables currently in scope, separated in different scopes."}
+ (Meta (List (List [Text Type])))
+ (function (_ compiler)
+ (case (list.inits (get@ #.scopes compiler))
+ #.None
+ (#try.Failure "No local environment")
+
+ (#.Some scopes)
+ (#try.Success [compiler
+ (list\map (|>> (get@ [#.locals #.mappings])
+ (list\map (function (_ [name [type _]])
+ [name type])))
+ scopes)]))))
+
+(def: #export (un_alias def_name)
+ {#.doc "Given an aliased definition's name, returns the original definition being referenced."}
+ (-> Name (Meta Name))
+ (do ..monad
+ [constant (..find_def def_name)]
+ (wrap (case constant
+ (#.Left real_def_name)
+ real_def_name
+
+ (#.Right _)
+ def_name))))
+
+(def: #export get_compiler
+ {#.doc "Obtains the current state of the compiler."}
+ (Meta Lux)
+ (function (_ compiler)
+ (#try.Success [compiler compiler])))
+
+(def: #export type_context
+ (Meta Type_Context)
+ (function (_ compiler)
+ (#try.Success [compiler (get@ #.type_context compiler)])))
+
+(def: #export (lift result)
+ (All [a] (-> (Try a) (Meta a)))
+ (case result
+ (#try.Success output)
+ (\ ..monad wrap output)
+
+ (#try.Failure error)
+ (..fail error)))
diff --git a/stdlib/source/library/lux/meta/annotation.lux b/stdlib/source/library/lux/meta/annotation.lux
new file mode 100644
index 000000000..1b7ee480b
--- /dev/null
+++ b/stdlib/source/library/lux/meta/annotation.lux
@@ -0,0 +1,95 @@
+(.module:
+ [library
+ [lux (#- nat int rev)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." maybe]
+ ["." name ("#\." equivalence)]]]])
+
+(type: #export Annotation
+ Code)
+
+(def: #export (value tag ann)
+ (-> Name Annotation (Maybe Code))
+ (case ann
+ [_ (#.Record ann)]
+ (loop [ann ann]
+ (case ann
+ (#.Cons [key value] ann')
+ (case key
+ [_ (#.Tag tag')]
+ (if (name\= tag tag')
+ (#.Some value)
+ (recur ann'))
+
+ _
+ (recur ann'))
+
+ #.Nil
+ #.None))
+
+ _
+ #.None))
+
+(template [<name> <tag> <type>]
+ [(def: #export (<name> tag ann)
+ (-> Name Annotation (Maybe <type>))
+ (case (..value tag ann)
+ (#.Some [_ (<tag> value)])
+ (#.Some value)
+
+ _
+ #.None))]
+
+ [bit #.Bit Bit]
+ [nat #.Nat Nat]
+ [int #.Int Int]
+ [rev #.Rev Rev]
+ [frac #.Frac Frac]
+ [text #.Text Text]
+ [identifier #.Identifier Name]
+ [tag #.Tag Name]
+ [form #.Form (List Code)]
+ [tuple #.Tuple (List Code)]
+ [record #.Record (List [Code Code])]
+ )
+
+(def: #export documentation
+ (-> Annotation (Maybe Text))
+ (..text (name_of #.doc)))
+
+(def: #export (flagged? flag)
+ (-> Name Annotation Bit)
+ (|>> (..bit flag) (maybe.default false)))
+
+(template [<name> <tag>]
+ [(def: #export <name>
+ (-> Annotation Bit)
+ (..flagged? (name_of <tag>)))]
+
+ [implementation? #.implementation?]
+ [recursive_type? #.type-rec?]
+ [signature? #.sig?]
+ )
+
+(def: (parse_text input)
+ (-> Code (Maybe Text))
+ (case input
+ [_ (#.Text actual_value)]
+ (#.Some actual_value)
+
+ _
+ #.None))
+
+(template [<name> <tag>]
+ [(def: #export (<name> ann)
+ (-> Annotation (List Text))
+ (maybe.default (list)
+ (do {! maybe.monad}
+ [args (..tuple (name_of <tag>) ann)]
+ (monad.map ! ..parse_text args))))]
+
+ [function_arguments #.func-args]
+ [type_arguments #.type-args]
+ )
diff --git a/stdlib/source/library/lux/meta/location.lux b/stdlib/source/library/lux/meta/location.lux
new file mode 100644
index 000000000..ddc40b147
--- /dev/null
+++ b/stdlib/source/library/lux/meta/location.lux
@@ -0,0 +1,49 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]]])
+
+(implementation: #export equivalence
+ (Equivalence Location)
+
+ (def: (= reference subject)
+ (and ("lux text =" (get@ #.module reference) (get@ #.module subject))
+ ("lux i64 =" (get@ #.line reference) (get@ #.line subject))
+ ("lux i64 =" (get@ #.column reference) (get@ #.column subject)))))
+
+(def: #export dummy
+ Location
+ {#.module ""
+ #.line 0
+ #.column 0})
+
+(macro: #export (here tokens compiler)
+ (case tokens
+ #.Nil
+ (let [location (get@ #.location compiler)]
+ (#.Right [compiler
+ (list (` [(~ [..dummy (#.Text (get@ #.module location))])
+ (~ [..dummy (#.Nat (get@ #.line location))])
+ (~ [..dummy (#.Nat (get@ #.column location))])]))]))
+
+ _
+ (#.Left (`` (("lux in-module" (~~ (static .prelude_module)) wrong_syntax_error) (name_of ..here))))))
+
+(def: #export (format value)
+ (-> Location Text)
+ (let [separator ","
+ [file line column] value]
+ ($_ "lux text concat"
+ "@"
+ (`` (("lux in-module" (~~ (static .prelude_module)) .text\encode) file)) separator
+ (`` (("lux in-module" (~~ (static .prelude_module)) .nat\encode) line)) separator
+ (`` (("lux in-module" (~~ (static .prelude_module)) .nat\encode) column)))))
+
+(def: \n
+ ("lux i64 char" +10))
+
+(def: #export (with location error)
+ (-> Location Text Text)
+ ($_ "lux text concat" (..format location) \n
+ error))
diff --git a/stdlib/source/library/lux/program.lux b/stdlib/source/library/lux/program.lux
new file mode 100644
index 000000000..bd486796b
--- /dev/null
+++ b/stdlib/source/library/lux/program.lux
@@ -0,0 +1,83 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io]
+ [concurrency
+ ["." thread]]
+ ["<>" parser
+ ["<.>" code]
+ ["<.>" cli]]]
+ [data
+ ["." text]
+ [collection
+ ["." list ("#\." monad)]]]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]]]])
+
+(type: Arguments
+ (#Raw Text)
+ (#Parsed (List [Code Code])))
+
+(def: arguments^
+ (<code>.Parser Arguments)
+ (<>.or <code>.local_identifier
+ (<code>.tuple (<>.some (<>.either (do <>.monad
+ [name <code>.local_identifier]
+ (wrap [(code.identifier ["" name]) (` (~! <cli>.any))]))
+ (<code>.record (<>.and <code>.any <code>.any)))))))
+
+(syntax: #export (program:
+ {args ..arguments^}
+ 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/control/parser/cli module."
+ (program: all_args
+ (do io.monad
+ [foo init_program
+ bar (do_something all_args)]
+ (wrap [])))
+
+ (program: [name]
+ (io (log! (\ text.monoid compose "Hello, " name))))
+
+ (program: [{config configuration_parser}]
+ (do io.monad
+ [data (init_program config)]
+ (do_something data))))}
+ (with_gensyms [g!program g!args g!_ g!output g!message]
+ (let [initialization+event_loop
+ (` ((~! do) (~! io.monad)
+ [(~ g!output) (~ body)
+ (~+ (for {@.old (list)
+ @.jvm (list)
+ @.js (list)
+ @.python (list)}
+ (list g!_ (` (~! thread.run!)))))]
+ ((~' wrap) (~ g!output))))]
+ (wrap (list (` ("lux def program"
+ (~ (case args
+ (#Raw args)
+ (` (.function ((~ g!program) (~ (code.identifier ["" args])))
+ (~ initialization+event_loop)))
+
+ (#Parsed args)
+ (` (.function ((~ g!program) (~ g!args))
+ (case ((~! <cli>.run) (: (~! (<cli>.Parser (io.IO .Any)))
+ ((~! do) (~! <>.monad)
+ [(~+ (|> args
+ (list\map (function (_ [binding parser])
+ (list binding parser)))
+ list\join))]
+ ((~' wrap) (~ initialization+event_loop))))
+ (~ g!args))
+ (#.Right (~ g!output))
+ (~ g!output)
+
+ (#.Left (~ g!message))
+ (.error! (~ g!message))))))))))))))
diff --git a/stdlib/source/library/lux/target.lux b/stdlib/source/library/lux/target.lux
new file mode 100644
index 000000000..323cf812b
--- /dev/null
+++ b/stdlib/source/library/lux/target.lux
@@ -0,0 +1,26 @@
+(.module:
+ [library
+ lux])
+
+(type: #export Target
+ Text)
+
+(template [<name> <value>]
+ [(def: #export <name>
+ Target
+ <value>)]
+
+ ## TODO: Delete ASAP.
+ [old "{old}"]
+ ## Available.
+ [js "JavaScript"]
+ [jvm "JVM"]
+ [lua "Lua"]
+ [python "Python"]
+ [ruby "Ruby"]
+ ## Not available yet.
+ [common_lisp "Common Lisp"]
+ [php "PHP"]
+ [r "R"]
+ [scheme "Scheme"]
+ )
diff --git a/stdlib/source/library/lux/target/common_lisp.lux b/stdlib/source/library/lux/target/common_lisp.lux
new file mode 100644
index 000000000..2ec6746c2
--- /dev/null
+++ b/stdlib/source/library/lux/target/common_lisp.lux
@@ -0,0 +1,469 @@
+(.module:
+ [library
+ [lux (#- Code int if cond or and comment let)
+ [control
+ [pipe (#+ case> cond> new>)]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." monad fold monoid)]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["f" frac]]]
+ [type
+ abstract]]])
+
+(def: as_form
+ (-> Text Text)
+ (text.enclose ["(" ")"]))
+
+(abstract: #export (Code brand)
+ Text
+
+ (def: #export manual
+ (-> Text Code)
+ (|>> :abstraction))
+
+ (def: #export code
+ (-> (Code Any) Text)
+ (|>> :representation))
+
+ (template [<type> <super>]
+ [(with_expansions [<brand> (template.identifier [<type> "'"])]
+ (`` (abstract: #export (<brand> brand) Any))
+ (`` (type: #export (<type> brand)
+ (<super> (<brand> brand)))))]
+
+ [Expression Code]
+ [Computation Expression]
+ [Access Computation]
+ [Var Access]
+
+ [Input Code]
+ )
+
+ (template [<type> <super>]
+ [(with_expansions [<brand> (template.identifier [<type> "'"])]
+ (`` (abstract: #export <brand> Any))
+ (`` (type: #export <type> (<super> <brand>))))]
+
+ [Label Code]
+ [Tag Expression]
+ [Literal Expression]
+ [Var/1 Var]
+ [Var/* Input]
+ )
+
+ (type: #export Lambda
+ {#input Var/*
+ #output (Expression Any)})
+
+ (def: #export nil
+ Literal
+ (:abstraction "()"))
+
+ (template [<prefix> <name>]
+ [(def: #export <name>
+ (-> Text Literal)
+ (|>> (format <prefix>) :abstraction))]
+
+ ["'" symbol]
+ [":" keyword])
+
+ (def: #export bool
+ (-> Bit Literal)
+ (|>> (case> #0 ..nil
+ #1 (..symbol "t"))))
+
+ (def: #export int
+ (-> Int Literal)
+ (|>> %.int :abstraction))
+
+ (def: #export float
+ (-> Frac Literal)
+ (|>> (cond> [(f.= f.positive_infinity)]
+ [(new> "(/ 1.0 0.0)" [])]
+
+ [(f.= f.negative_infinity)]
+ [(new> "(/ -1.0 0.0)" [])]
+
+ [f.not_a_number?]
+ [(new> "(/ 0.0 0.0)" [])]
+
+ ## else
+ [%.frac])
+ :abstraction))
+
+ (def: #export (double value)
+ (-> Frac Literal)
+ (:abstraction
+ (.cond (f.= f.positive_infinity value)
+ "(/ 1.0d0 0.0d0)"
+
+ (f.= f.negative_infinity value)
+ "(/ -1.0d0 0.0d0)"
+
+ (f.not_a_number? value)
+ "(/ 0.0d0 0.0d0)"
+
+ ## else
+ (.let [raw (%.frac value)]
+ (.if (text.contains? "E" raw)
+ (text.replace_once "E" "d" raw)
+ (format raw "d0"))))))
+
+ (def: sanitize
+ (-> Text Text)
+ (`` (|>> (~~ (template [<find> <replace>]
+ [(text.replace_all <find> <replace>)]
+
+ ["\" "\\"]
+ [text.tab "\t"]
+ [text.vertical_tab "\v"]
+ [text.null "\0"]
+ [text.back_space "\b"]
+ [text.form_feed "\f"]
+ [text.new_line "\n"]
+ [text.carriage_return "\r"]
+ [text.double_quote (format "\" text.double_quote)]
+ ))
+ )))
+
+ (def: #export string
+ (-> Text Literal)
+ (|>> ..sanitize
+ (text.enclose' text.double_quote)
+ :abstraction))
+
+ (def: #export var
+ (-> Text Var/1)
+ (|>> :abstraction))
+
+ (def: #export args
+ (-> (List Var/1) Var/*)
+ (|>> (list\map ..code)
+ (text.join_with " ")
+ ..as_form
+ :abstraction))
+
+ (def: #export (args& singles rest)
+ (-> (List Var/1) Var/1 Var/*)
+ (|> (case singles
+ #.Nil
+ ""
+
+ (#.Cons _)
+ (|> singles
+ (list\map ..code)
+ (text.join_with " ")
+ (text.suffix " ")))
+ (format "&rest " (:representation rest))
+ ..as_form
+ :abstraction))
+
+ (def: form
+ (-> (List (Expression Any)) Expression)
+ (|>> (list\map ..code)
+ (text.join_with " ")
+ ..as_form
+ :abstraction))
+
+ (def: #export (call/* func)
+ (-> (Expression Any) (-> (List (Expression Any)) (Computation Any)))
+ (|>> (#.Cons func) ..form))
+
+ (template [<name> <function>]
+ [(def: #export <name>
+ (-> (List (Expression Any)) (Computation Any))
+ (..call/* (..var <function>)))]
+
+ [vector/* "vector"]
+ [list/* "list"]
+ )
+
+ (def: #export (labels definitions body)
+ (-> (List [Var/1 Lambda]) (Expression Any) (Computation Any))
+ (..form (list (..var "labels")
+ (..form (list\map (function (_ [def_name [def_args def_body]])
+ (..form (list def_name (:transmutation def_args) def_body)))
+ definitions))
+ body)))
+
+ (def: #export (destructuring-bind [bindings expression] body)
+ (-> [Var/* (Expression Any)] (List (Expression Any)) (Computation Any))
+ (..form (list& (..var "destructuring-bind")
+ (:transmutation bindings) expression
+ body)))
+
+ (template [<call> <input_var>+ <input_type>+ <function>+]
+ [(`` (def: #export (<call> [(~~ (template.splice <input_var>+))] function)
+ (-> [(~~ (template.splice <input_type>+))] (Expression Any) (Computation Any))
+ (..call/* function (list (~~ (template.splice <input_var>+))))))
+
+ (`` (template [<lux_name> <host_name>]
+ [(def: #export (<lux_name> args)
+ (-> [(~~ (template.splice <input_type>+))] (Computation Any))
+ (<call> args (..var <host_name>)))]
+
+ (~~ (template.splice <function>+))))]
+
+ [call/0 [] []
+ [[get-universal-time/0 "get-universal-time"]
+ [make-hash-table/0 "make-hash-table"]]]
+ [call/1 [in0] [(Expression Any)]
+ [[length/1 "length"]
+ [function/1 "function"]
+ [copy-seq/1 "copy-seq"]
+ [null/1 "null"]
+ [error/1 "error"]
+ [not/1 "not"]
+ [floor/1 "floor"]
+ [type-of/1 "type-of"]
+ [write-to-string/1 "write-to-string"]
+ [read-from-string/1 "read-from-string"]
+ [print/1 "print"]
+ [reverse/1 "reverse"]
+ [sxhash/1 "sxhash"]
+ [string-upcase/1 "string-upcase"]
+ [string-downcase/1 "string-downcase"]
+ [char-int/1 "char-int"]
+ [text/1 "text"]
+ [hash-table-size/1 "hash-table-size"]
+ [hash-table-rehash-size/1 "hash-table-rehash-size"]
+ [code-char/1 "code-char"]
+ [char-code/1 "char-code"]
+ [string/1 "string"]
+ [write-line/1 "write-line"]
+ [pprint/1 "pprint"]
+ [identity/1 "identity"]]]
+ [call/2 [in0 in1] [(Expression Any) (Expression Any)]
+ [[apply/2 "apply"]
+ [append/2 "append"]
+ [cons/2 "cons"]
+ [char/2 "char"]
+ [nth/2 "nth"]
+ [nthcdr/2 "nthcdr"]
+ [coerce/2 "coerce"]
+ [eq/2 "eq"]
+ [equal/2 "equal"]
+ [string=/2 "string="]
+ [=/2 "="]
+ [+/2 "+"]
+ [*/2 "*"]]]
+ [call/3 [in0 in1 in2] [(Expression Any) (Expression Any) (Expression Any)]
+ [[subseq/3 "subseq"]
+ [map/3 "map"]
+ [concatenate/3 "concatenate"]
+ [format/3 "format"]]]
+ )
+
+ (template [<call> <input_type>+ <function>+]
+ [(`` (template [<lux_name> <host_name>]
+ [(def: #export (<lux_name> args)
+ (-> [(~~ (template.splice <input_type>+))] (Access Any))
+ (:transmutation (<call> args (..var <host_name>))))]
+
+ (~~ (template.splice <function>+))))]
+
+ [call/1 [(Expression Any)]
+ [[car/1 "car"]
+ [cdr/1 "cdr"]
+ [cadr/1 "cadr"]
+ [cddr/1 "cddr"]]]
+ [call/2 [(Expression Any) (Expression Any)]
+ [[svref/2 "svref"]
+ [elt/2 "elt"]
+ [gethash/2 "gethash"]]]
+ )
+
+ (def: #export (make-hash-table/with_size size)
+ (-> (Expression Any) (Computation Any))
+ (..call/* (..var "make-hash-table")
+ (list (..keyword "size")
+ size)))
+
+ (def: #export (funcall/+ [func args])
+ (-> [(Expression Any) (List (Expression Any))] (Computation Any))
+ (..call/* (..var "funcall") (list& func args)))
+
+ (def: #export (search/3 [reference space start])
+ (-> [(Expression Any) (Expression Any) (Expression Any)] (Computation Any))
+ (..call/* (..var "search")
+ (list reference
+ space
+ (..keyword "start2") start)))
+
+ (def: #export (concatenate/2|string [left right])
+ (-> [(Expression Any) (Expression Any)] (Computation Any))
+ (concatenate/3 [(..symbol "string") left right]))
+
+ (template [<lux_name> <host_name>]
+ [(def: #export (<lux_name> left right)
+ (-> (Expression Any) (Expression Any) (Computation Any))
+ (..form (list (..var <host_name>) left right)))]
+
+ [or "or"]
+ [and "and"]
+ )
+
+ (template [<lux_name> <host_name>]
+ [(def: #export (<lux_name> [param subject])
+ (-> [(Expression Any) (Expression Any)] (Computation Any))
+ (..form (list (..var <host_name>) subject param)))]
+
+ [</2 "<"]
+ [<=/2 "<="]
+ [>/2 ">"]
+ [>=/2 ">="]
+ [string</2 "string<"]
+ [-/2 "-"]
+ [//2 "/"]
+ [rem/2 "rem"]
+ [floor/2 "floor"]
+ [mod/2 "mod"]
+ [ash/2 "ash"]
+ [logand/2 "logand"]
+ [logior/2 "logior"]
+ [logxor/2 "logxor"]
+ )
+
+ (def: #export (if test then else)
+ (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any))
+ (..form (list (..var "if") test then else)))
+
+ (def: #export (when test then)
+ (-> (Expression Any) (Expression Any) (Computation Any))
+ (..form (list (..var "when") test then)))
+
+ (def: #export (lambda input body)
+ (-> Var/* (Expression Any) Literal)
+ (..form (list (..var "lambda") (:transmutation input) body)))
+
+ (template [<lux_name> <host_name>]
+ [(def: #export (<lux_name> bindings body)
+ (-> (List [Var/1 (Expression Any)]) (List (Expression Any)) (Computation Any))
+ (..form (list& (..var <host_name>)
+ (|> bindings
+ (list\map (function (_ [name value])
+ (..form (list name value))))
+ ..form)
+ body)))]
+
+ [let "let"]
+ [let* "let*"]
+ )
+
+ (def: #export (defparameter name body)
+ (-> Var/1 (Expression Any) (Expression Any))
+ (..form (list (..var "defparameter") name body)))
+
+ (def: #export (defun name inputs body)
+ (-> Var/1 Var/* (Expression Any) (Expression Any))
+ (..form (list (..var "defun") name (:transmutation inputs) body)))
+
+ (template [<name> <symbol>]
+ [(def: #export <name>
+ (-> (List (Expression Any)) (Computation Any))
+ (|>> (list& (..var <symbol>)) ..form))]
+
+ [progn "progn"]
+ [tagbody "tagbody"]
+ [values/* "values"]
+ )
+
+ (def: #export (setq name value)
+ (-> Var/1 (Expression Any) (Expression Any))
+ (..form (list (..var "setq") name value)))
+
+ (def: #export (setf access value)
+ (-> (Access Any) (Expression Any) (Expression Any))
+ (..form (list (..var "setf") access value)))
+
+ (type: #export Handler
+ {#condition_type (Expression Any)
+ #condition Var/1
+ #body (Expression Any)})
+
+ (def: #export (handler-case handlers body)
+ (-> (List Handler) (Expression Any) (Computation Any))
+ (..form (list& (..var "handler-case")
+ body
+ (list\map (function (_ [type condition handler])
+ (..form (list type
+ (:transmutation (..args (list condition)))
+ handler)))
+ handlers))))
+
+ (template [<name> <prefix>]
+ [(def: #export (<name> conditions expression)
+ (-> (List Text) (Expression Any) (Expression Any))
+ (case conditions
+ #.Nil
+ expression
+
+ (#.Cons single #.Nil)
+ (:abstraction
+ (format <prefix> single " " (:representation expression)))
+
+ _
+ (:abstraction
+ (format <prefix> (|> conditions (list\map ..symbol)
+ (list& (..symbol "or")) ..form
+ :representation)
+ " " (:representation expression)))))]
+
+ [conditional+ "#+"]
+ [conditional- "#-"])
+
+ (def: #export label
+ (-> Text Label)
+ (|>> :abstraction))
+
+ (def: #export (block name body)
+ (-> Label (List (Expression Any)) (Computation Any))
+ (..form (list& (..var "block") (:transmutation name) body)))
+
+ (def: #export (return-from target value)
+ (-> Label (Expression Any) (Computation Any))
+ (..form (list (..var "return-from") (:transmutation target) value)))
+
+ (def: #export (return value)
+ (-> (Expression Any) (Computation Any))
+ (..form (list (..var "return") value)))
+
+ (def: #export (cond clauses else)
+ (-> (List [(Expression Any) (Expression Any)]) (Expression Any) (Computation Any))
+ (..form (list& (..var "cond")
+ (list\compose (list\map (function (_ [test then])
+ (..form (list test then)))
+ clauses)
+ (list (..form (list (..bool true) else)))))))
+
+ (def: #export tag
+ (-> Text Tag)
+ (|>> :abstraction))
+
+ (def: #export go
+ (-> Tag (Expression Any))
+ (|>> (list (..var "go"))
+ ..form))
+
+ (def: #export values-list/1
+ (-> (Expression Any) (Expression Any))
+ (|>> (list (..var "values-list"))
+ ..form))
+
+ (def: #export (multiple-value-setq bindings values)
+ (-> Var/* (Expression Any) (Expression Any))
+ (..form (list (..var "multiple-value-setq")
+ (:transmutation bindings)
+ values)))
+ )
+
+(def: #export (while condition body)
+ (-> (Expression Any) (Expression Any) (Computation Any))
+ (..form (list (..var "loop") (..var "while") condition
+ (..var "do") body)))
diff --git a/stdlib/source/library/lux/target/js.lux b/stdlib/source/library/lux/target/js.lux
new file mode 100644
index 000000000..d7b42280c
--- /dev/null
+++ b/stdlib/source/library/lux/target/js.lux
@@ -0,0 +1,449 @@
+(.module:
+ [library
+ [lux (#- Location Code or and function if cond undefined for comment not int try)
+ [control
+ [pipe (#+ case>)]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["i" int]
+ ["f" frac]]]
+ [type
+ abstract]]])
+
+(def: expression (text.enclose ["(" ")"]))
+(def: element (text.enclose ["[" "]"]))
+
+(def: nest
+ (-> Text Text)
+ (|>> (format text.new_line)
+ (text.replace_all text.new_line (format text.new_line text.tab))))
+
+(abstract: #export (Code brand)
+ Text
+
+ (def: #export code
+ (-> (Code Any) Text)
+ (|>> :representation))
+
+ (template [<type> <super>+]
+ [(with_expansions [<brand> (template.identifier [<type> "'"])]
+ (abstract: (<brand> brand) Any)
+ (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))]
+
+ [Expression [Code]]
+ [Computation [Expression' Code]]
+ [Location [Computation' Expression' Code]]
+ [Statement [Code]]
+ )
+
+ (template [<type> <super>+]
+ [(with_expansions [<brand> (template.identifier [<type> "'"])]
+ (abstract: #export <brand> Any)
+ (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))]
+
+ [Var [Location' Computation' Expression' Code]]
+ [Access [Location' Computation' Expression' Code]]
+ [Literal [Computation' Expression' Code]]
+ [Loop [Statement' Code]]
+ [Label [Code]]
+ )
+
+ (template [<name> <literal>]
+ [(def: #export <name> Literal (:abstraction <literal>))]
+
+ [null "null"]
+ [undefined "undefined"]
+ )
+
+ (def: #export boolean
+ (-> Bit Literal)
+ (|>> (case>
+ #0 "false"
+ #1 "true")
+ :abstraction))
+
+ (def: #export (number value)
+ (-> Frac Literal)
+ (:abstraction
+ (.cond (f.not_a_number? value)
+ "NaN"
+
+ (f.= f.positive_infinity value)
+ "Infinity"
+
+ (f.= f.negative_infinity value)
+ "-Infinity"
+
+ ## else
+ (|> value %.frac ..expression))))
+
+ (def: sanitize
+ (-> Text Text)
+ (`` (|>> (~~ (template [<replace> <find>]
+ [(text.replace_all <find> <replace>)]
+
+ ["\\" "\"]
+ ["\t" text.tab]
+ ["\v" text.vertical_tab]
+ ["\0" text.null]
+ ["\b" text.back_space]
+ ["\f" text.form_feed]
+ ["\n" text.new_line]
+ ["\r" text.carriage_return]
+ [(format "\" text.double_quote)
+ text.double_quote]
+ ))
+ )))
+
+ (def: #export string
+ (-> Text Literal)
+ (|>> ..sanitize
+ (text.enclose [text.double_quote text.double_quote])
+ :abstraction))
+
+ (def: argument_separator ", ")
+ (def: field_separator ": ")
+ (def: statement_suffix ";")
+
+ (def: #export array
+ (-> (List Expression) Computation)
+ (|>> (list\map ..code)
+ (text.join_with ..argument_separator)
+ ..element
+ :abstraction))
+
+ (def: #export var
+ (-> Text Var)
+ (|>> :abstraction))
+
+ (def: #export (at index array_or_object)
+ (-> Expression Expression Access)
+ (:abstraction (format (:representation array_or_object) (..element (:representation index)))))
+
+ (def: #export (the field object)
+ (-> Text Expression Access)
+ (:abstraction (format (:representation object) "." field)))
+
+ (def: #export (apply/* function inputs)
+ (-> Expression (List Expression) Computation)
+ (|> inputs
+ (list\map ..code)
+ (text.join_with ..argument_separator)
+ ..expression
+ (format (:representation function))
+ :abstraction))
+
+ (def: #export (do method inputs object)
+ (-> Text (List Expression) Expression Computation)
+ (apply/* (..the method object) inputs))
+
+ (def: #export object
+ (-> (List [Text Expression]) Computation)
+ (|>> (list\map (.function (_ [key val])
+ (format (:representation (..string key)) ..field_separator (:representation val))))
+ (text.join_with ..argument_separator)
+ (text.enclose ["{" "}"])
+ ..expression
+ :abstraction))
+
+ (def: #export (, pre post)
+ (-> Expression Expression Computation)
+ (|> (format (:representation pre) ..argument_separator (:representation post))
+ ..expression
+ :abstraction))
+
+ (def: #export (then pre post)
+ (-> Statement Statement Statement)
+ (:abstraction (format (:representation pre)
+ text.new_line
+ (:representation post))))
+
+ (def: block
+ (-> Statement Text)
+ (let [close (format text.new_line "}")]
+ (|>> :representation
+ ..nest
+ (text.enclose ["{"
+ close]))))
+
+ (def: #export (function! name inputs body)
+ (-> Var (List Var) Statement Statement)
+ (|> body
+ ..block
+ (format "function " (:representation name)
+ (|> inputs
+ (list\map ..code)
+ (text.join_with ..argument_separator)
+ ..expression)
+ " ")
+ :abstraction))
+
+ (def: #export (function name inputs body)
+ (-> Var (List Var) Statement Computation)
+ (|> (..function! name inputs body)
+ :representation
+ ..expression
+ :abstraction))
+
+ (def: #export (closure inputs body)
+ (-> (List Var) Statement Computation)
+ (|> body
+ ..block
+ (format "function"
+ (|> inputs
+ (list\map ..code)
+ (text.join_with ..argument_separator)
+ ..expression)
+ " ")
+ ..expression
+ :abstraction))
+
+ (template [<name> <op>]
+ [(def: #export (<name> param subject)
+ (-> Expression Expression Computation)
+ (|> (format (:representation subject) " " <op> " " (:representation param))
+ ..expression
+ :abstraction))]
+
+ [= "==="]
+ [< "<"]
+ [<= "<="]
+ [> ">"]
+ [>= ">="]
+
+ [+ "+"]
+ [- "-"]
+ [* "*"]
+ [/ "/"]
+ [% "%"]
+
+ [left_shift "<<"]
+ [arithmetic_right_shift ">>"]
+ [logic_right_shift ">>>"]
+
+ [or "||"]
+ [and "&&"]
+ [bit_xor "^"]
+ [bit_or "|"]
+ [bit_and "&"]
+ )
+
+ (template [<name> <prefix>]
+ [(def: #export <name>
+ (-> Expression Computation)
+ (|>> :representation (text.prefix <prefix>) ..expression :abstraction))]
+
+ [not "!"]
+ [bit_not "~"]
+ [negate "-"]
+ )
+
+ (template [<name> <input> <format>]
+ [(def: #export (<name> value)
+ {#.doc "A 32-bit integer expression."}
+ (-> <input> Computation)
+ (:abstraction (..expression (format (<format> value) "|0"))))]
+
+ [to_i32 Expression :representation]
+ [i32 Int %.int]
+ )
+
+ (def: #export (int value)
+ (-> Int Literal)
+ (:abstraction (.if (i.< +0 value)
+ (%.int value)
+ (%.nat (.nat value)))))
+
+ (def: #export (? test then else)
+ (-> Expression Expression Expression Computation)
+ (|> (format (:representation test)
+ " ? " (:representation then)
+ " : " (:representation else))
+ ..expression
+ :abstraction))
+
+ (def: #export type_of
+ (-> Expression Computation)
+ (|>> :representation
+ (format "typeof ")
+ ..expression
+ :abstraction))
+
+ (def: #export (new constructor inputs)
+ (-> Expression (List Expression) Computation)
+ (|> (format "new " (:representation constructor)
+ (|> inputs
+ (list\map ..code)
+ (text.join_with ..argument_separator)
+ ..expression))
+ ..expression
+ :abstraction))
+
+ (def: #export statement
+ (-> Expression Statement)
+ (|>> :representation (text.suffix ..statement_suffix) :abstraction))
+
+ (def: #export use_strict
+ Statement
+ (:abstraction (format text.double_quote "use strict" text.double_quote ..statement_suffix)))
+
+ (def: #export (declare name)
+ (-> Var Statement)
+ (:abstraction (format "var " (:representation name) ..statement_suffix)))
+
+ (def: #export (define name value)
+ (-> Var Expression Statement)
+ (:abstraction (format "var " (:representation name) " = " (:representation value) ..statement_suffix)))
+
+ (def: #export (set' name value)
+ (-> Location Expression Expression)
+ (:abstraction (..expression (format (:representation name) " = " (:representation value)))))
+
+ (def: #export (set name value)
+ (-> Location Expression Statement)
+ (:abstraction (format (:representation name) " = " (:representation value) ..statement_suffix)))
+
+ (def: #export (throw message)
+ (-> Expression Statement)
+ (:abstraction (format "throw " (:representation message) ..statement_suffix)))
+
+ (def: #export (return value)
+ (-> Expression Statement)
+ (:abstraction (format "return " (:representation value) ..statement_suffix)))
+
+ (def: #export (delete' value)
+ (-> Location Expression)
+ (:abstraction (format "delete " (:representation value))))
+
+ (def: #export (delete value)
+ (-> Location Statement)
+ (:abstraction (format (:representation (delete' value)) ..statement_suffix)))
+
+ (def: #export (if test then! else!)
+ (-> Expression Statement Statement Statement)
+ (:abstraction (format "if(" (:representation test) ") "
+ (..block then!)
+ " else "
+ (..block else!))))
+
+ (def: #export (when test then!)
+ (-> Expression Statement Statement)
+ (:abstraction (format "if(" (:representation test) ") "
+ (..block then!))))
+
+ (def: #export (while test body)
+ (-> Expression Statement Loop)
+ (:abstraction (format "while(" (:representation test) ") "
+ (..block body))))
+
+ (def: #export (do_while test body)
+ (-> Expression Statement Loop)
+ (:abstraction (format "do " (..block body)
+ " while(" (:representation test) ")" ..statement_suffix)))
+
+ (def: #export (try body [exception catch])
+ (-> Statement [Var Statement] Statement)
+ (:abstraction (format "try "
+ (..block body)
+ " catch(" (:representation exception) ") "
+ (..block catch))))
+
+ (def: #export (for var init condition update iteration)
+ (-> Var Expression Expression Expression Statement Loop)
+ (:abstraction (format "for(" (:representation (..define var init))
+ " " (:representation condition)
+ ..statement_suffix " " (:representation update)
+ ")"
+ (..block iteration))))
+
+ (def: #export label
+ (-> Text Label)
+ (|>> :abstraction))
+
+ (def: #export (with_label label loop)
+ (-> Label Loop Statement)
+ (:abstraction (format (:representation label) ": " (:representation loop))))
+
+ (template [<keyword> <0> <1>]
+ [(def: #export <0>
+ Statement
+ (:abstraction (format <keyword> ..statement_suffix)))
+
+ (def: #export (<1> label)
+ (-> Label Statement)
+ (:abstraction (format <keyword> " " (:representation label) ..statement_suffix)))]
+
+ ["break" break break_at]
+ ["continue" continue continue_at]
+ )
+
+ (template [<name> <js>]
+ [(def: #export <name>
+ (-> Location Expression)
+ (|>> :representation
+ (text.suffix <js>)
+ :abstraction))]
+
+ [++ "++"]
+ [-- "--"]
+ )
+
+ (def: #export (comment commentary on)
+ (All [kind] (-> Text (Code kind) (Code kind)))
+ (:abstraction (format "/* " commentary " */" " " (:representation on))))
+
+ (def: #export (switch input cases default)
+ (-> Expression (List [(List Literal) Statement]) (Maybe Statement) Statement)
+ (:abstraction (format "switch (" (:representation input) ") "
+ (|> (format (|> cases
+ (list\map (.function (_ [when then])
+ (format (|> when
+ (list\map (|>> :representation (text.enclose ["case " ":"])))
+ (text.join_with text.new_line))
+ (..nest (:representation then)))))
+ (text.join_with text.new_line))
+ text.new_line
+ (case default
+ (#.Some default)
+ (format "default:"
+ (..nest (:representation default)))
+
+ #.None ""))
+ :abstraction
+ ..block))))
+ )
+
+(def: #export (cond clauses else!)
+ (-> (List [Expression Statement]) Statement Statement)
+ (list\fold (.function (_ [test then!] next!)
+ (..if test then! next!))
+ else!
+ (list.reverse clauses)))
+
+(template [<apply> <arg>+ <type>+ <function>+]
+ [(`` (def: #export (<apply> function)
+ (-> Expression (~~ (template.splice <type>+)) Computation)
+ (.function (_ (~~ (template.splice <arg>+)))
+ (..apply/* function (list (~~ (template.splice <arg>+)))))))
+
+ (`` (template [<definition> <function>]
+ [(def: #export <definition> (<apply> (..var <function>)))]
+
+ (~~ (template.splice <function>+))))]
+
+ [apply/1 [_0] [Expression]
+ [[not_a_number? "isNaN"]]]
+
+ [apply/2 [_0 _1] [Expression Expression]
+ []]
+
+ [apply/3 [_0 _1 _2] [Expression Expression Expression]
+ []]
+ )
diff --git a/stdlib/source/library/lux/target/jvm.lux b/stdlib/source/library/lux/target/jvm.lux
new file mode 100644
index 000000000..b470abea9
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm.lux
@@ -0,0 +1,284 @@
+(.module:
+ [library
+ [lux (#- Type)
+ [data
+ [collection
+ [row (#+ Row)]]]
+ [target
+ [jvm
+ [type (#+ Type)
+ ["." category (#+ Primitive Class Value Method)]]]]]])
+
+(type: #export Literal
+ (#Boolean Bit)
+ (#Int Int)
+ (#Long Int)
+ (#Double Frac)
+ (#Char Nat)
+ (#String Text))
+
+(type: #export Constant
+ (#BIPUSH Int)
+
+ (#SIPUSH Int)
+
+ #ICONST_M1
+ #ICONST_0
+ #ICONST_1
+ #ICONST_2
+ #ICONST_3
+ #ICONST_4
+ #ICONST_5
+
+ #LCONST_0
+ #LCONST_1
+
+ #FCONST_0
+ #FCONST_1
+ #FCONST_2
+
+ #DCONST_0
+ #DCONST_1
+
+ #ACONST_NULL
+
+ (#LDC Literal))
+
+(type: #export Int_Arithmetic
+ #IADD
+ #ISUB
+ #IMUL
+ #IDIV
+ #IREM
+ #INEG)
+
+(type: #export Long_Arithmetic
+ #LADD
+ #LSUB
+ #LMUL
+ #LDIV
+ #LREM
+ #LNEG)
+
+(type: #export Float_Arithmetic
+ #FADD
+ #FSUB
+ #FMUL
+ #FDIV
+ #FREM
+ #FNEG)
+
+(type: #export Double_Arithmetic
+ #DADD
+ #DSUB
+ #DMUL
+ #DDIV
+ #DREM
+ #DNEG)
+
+(type: #export Arithmetic
+ (#Int_Arithmetic Int_Arithmetic)
+ (#Long_Arithmetic Long_Arithmetic)
+ (#Float_Arithmetic Float_Arithmetic)
+ (#Double_Arithmetic Double_Arithmetic))
+
+(type: #export Int_Bitwise
+ #IOR
+ #IXOR
+ #IAND
+ #ISHL
+ #ISHR
+ #IUSHR)
+
+(type: #export Long_Bitwise
+ #LOR
+ #LXOR
+ #LAND
+ #LSHL
+ #LSHR
+ #LUSHR)
+
+(type: #export Bitwise
+ (#Int_Bitwise Int_Bitwise)
+ (#Long_Bitwise Long_Bitwise))
+
+(type: #export Conversion
+ #I2B
+ #I2S
+ #I2L
+ #I2F
+ #I2D
+ #I2C
+
+ #L2I
+ #L2F
+ #L2D
+
+ #F2I
+ #F2L
+ #F2D
+
+ #D2I
+ #D2L
+ #D2F)
+
+(type: #export Array
+ #ARRAYLENGTH
+
+ (#NEWARRAY (Type Primitive))
+ (#ANEWARRAY (Type category.Object))
+
+ #BALOAD
+ #BASTORE
+
+ #SALOAD
+ #SASTORE
+
+ #IALOAD
+ #IASTORE
+
+ #LALOAD
+ #LASTORE
+
+ #FALOAD
+ #FASTORE
+
+ #DALOAD
+ #DASTORE
+
+ #CALOAD
+ #CASTORE
+
+ #AALOAD
+ #AASTORE)
+
+(type: #export Object
+ (#GETSTATIC (Type Class) Text (Type Value))
+ (#PUTSTATIC (Type Class) Text (Type Value))
+
+ (#NEW (Type Class))
+
+ (#INSTANCEOF (Type Class))
+ (#CHECKCAST (Type category.Object))
+
+ (#GETFIELD (Type Class) Text (Type Value))
+ (#PUTFIELD (Type Class) Text (Type Value))
+
+ (#INVOKEINTERFACE (Type Class) Text (Type Method))
+ (#INVOKESPECIAL (Type Class) Text (Type Method))
+ (#INVOKESTATIC (Type Class) Text (Type Method))
+ (#INVOKEVIRTUAL (Type Class) Text (Type Method)))
+
+(type: #export Register Nat)
+
+(type: #export Local_Int
+ (#ILOAD Register)
+ (#ISTORE Register))
+
+(type: #export Local_Long
+ (#LLOAD Register)
+ (#LSTORE Register))
+
+(type: #export Local_Float
+ (#FLOAD Register)
+ (#FSTORE Register))
+
+(type: #export Local_Double
+ (#DLOAD Register)
+ (#DSTORE Register))
+
+(type: #export Local_Object
+ (#ALOAD Register)
+ (#ASTORE Register))
+
+(type: #export Local
+ (#Local_Int Local_Int)
+ (#IINC Register)
+ (#Local_Long Local_Long)
+ (#Local_Float Local_Float)
+ (#Local_Double Local_Double)
+ (#Local_Object Local_Object))
+
+(type: #export Stack
+ #DUP
+ #DUP_X1
+ #DUP_X2
+ #DUP2
+ #DUP2_X1
+ #DUP2_X2
+ #SWAP
+ #POP
+ #POP2)
+
+(type: #export Comparison
+ #LCMP
+
+ #FCMPG
+ #FCMPL
+
+ #DCMPG
+ #DCMPL)
+
+(type: #export Label Nat)
+
+(type: #export (Branching label)
+ (#IF_ICMPEQ label)
+ (#IF_ICMPGE label)
+ (#IF_ICMPGT label)
+ (#IF_ICMPLE label)
+ (#IF_ICMPLT label)
+ (#IF_ICMPNE label)
+ (#IFEQ label)
+ (#IFNE label)
+ (#IFGE label)
+ (#IFGT label)
+ (#IFLE label)
+ (#IFLT label)
+
+ (#TABLESWITCH Int Int label (List label))
+ (#LOOKUPSWITCH label (List [Int label]))
+
+ (#IF_ACMPEQ label)
+ (#IF_ACMPNE label)
+ (#IFNONNULL label)
+ (#IFNULL label))
+
+(type: #export (Exception label)
+ (#Try label label label (Type Class))
+ #ATHROW)
+
+(type: #export Concurrency
+ #MONITORENTER
+ #MONITOREXIT)
+
+(type: #export Return
+ #RETURN
+ #IRETURN
+ #LRETURN
+ #FRETURN
+ #DRETURN
+ #ARETURN)
+
+(type: #export (Control label)
+ (#GOTO label)
+ (#Branching (Branching label))
+ (#Exception (Exception label))
+ (#Concurrency Concurrency)
+ (#Return Return))
+
+(type: #export (Instruction embedded label)
+ #NOP
+ (#Constant Constant)
+ (#Arithmetic Arithmetic)
+ (#Bitwise Bitwise)
+ (#Conversion Conversion)
+ (#Array Array)
+ (#Object Object)
+ (#Local Local)
+ (#Stack Stack)
+ (#Comparison Comparison)
+ (#Control (Control label))
+ (#Embedded embedded))
+
+(type: #export (Bytecode embedded label)
+ (Row (Instruction embedded label)))
diff --git a/stdlib/source/library/lux/target/jvm/attribute.lux b/stdlib/source/library/lux/target/jvm/attribute.lux
new file mode 100644
index 000000000..9869a6f8b
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/attribute.lux
@@ -0,0 +1,123 @@
+(.module:
+ [library
+ [lux (#- Info Code)
+ [abstract
+ [monad (#+ do)]
+ ["." equivalence (#+ Equivalence)]]
+ [control
+ ["." try]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." sum]
+ ["." product]
+ [format
+ [".F" binary (#+ Writer)]]]
+ [math
+ [number
+ ["n" nat]]]]]
+ ["." // #_
+ ["#." index (#+ Index)]
+ [encoding
+ ["#." unsigned (#+ U2 U4)]]
+ ["#." constant (#+ UTF8 Class Value)
+ ["#/." pool (#+ Pool Resource)]]]
+ ["." / #_
+ ["#." constant (#+ Constant)]
+ ["#." code]])
+
+(type: #export (Info about)
+ {#name (Index UTF8)
+ #length U4
+ #info about})
+
+(def: #export (info_equivalence Equivalence<about>)
+ (All [about]
+ (-> (Equivalence about)
+ (Equivalence (Info about))))
+ ($_ product.equivalence
+ //index.equivalence
+ //unsigned.equivalence
+ Equivalence<about>))
+
+(def: (info_writer writer)
+ (All [about]
+ (-> (Writer about)
+ (Writer (Info about))))
+ (function (_ [name length info])
+ (let [[nameS nameT] (//index.writer name)
+ [lengthS lengthT] (//unsigned.writer/4 length)
+ [infoS infoT] (writer info)]
+ [($_ n.+ nameS lengthS infoS)
+ (|>> nameT lengthT infoT)])))
+
+(with_expansions [<Code> (as_is (/code.Code Attribute))]
+ (type: #export #rec Attribute
+ (#Constant (Info (Constant Any)))
+ (#Code (Info <Code>)))
+
+ (type: #export Code
+ <Code>)
+ )
+
+(def: #export equivalence
+ (Equivalence Attribute)
+ (equivalence.rec
+ (function (_ equivalence)
+ ($_ sum.equivalence
+ (info_equivalence /constant.equivalence)
+ (info_equivalence (/code.equivalence equivalence))))))
+
+(def: common_attribute_length
+ ($_ n.+
+ ## u2 attribute_name_index;
+ //unsigned.bytes/2
+ ## u4 attribute_length;
+ //unsigned.bytes/4
+ ))
+
+(def: (length attribute)
+ (-> Attribute Nat)
+ (case attribute
+ (^template [<tag>]
+ [(<tag> [name length info])
+ (|> length //unsigned.value (n.+ ..common_attribute_length))])
+ ([#Constant] [#Code])))
+
+## TODO: Inline ASAP
+(def: (constant' @name index)
+ (-> (Index UTF8) (Constant Any) Attribute)
+ (#Constant {#name @name
+ #length (|> /constant.length //unsigned.u4 try.assume)
+ #info index}))
+
+(def: #export (constant index)
+ (-> (Constant Any) (Resource Attribute))
+ (do //constant/pool.monad
+ [@name (//constant/pool.utf8 "ConstantValue")]
+ (wrap (constant' @name index))))
+
+## TODO: Inline ASAP
+(def: (code' @name specification)
+ (-> (Index UTF8) Code Attribute)
+ (#Code {#name @name
+ ## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3
+ #length (|> specification
+ (/code.length ..length)
+ //unsigned.u4
+ try.assume)
+ #info specification}))
+
+(def: #export (code specification)
+ (-> Code (Resource Attribute))
+ (do //constant/pool.monad
+ [@name (//constant/pool.utf8 "Code")]
+ (wrap (code' @name specification))))
+
+(def: #export (writer value)
+ (Writer Attribute)
+ (case value
+ (#Constant attribute)
+ ((info_writer /constant.writer) attribute)
+
+ (#Code attribute)
+ ((info_writer (/code.writer writer)) attribute)))
diff --git a/stdlib/source/library/lux/target/jvm/attribute/code.lux b/stdlib/source/library/lux/target/jvm/attribute/code.lux
new file mode 100644
index 000000000..80cc7a6ad
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/attribute/code.lux
@@ -0,0 +1,83 @@
+(.module:
+ [library
+ [lux (#- Code)
+ [type (#+ :share)]
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." product]
+ ["." binary (#+ Binary)]
+ [format
+ [".F" binary (#+ Writer) ("#\." monoid)]]
+ [collection
+ ["." row (#+ Row) ("#\." functor fold)]]]
+ [math
+ [number
+ ["n" nat]]]]]
+ ["." /// #_
+ [bytecode
+ [environment
+ ["#." limit (#+ Limit)]]]
+ [encoding
+ ["#." unsigned (#+ U2)]]]
+ ["." / #_
+ ["#." exception (#+ Exception)]])
+
+(type: #export (Code Attribute)
+ {#limit Limit
+ #code Binary
+ #exception_table (Row Exception)
+ #attributes (Row Attribute)})
+
+(def: #export (length length code)
+ (All [Attribute] (-> (-> Attribute Nat) (Code Attribute) Nat))
+ ($_ n.+
+ ## u2 max_stack;
+ ## u2 max_locals;
+ ///limit.length
+ ## u4 code_length;
+ ///unsigned.bytes/4
+ ## u1 code[code_length];
+ (binary.size (get@ #code code))
+ ## u2 exception_table_length;
+ ///unsigned.bytes/2
+ ## exception_table[exception_table_length];
+ (|> code
+ (get@ #exception_table)
+ row.size
+ (n.* /exception.length))
+ ## u2 attributes_count;
+ ///unsigned.bytes/2
+ ## attribute_info attributes[attributes_count];
+ (|> code
+ (get@ #attributes)
+ (row\map length)
+ (row\fold n.+ 0))))
+
+(def: #export (equivalence attribute_equivalence)
+ (All [attribute]
+ (-> (Equivalence attribute) (Equivalence (Code attribute))))
+ ($_ product.equivalence
+ ///limit.equivalence
+ binary.equivalence
+ (row.equivalence /exception.equivalence)
+ (row.equivalence attribute_equivalence)
+ ))
+
+## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3
+(def: #export (writer writer code)
+ (All [Attribute] (-> (Writer Attribute) (Writer (Code Attribute))))
+ ($_ binaryF\compose
+ ## u2 max_stack;
+ ## u2 max_locals;
+ (///limit.writer (get@ #limit code))
+ ## u4 code_length;
+ ## u1 code[code_length];
+ (binaryF.binary/32 (get@ #code code))
+ ## u2 exception_table_length;
+ ## exception_table[exception_table_length];
+ ((binaryF.row/16 /exception.writer) (get@ #exception_table code))
+ ## u2 attributes_count;
+ ## attribute_info attributes[attributes_count];
+ ((binaryF.row/16 writer) (get@ #attributes code))
+ ))
diff --git a/stdlib/source/library/lux/target/jvm/attribute/code/exception.lux b/stdlib/source/library/lux/target/jvm/attribute/code/exception.lux
new file mode 100644
index 000000000..e2aa089b0
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/attribute/code/exception.lux
@@ -0,0 +1,58 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." product]
+ ["." format #_
+ ["#" binary (#+ Writer)]]]
+ [math
+ [number
+ ["n" nat]]]]]
+ ["." // #_
+ ["//#" /// #_
+ [constant (#+ Class)]
+ ["#." index (#+ Index)]
+ [bytecode
+ ["#." address (#+ Address)]]
+ [encoding
+ ["#." unsigned (#+ U2)]]]])
+
+(type: #export Exception
+ {#start Address
+ #end Address
+ #handler Address
+ #catch (Index Class)})
+
+(def: #export equivalence
+ (Equivalence Exception)
+ ($_ product.equivalence
+ ////address.equivalence
+ ////address.equivalence
+ ////address.equivalence
+ ////index.equivalence
+ ))
+
+## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3
+(def: #export length
+ Nat
+ ($_ n.+
+ ## u2 start_pc;
+ ////unsigned.bytes/2
+ ## u2 end_pc;
+ ////unsigned.bytes/2
+ ## u2 handler_pc;
+ ////unsigned.bytes/2
+ ## u2 catch_type;
+ ////unsigned.bytes/2
+ ))
+
+(def: #export writer
+ (Writer Exception)
+ ($_ format.and
+ ////address.writer
+ ////address.writer
+ ////address.writer
+ ////index.writer
+ ))
diff --git a/stdlib/source/library/lux/target/jvm/attribute/constant.lux b/stdlib/source/library/lux/target/jvm/attribute/constant.lux
new file mode 100644
index 000000000..d9f26d418
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/attribute/constant.lux
@@ -0,0 +1,27 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ [format
+ [binary (#+ Writer)]]]]]
+ ["." /// #_
+ [constant (#+ Value)]
+ ["#." index (#+ Index)]
+ [encoding
+ ["#." unsigned (#+ U2 U4)]]])
+
+(type: #export (Constant a)
+ (Index (Value a)))
+
+(def: #export equivalence
+ (All [a] (Equivalence (Constant a)))
+ ///index.equivalence)
+
+(def: #export length
+ ///index.length)
+
+(def: #export writer
+ (All [a] (Writer (Constant a)))
+ ///index.writer)
diff --git a/stdlib/source/library/lux/target/jvm/bytecode.lux b/stdlib/source/library/lux/target/jvm/bytecode.lux
new file mode 100644
index 000000000..c50278c28
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/bytecode.lux
@@ -0,0 +1,1046 @@
+(.module:
+ [library
+ [lux (#- Type int try)
+ ["." ffi (#+ import:)]
+ [abstract
+ [monoid (#+ Monoid)]
+ ["." monad (#+ Monad do)]]
+ [control
+ ["." writer (#+ Writer)]
+ ["." state (#+ State')]
+ ["." function]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." product]
+ ["." maybe]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." dictionary (#+ Dictionary)]
+ ["." row (#+ Row)]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]
+ ["." i32 (#+ I32)]]]]]
+ ["." / #_
+ ["#." address (#+ Address)]
+ ["#." jump (#+ Jump Big_Jump)]
+ ["_" instruction (#+ Primitive_Array_Type Instruction Estimator) ("#\." monoid)]
+ ["#." environment (#+ Environment)
+ [limit
+ ["/." registry (#+ Register Registry)]
+ ["/." stack (#+ Stack)]]]
+ ["/#" // #_
+ ["#." index (#+ Index)]
+ [encoding
+ ["#." name]
+ ["#." unsigned (#+ U1 U2)]
+ ["#." signed (#+ S1 S2 S4)]]
+ ["#." constant (#+ UTF8)
+ ["#/." pool (#+ Pool Resource)]]
+ [attribute
+ [code
+ ["#." exception (#+ Exception)]]]
+ ["." type (#+ Type)
+ [category (#+ Class Object Value' Value Return' Return Method)]
+ ["." reflection]
+ ["." parser]]]])
+
+(type: #export Label Nat)
+
+(type: #export Resolver (Dictionary Label [Stack (Maybe Address)]))
+
+(type: #export Tracker
+ {#program_counter Address
+ #next Label
+ #known Resolver})
+
+(def: fresh
+ Tracker
+ {#program_counter /address.start
+ #next 0
+ #known (dictionary.new n.hash)})
+
+(type: #export Relative
+ (-> Resolver (Try [(Row Exception) Instruction])))
+
+(def: no_exceptions
+ (Row Exception)
+ row.empty)
+
+(def: relative_identity
+ Relative
+ (function.constant (#try.Success [..no_exceptions _.empty])))
+
+(implementation: relative_monoid
+ (Monoid Relative)
+
+ (def: identity ..relative_identity)
+
+ (def: (compose left right)
+ (cond (is? ..relative_identity left)
+ right
+
+ (is? ..relative_identity right)
+ left
+
+ ## else
+ (function (_ resolver)
+ (do try.monad
+ [[left_exceptions left_instruction] (left resolver)
+ [right_exceptions right_instruction] (right resolver)]
+ (wrap [(\ row.monoid compose left_exceptions right_exceptions)
+ (_\compose left_instruction right_instruction)]))))))
+
+(type: #export (Bytecode a)
+ (State' Try [Pool Environment Tracker] (Writer Relative a)))
+
+(def: #export new_label
+ (Bytecode Label)
+ (function (_ [pool environment tracker])
+ (#try.Success [[pool
+ environment
+ (update@ #next inc tracker)]
+ [..relative_identity
+ (get@ #next tracker)]])))
+
+(exception: #export (label_has_already_been_set {label Label})
+ (exception.report
+ ["Label" (%.nat label)]))
+
+(exception: #export (mismatched_environments {instruction Name}
+ {label Label}
+ {address Address}
+ {expected Stack}
+ {actual Stack})
+ (exception.report
+ ["Instruction" (%.name instruction)]
+ ["Label" (%.nat label)]
+ ["Address" (/address.format address)]
+ ["Expected" (/stack.format expected)]
+ ["Actual" (/stack.format actual)]))
+
+(with_expansions [<success> (as_is (wrap [[pool
+ environment
+ (update@ #known
+ (dictionary.put label [actual (#.Some @here)])
+ tracker)]
+ [..relative_identity
+ []]]))]
+ (def: #export (set_label label)
+ (-> Label (Bytecode Any))
+ (function (_ [pool environment tracker])
+ (let [@here (get@ #program_counter tracker)]
+ (case (dictionary.get label (get@ #known tracker))
+ (#.Some [expected (#.Some address)])
+ (exception.throw ..label_has_already_been_set [label])
+
+ (#.Some [expected #.None])
+ (do try.monad
+ [[actual environment] (/environment.continue expected environment)]
+ <success>)
+
+ #.None
+ (do try.monad
+ [[actual environment] (/environment.continue (|> environment
+ (get@ #/environment.stack)
+ (maybe.default /stack.empty))
+ environment)]
+ <success>))))))
+
+(def: #export monad
+ (Monad Bytecode)
+ (<| (:as (Monad Bytecode))
+ (writer.with ..relative_monoid)
+ (: (Monad (State' Try [Pool Environment Tracker])))
+ state.with
+ (: (Monad Try))
+ try.monad))
+
+(def: #export fail
+ (-> Text Bytecode)
+ (|>> #try.Failure function.constant))
+
+(def: #export (throw exception value)
+ (All [e] (-> (exception.Exception e) e Bytecode))
+ (..fail (exception.construct exception value)))
+
+(def: #export (resolve environment bytecode)
+ (All [a] (-> Environment (Bytecode a) (Resource [Environment (Row Exception) Instruction a])))
+ (function (_ pool)
+ (do try.monad
+ [[[pool environment tracker] [relative output]] (bytecode [pool environment ..fresh])
+ [exceptions instruction] (relative (get@ #known tracker))]
+ (wrap [pool [environment exceptions instruction output]]))))
+
+(def: (step estimator counter)
+ (-> Estimator Address (Try Address))
+ (/address.move (estimator counter) counter))
+
+(def: (bytecode consumption production registry [estimator bytecode] input)
+ (All [a] (-> U2 U2 Registry [Estimator (-> [a] Instruction)] [a] (Bytecode Any)))
+ (function (_ [pool environment tracker])
+ (do {! try.monad}
+ [environment' (|> environment
+ (/environment.consumes consumption)
+ (monad.bind ! (/environment.produces production))
+ (monad.bind ! (/environment.has registry)))
+ program_counter' (step estimator (get@ #program_counter tracker))]
+ (wrap [[pool
+ environment'
+ (set@ #program_counter program_counter' tracker)]
+ [(function.constant (wrap [..no_exceptions (bytecode input)]))
+ []]]))))
+
+(template [<name> <frames>]
+ [(def: <name> U2 (|> <frames> //unsigned.u2 try.assume))]
+
+ [$0 0]
+ [$1 1]
+ [$2 2]
+ [$3 3]
+ [$4 4]
+ [$5 5]
+ [$6 6]
+ )
+
+(template [<name> <registry>]
+ [(def: <name> Registry (|> <registry> //unsigned.u2 try.assume /registry.registry))]
+
+ [@_ 0]
+ [@0 1]
+ [@1 2]
+ [@2 3]
+ [@3 4]
+ [@4 5]
+ )
+
+(template [<name> <consumption> <production> <registry> <instruction>]
+ [(def: #export <name>
+ (Bytecode Any)
+ (..bytecode <consumption>
+ <production>
+ <registry>
+ <instruction>
+ []))]
+
+ [nop $0 $0 @_ _.nop]
+
+ [aconst_null $0 $1 @_ _.aconst_null]
+
+ [iconst_m1 $0 $1 @_ _.iconst_m1]
+ [iconst_0 $0 $1 @_ _.iconst_0]
+ [iconst_1 $0 $1 @_ _.iconst_1]
+ [iconst_2 $0 $1 @_ _.iconst_2]
+ [iconst_3 $0 $1 @_ _.iconst_3]
+ [iconst_4 $0 $1 @_ _.iconst_4]
+ [iconst_5 $0 $1 @_ _.iconst_5]
+
+ [lconst_0 $0 $2 @_ _.lconst_0]
+ [lconst_1 $0 $2 @_ _.lconst_1]
+
+ [fconst_0 $0 $1 @_ _.fconst_0]
+ [fconst_1 $0 $1 @_ _.fconst_1]
+ [fconst_2 $0 $1 @_ _.fconst_2]
+
+ [dconst_0 $0 $2 @_ _.dconst_0]
+ [dconst_1 $0 $2 @_ _.dconst_1]
+
+ [pop $1 $0 @_ _.pop]
+ [pop2 $2 $0 @_ _.pop2]
+
+ [dup $1 $2 @_ _.dup]
+ [dup_x1 $2 $3 @_ _.dup_x1]
+ [dup_x2 $3 $4 @_ _.dup_x2]
+ [dup2 $2 $4 @_ _.dup2]
+ [dup2_x1 $3 $5 @_ _.dup2_x1]
+ [dup2_x2 $4 $6 @_ _.dup2_x2]
+
+ [swap $2 $2 @_ _.swap]
+
+ [iaload $2 $1 @_ _.iaload]
+ [laload $2 $2 @_ _.laload]
+ [faload $2 $1 @_ _.faload]
+ [daload $2 $2 @_ _.daload]
+ [aaload $2 $1 @_ _.aaload]
+ [baload $2 $1 @_ _.baload]
+ [caload $2 $1 @_ _.caload]
+ [saload $2 $1 @_ _.saload]
+
+ [iload_0 $0 $1 @0 _.iload_0]
+ [iload_1 $0 $1 @1 _.iload_1]
+ [iload_2 $0 $1 @2 _.iload_2]
+ [iload_3 $0 $1 @3 _.iload_3]
+
+ [lload_0 $0 $2 @1 _.lload_0]
+ [lload_1 $0 $2 @2 _.lload_1]
+ [lload_2 $0 $2 @3 _.lload_2]
+ [lload_3 $0 $2 @4 _.lload_3]
+
+ [fload_0 $0 $1 @0 _.fload_0]
+ [fload_1 $0 $1 @1 _.fload_1]
+ [fload_2 $0 $1 @2 _.fload_2]
+ [fload_3 $0 $1 @3 _.fload_3]
+
+ [dload_0 $0 $2 @1 _.dload_0]
+ [dload_1 $0 $2 @2 _.dload_1]
+ [dload_2 $0 $2 @3 _.dload_2]
+ [dload_3 $0 $2 @4 _.dload_3]
+
+ [aload_0 $0 $1 @0 _.aload_0]
+ [aload_1 $0 $1 @1 _.aload_1]
+ [aload_2 $0 $1 @2 _.aload_2]
+ [aload_3 $0 $1 @3 _.aload_3]
+
+ [iastore $3 $1 @_ _.iastore]
+ [lastore $4 $1 @_ _.lastore]
+ [fastore $3 $1 @_ _.fastore]
+ [dastore $4 $1 @_ _.dastore]
+ [aastore $3 $1 @_ _.aastore]
+ [bastore $3 $1 @_ _.bastore]
+ [castore $3 $1 @_ _.castore]
+ [sastore $3 $1 @_ _.sastore]
+
+ [istore_0 $1 $0 @0 _.istore_0]
+ [istore_1 $1 $0 @1 _.istore_1]
+ [istore_2 $1 $0 @2 _.istore_2]
+ [istore_3 $1 $0 @3 _.istore_3]
+
+ [lstore_0 $2 $0 @1 _.lstore_0]
+ [lstore_1 $2 $0 @2 _.lstore_1]
+ [lstore_2 $2 $0 @3 _.lstore_2]
+ [lstore_3 $2 $0 @4 _.lstore_3]
+
+ [fstore_0 $1 $0 @0 _.fstore_0]
+ [fstore_1 $1 $0 @1 _.fstore_1]
+ [fstore_2 $1 $0 @2 _.fstore_2]
+ [fstore_3 $1 $0 @3 _.fstore_3]
+
+ [dstore_0 $2 $0 @1 _.dstore_0]
+ [dstore_1 $2 $0 @2 _.dstore_1]
+ [dstore_2 $2 $0 @3 _.dstore_2]
+ [dstore_3 $2 $0 @4 _.dstore_3]
+
+ [astore_0 $1 $0 @0 _.astore_0]
+ [astore_1 $1 $0 @1 _.astore_1]
+ [astore_2 $1 $0 @2 _.astore_2]
+ [astore_3 $1 $0 @3 _.astore_3]
+
+ [iadd $2 $1 @_ _.iadd]
+ [isub $2 $1 @_ _.isub]
+ [imul $2 $1 @_ _.imul]
+ [idiv $2 $1 @_ _.idiv]
+ [irem $2 $1 @_ _.irem]
+ [ineg $1 $1 @_ _.ineg]
+ [iand $2 $1 @_ _.iand]
+ [ior $2 $1 @_ _.ior]
+ [ixor $2 $1 @_ _.ixor]
+ [ishl $2 $1 @_ _.ishl]
+ [ishr $2 $1 @_ _.ishr]
+ [iushr $2 $1 @_ _.iushr]
+
+ [ladd $4 $2 @_ _.ladd]
+ [lsub $4 $2 @_ _.lsub]
+ [lmul $4 $2 @_ _.lmul]
+ [ldiv $4 $2 @_ _.ldiv]
+ [lrem $4 $2 @_ _.lrem]
+ [lneg $2 $2 @_ _.lneg]
+ [land $4 $2 @_ _.land]
+ [lor $4 $2 @_ _.lor]
+ [lxor $4 $2 @_ _.lxor]
+ [lshl $3 $2 @_ _.lshl]
+ [lshr $3 $2 @_ _.lshr]
+ [lushr $3 $2 @_ _.lushr]
+
+ [fadd $2 $1 @_ _.fadd]
+ [fsub $2 $1 @_ _.fsub]
+ [fmul $2 $1 @_ _.fmul]
+ [fdiv $2 $1 @_ _.fdiv]
+ [frem $2 $1 @_ _.frem]
+ [fneg $1 $1 @_ _.fneg]
+
+ [dadd $4 $2 @_ _.dadd]
+ [dsub $4 $2 @_ _.dsub]
+ [dmul $4 $2 @_ _.dmul]
+ [ddiv $4 $2 @_ _.ddiv]
+ [drem $4 $2 @_ _.drem]
+ [dneg $2 $2 @_ _.dneg]
+
+ [l2i $2 $1 @_ _.l2i]
+ [l2f $2 $1 @_ _.l2f]
+ [l2d $2 $2 @_ _.l2d]
+
+ [f2i $1 $1 @_ _.f2i]
+ [f2l $1 $2 @_ _.f2l]
+ [f2d $1 $2 @_ _.f2d]
+
+ [d2i $2 $1 @_ _.d2i]
+ [d2l $2 $2 @_ _.d2l]
+ [d2f $2 $1 @_ _.d2f]
+
+ [i2l $1 $2 @_ _.i2l]
+ [i2f $1 $1 @_ _.i2f]
+ [i2d $1 $2 @_ _.i2d]
+ [i2b $1 $1 @_ _.i2b]
+ [i2c $1 $1 @_ _.i2c]
+ [i2s $1 $1 @_ _.i2s]
+
+ [lcmp $4 $1 @_ _.lcmp]
+
+ [fcmpl $2 $1 @_ _.fcmpl]
+ [fcmpg $2 $1 @_ _.fcmpg]
+
+ [dcmpl $4 $1 @_ _.dcmpl]
+ [dcmpg $4 $1 @_ _.dcmpg]
+
+ [arraylength $1 $1 @_ _.arraylength]
+
+ [monitorenter $1 $0 @_ _.monitorenter]
+ [monitorexit $1 $0 @_ _.monitorexit]
+ )
+
+(def: discontinuity!
+ (Bytecode Any)
+ (function (_ [pool environment tracker])
+ (do try.monad
+ [_ (/environment.stack environment)]
+ (wrap [[pool
+ (/environment.discontinue environment)
+ tracker]
+ [..relative_identity
+ []]]))))
+
+(template [<name> <consumption> <instruction>]
+ [(def: #export <name>
+ (Bytecode Any)
+ (do ..monad
+ [_ (..bytecode <consumption> $0 @_ <instruction> [])]
+ ..discontinuity!))]
+
+ [ireturn $1 _.ireturn]
+ [lreturn $2 _.lreturn]
+ [freturn $1 _.freturn]
+ [dreturn $2 _.dreturn]
+ [areturn $1 _.areturn]
+ [return $0 _.return]
+
+ [athrow $1 _.athrow]
+ )
+
+(def: #export (bipush byte)
+ (-> S1 (Bytecode Any))
+ (..bytecode $0 $1 @_ _.bipush [byte]))
+
+(def: (lift resource)
+ (All [a]
+ (-> (Resource a)
+ (Bytecode a)))
+ (function (_ [pool environment tracker])
+ (do try.monad
+ [[pool' output] (resource pool)]
+ (wrap [[pool' environment tracker]
+ [..relative_identity
+ output]]))))
+
+(def: #export (string value)
+ (-> //constant.UTF8 (Bytecode Any))
+ (do ..monad
+ [index (..lift (//constant/pool.string value))]
+ (case (|> index //index.value //unsigned.value //unsigned.u1)
+ (#try.Success index)
+ (..bytecode $0 $1 @_ _.ldc [index])
+
+ (#try.Failure _)
+ (..bytecode $0 $1 @_ _.ldc_w/string [index]))))
+
+(import: java/lang/Float
+ ["#::."
+ (#static floatToRawIntBits #manual [float] int)])
+
+(import: java/lang/Double
+ ["#::."
+ (#static doubleToRawLongBits #manual [double] long)])
+
+(template [<name> <type> <constructor> <constant> <wide> <to_lux> <specializations>]
+ [(def: #export (<name> value)
+ (-> <type> (Bytecode Any))
+ (case (|> value <to_lux>)
+ (^template [<special> <instruction>]
+ [<special> (..bytecode $0 $1 @_ <instruction> [])])
+ <specializations>
+
+ _ (do ..monad
+ [index (..lift (<constant> (<constructor> value)))]
+ (case (|> index //index.value //unsigned.value //unsigned.u1)
+ (#try.Success index)
+ (..bytecode $0 $1 @_ _.ldc [index])
+
+ (#try.Failure _)
+ (..bytecode $0 $1 @_ <wide> [index])))))]
+
+ [int I32 //constant.integer //constant/pool.integer _.ldc_w/integer
+ (<| .int i32.i64)
+ ([-1 _.iconst_m1]
+ [+0 _.iconst_0]
+ [+1 _.iconst_1]
+ [+2 _.iconst_2]
+ [+3 _.iconst_3]
+ [+4 _.iconst_4]
+ [+5 _.iconst_5])]
+ )
+
+(def: (arbitrary_float value)
+ (-> java/lang/Float (Bytecode Any))
+ (do ..monad
+ [index (..lift (//constant/pool.float (//constant.float value)))]
+ (case (|> index //index.value //unsigned.value //unsigned.u1)
+ (#try.Success index)
+ (..bytecode $0 $1 @_ _.ldc [index])
+
+ (#try.Failure _)
+ (..bytecode $0 $1 @_ _.ldc_w/float [index]))))
+
+(def: float_bits
+ (-> java/lang/Float Int)
+ (|>> java/lang/Float::floatToRawIntBits
+ ffi.int_to_long
+ (:as Int)))
+
+(def: negative_zero_float_bits
+ (|> -0.0 (:as java/lang/Double) ffi.double_to_float ..float_bits))
+
+(def: #export (float value)
+ (-> java/lang/Float (Bytecode Any))
+ (if (i.= ..negative_zero_float_bits
+ (..float_bits value))
+ (..arbitrary_float value)
+ (case (|> value ffi.float_to_double (:as Frac))
+ (^template [<special> <instruction>]
+ [<special> (..bytecode $0 $1 @_ <instruction> [])])
+ ([+0.0 _.fconst_0]
+ [+1.0 _.fconst_1]
+ [+2.0 _.fconst_2])
+
+ _ (..arbitrary_float value))))
+
+(template [<name> <type> <constructor> <constant> <wide> <to_lux> <specializations>]
+ [(def: #export (<name> value)
+ (-> <type> (Bytecode Any))
+ (case (|> value <to_lux>)
+ (^template [<special> <instruction>]
+ [<special> (..bytecode $0 $2 @_ <instruction> [])])
+ <specializations>
+
+ _ (do ..monad
+ [index (..lift (<constant> (<constructor> value)))]
+ (..bytecode $0 $2 @_ <wide> [index]))))]
+
+ [long Int //constant.long //constant/pool.long _.ldc2_w/long
+ (<|)
+ ([+0 _.lconst_0]
+ [+1 _.lconst_1])]
+ )
+
+(def: (arbitrary_double value)
+ (-> java/lang/Double (Bytecode Any))
+ (do ..monad
+ [index (..lift (//constant/pool.double (//constant.double (:as Frac value))))]
+ (..bytecode $0 $2 @_ _.ldc2_w/double [index])))
+
+(def: double_bits
+ (-> java/lang/Double Int)
+ (|>> java/lang/Double::doubleToRawLongBits
+ (:as Int)))
+
+(def: negative_zero_double_bits
+ (..double_bits (:as java/lang/Double -0.0)))
+
+(def: #export (double value)
+ (-> java/lang/Double (Bytecode Any))
+ (if (i.= ..negative_zero_double_bits
+ (..double_bits value))
+ (..arbitrary_double value)
+ (case (:as Frac value)
+ (^template [<special> <instruction>]
+ [<special> (..bytecode $0 $2 @_ <instruction> [])])
+ ([+0.0 _.dconst_0]
+ [+1.0 _.dconst_1])
+
+ _ (..arbitrary_double value))))
+
+(exception: #export (invalid_register {id Nat})
+ (exception.report
+ ["ID" (%.nat id)]))
+
+(def: (register id)
+ (-> Nat (Bytecode Register))
+ (case (//unsigned.u1 id)
+ (#try.Success register)
+ (\ ..monad wrap register)
+
+ (#try.Failure error)
+ (..throw ..invalid_register [id])))
+
+(template [<for> <size> <name> <general> <specials>]
+ [(def: #export (<name> local)
+ (-> Nat (Bytecode Any))
+ (with_expansions [<specials>' (template.splice <specials>)]
+ (`` (case local
+ (~~ (template [<case> <instruction> <registry>]
+ [<case> (..bytecode $0 <size> <registry> <instruction> [])]
+
+ <specials>'))
+ _ (do ..monad
+ [local (..register local)]
+ (..bytecode $0 <size> (<for> local) <general> [local]))))))]
+
+ [/registry.for $1 iload _.iload
+ [[0 _.iload_0 @0]
+ [1 _.iload_1 @1]
+ [2 _.iload_2 @2]
+ [3 _.iload_3 @3]]]
+ [/registry.for_wide $2 lload _.lload
+ [[0 _.lload_0 @1]
+ [1 _.lload_1 @2]
+ [2 _.lload_2 @3]
+ [3 _.lload_3 @4]]]
+ [/registry.for $1 fload _.fload
+ [[0 _.fload_0 @0]
+ [1 _.fload_1 @1]
+ [2 _.fload_2 @2]
+ [3 _.fload_3 @3]]]
+ [/registry.for_wide $2 dload _.dload
+ [[0 _.dload_0 @1]
+ [1 _.dload_1 @2]
+ [2 _.dload_2 @3]
+ [3 _.dload_3 @4]]]
+ [/registry.for $1 aload _.aload
+ [[0 _.aload_0 @0]
+ [1 _.aload_1 @1]
+ [2 _.aload_2 @2]
+ [3 _.aload_3 @3]]]
+ )
+
+(template [<for> <size> <name> <general> <specials>]
+ [(def: #export (<name> local)
+ (-> Nat (Bytecode Any))
+ (with_expansions [<specials>' (template.splice <specials>)]
+ (`` (case local
+ (~~ (template [<case> <instruction> <registry>]
+ [<case> (..bytecode <size> $0 <registry> <instruction> [])]
+
+ <specials>'))
+ _ (do ..monad
+ [local (..register local)]
+ (..bytecode <size> $0 (<for> local) <general> [local]))))))]
+
+ [/registry.for $1 istore _.istore
+ [[0 _.istore_0 @0]
+ [1 _.istore_1 @1]
+ [2 _.istore_2 @2]
+ [3 _.istore_3 @3]]]
+ [/registry.for_wide $2 lstore _.lstore
+ [[0 _.lstore_0 @1]
+ [1 _.lstore_1 @2]
+ [2 _.lstore_2 @3]
+ [3 _.lstore_3 @4]]]
+ [/registry.for $1 fstore _.fstore
+ [[0 _.fstore_0 @0]
+ [1 _.fstore_1 @1]
+ [2 _.fstore_2 @2]
+ [3 _.fstore_3 @3]]]
+ [/registry.for_wide $2 dstore _.dstore
+ [[0 _.dstore_0 @1]
+ [1 _.dstore_1 @2]
+ [2 _.dstore_2 @3]
+ [3 _.dstore_3 @4]]]
+ [/registry.for $1 astore _.astore
+ [[0 _.astore_0 @0]
+ [1 _.astore_1 @1]
+ [2 _.astore_2 @2]
+ [3 _.astore_3 @3]]]
+ )
+
+(template [<consumption> <production> <name> <instruction> <input>]
+ [(def: #export <name>
+ (-> <input> (Bytecode Any))
+ (..bytecode <consumption> <production> @_ <instruction>))]
+
+ [$1 $1 newarray _.newarray Primitive_Array_Type]
+ [$0 $1 sipush _.sipush S2]
+ )
+
+(exception: #export (unknown_label {label Label})
+ (exception.report
+ ["Label" (%.nat label)]))
+
+(exception: #export (cannot_do_a_big_jump {label Label}
+ {@from Address}
+ {jump Big_Jump})
+ (exception.report
+ ["Label" (%.nat label)]
+ ["Start" (|> @from /address.value //unsigned.value %.nat)]
+ ["Target" (|> jump //signed.value %.int)]))
+
+(type: Any_Jump (Either Big_Jump Jump))
+
+(def: (jump @from @to)
+ (-> Address Address (Try Any_Jump))
+ (do {! try.monad}
+ [jump (\ ! map //signed.value
+ (/address.jump @from @to))]
+ (let [big? (n.> (//unsigned.value //unsigned.maximum/2)
+ (.nat (i.* (if (i.>= +0 jump)
+ +1
+ -1)
+ jump)))]
+ (if big?
+ (\ ! map (|>> #.Left) (//signed.s4 jump))
+ (\ ! map (|>> #.Right) (//signed.s2 jump))))))
+
+(exception: #export (unset_label {label Label})
+ (exception.report
+ ["Label" (%.nat label)]))
+
+(def: (resolve_label label resolver)
+ (-> Label Resolver (Try [Stack Address]))
+ (case (dictionary.get label resolver)
+ (#.Some [actual (#.Some address)])
+ (#try.Success [actual address])
+
+ (#.Some [actual #.None])
+ (exception.throw ..unset_label [label])
+
+ #.None
+ (exception.throw ..unknown_label [label])))
+
+(def: (acknowledge_label stack label tracker)
+ (-> Stack Label Tracker Tracker)
+ (case (dictionary.get label (get@ #known tracker))
+ (#.Some _)
+ tracker
+
+ #.None
+ (update@ #known (dictionary.put label [stack #.None]) tracker)))
+
+(template [<consumption> <name> <instruction>]
+ [(def: #export (<name> label)
+ (-> Label (Bytecode Any))
+ (let [[estimator bytecode] <instruction>]
+ (function (_ [pool environment tracker])
+ (let [@here (get@ #program_counter tracker)]
+ (do try.monad
+ [environment' (|> environment
+ (/environment.consumes <consumption>))
+ actual (/environment.stack environment')
+ program_counter' (step estimator @here)]
+ (wrap (let [@from @here]
+ [[pool
+ environment'
+ (|> tracker
+ (..acknowledge_label actual label)
+ (set@ #program_counter program_counter'))]
+ [(function (_ resolver)
+ (do try.monad
+ [[expected @to] (..resolve_label label resolver)
+ _ (exception.assert ..mismatched_environments [(name_of <instruction>) label @here expected actual]
+ (\ /stack.equivalence = expected actual))
+ jump (..jump @from @to)]
+ (case jump
+ (#.Left jump)
+ (exception.throw ..cannot_do_a_big_jump [label @from jump])
+
+ (#.Right jump)
+ (wrap [..no_exceptions (bytecode jump)]))))
+ []]])))))))]
+
+ [$1 ifeq _.ifeq]
+ [$1 ifne _.ifne]
+ [$1 iflt _.iflt]
+ [$1 ifge _.ifge]
+ [$1 ifgt _.ifgt]
+ [$1 ifle _.ifle]
+
+ [$1 ifnull _.ifnull]
+ [$1 ifnonnull _.ifnonnull]
+
+ [$2 if_icmpeq _.if_icmpeq]
+ [$2 if_icmpne _.if_icmpne]
+ [$2 if_icmplt _.if_icmplt]
+ [$2 if_icmpge _.if_icmpge]
+ [$2 if_icmpgt _.if_icmpgt]
+ [$2 if_icmple _.if_icmple]
+
+ [$2 if_acmpeq _.if_acmpeq]
+ [$2 if_acmpne _.if_acmpne]
+ )
+
+(template [<name> <instruction> <on_long_jump> <on_short_jump>]
+ [(def: #export (<name> label)
+ (-> Label (Bytecode Any))
+ (let [[estimator bytecode] <instruction>]
+ (function (_ [pool environment tracker])
+ (do try.monad
+ [actual (/environment.stack environment)
+ #let [@here (get@ #program_counter tracker)]
+ program_counter' (step estimator @here)]
+ (wrap (let [@from @here]
+ [[pool
+ (/environment.discontinue environment)
+ (|> tracker
+ (..acknowledge_label actual label)
+ (set@ #program_counter program_counter'))]
+ [(function (_ resolver)
+ (case (dictionary.get label resolver)
+ (#.Some [expected (#.Some @to)])
+ (do try.monad
+ [_ (exception.assert ..mismatched_environments [(name_of <instruction>) label @here expected actual]
+ (\ /stack.equivalence = expected actual))
+ jump (..jump @from @to)]
+ (case jump
+ (#.Left jump)
+ <on_long_jump>
+
+ (#.Right jump)
+ <on_short_jump>))
+
+ (#.Some [expected #.None])
+ (exception.throw ..unset_label [label])
+
+ #.None
+ (exception.throw ..unknown_label [label])))
+ []]]))))))]
+
+ [goto _.goto
+ (exception.throw ..cannot_do_a_big_jump [label @from jump])
+ (wrap [..no_exceptions (bytecode jump)])]
+ [goto_w _.goto_w
+ (wrap [..no_exceptions (bytecode jump)])
+ (wrap [..no_exceptions (bytecode (/jump.lift jump))])]
+ )
+
+(def: (big_jump jump)
+ (-> Any_Jump Big_Jump)
+ (case jump
+ (#.Left big)
+ big
+
+ (#.Right small)
+ (/jump.lift small)))
+
+(exception: #export invalid_tableswitch)
+
+(def: #export (tableswitch minimum default [at_minimum afterwards])
+ (-> S4 Label [Label (List Label)] (Bytecode Any))
+ (let [[estimator bytecode] _.tableswitch]
+ (function (_ [pool environment tracker])
+ (do try.monad
+ [environment' (|> environment
+ (/environment.consumes $1))
+ actual (/environment.stack environment')
+ program_counter' (step (estimator (list.size afterwards)) (get@ #program_counter tracker))]
+ (wrap (let [@from (get@ #program_counter tracker)]
+ [[pool
+ environment'
+ (|> (list\fold (..acknowledge_label actual) tracker (list& default at_minimum afterwards))
+ (set@ #program_counter program_counter'))]
+ [(function (_ resolver)
+ (let [get (: (-> Label (Maybe [Stack (Maybe Address)]))
+ (function (_ label)
+ (dictionary.get label resolver)))]
+ (case (do {! maybe.monad}
+ [@default (|> default get (monad.bind ! product.right))
+ @at_minimum (|> at_minimum get (monad.bind ! product.right))
+ @afterwards (|> afterwards
+ (monad.map ! get)
+ (monad.bind ! (monad.map ! product.right)))]
+ (wrap [@default @at_minimum @afterwards]))
+ (#.Some [@default @at_minimum @afterwards])
+ (do {! try.monad}
+ [>default (\ ! map ..big_jump (..jump @from @default))
+ >at_minimum (\ ! map ..big_jump (..jump @from @at_minimum))
+ >afterwards (monad.map ! (|>> (..jump @from) (\ ! map ..big_jump))
+ @afterwards)]
+ (wrap [..no_exceptions (bytecode minimum >default [>at_minimum >afterwards])]))
+
+ #.None
+ (exception.throw ..invalid_tableswitch []))))
+ []]]))))))
+
+(exception: #export invalid_lookupswitch)
+
+(def: #export (lookupswitch default cases)
+ (-> Label (List [S4 Label]) (Bytecode Any))
+ (let [cases (list.sort (function (_ [left _] [right _])
+ (i.< (//signed.value left)
+ (//signed.value right)))
+ cases)
+ [estimator bytecode] _.lookupswitch]
+ (function (_ [pool environment tracker])
+ (do try.monad
+ [environment' (|> environment
+ (/environment.consumes $1))
+ actual (/environment.stack environment')
+ program_counter' (step (estimator (list.size cases)) (get@ #program_counter tracker))]
+ (wrap (let [@from (get@ #program_counter tracker)]
+ [[pool
+ environment'
+ (|> (list\fold (..acknowledge_label actual) tracker (list& default (list\map product.right cases)))
+ (set@ #program_counter program_counter'))]
+ [(function (_ resolver)
+ (let [get (: (-> Label (Maybe [Stack (Maybe Address)]))
+ (function (_ label)
+ (dictionary.get label resolver)))]
+ (case (do {! maybe.monad}
+ [@default (|> default get (monad.bind ! product.right))
+ @cases (|> cases
+ (monad.map ! (|>> product.right get))
+ (monad.bind ! (monad.map ! product.right)))]
+ (wrap [@default @cases]))
+ (#.Some [@default @cases])
+ (do {! try.monad}
+ [>default (\ ! map ..big_jump (..jump @from @default))
+ >cases (|> @cases
+ (monad.map ! (|>> (..jump @from) (\ ! map ..big_jump)))
+ (\ ! map (|>> (list.zip/2 (list\map product.left cases)))))]
+ (wrap [..no_exceptions (bytecode >default >cases)]))
+
+ #.None
+ (exception.throw ..invalid_lookupswitch []))))
+ []]]))))))
+
+(def: reflection
+ (All [category]
+ (-> (Type (<| Return' Value' category)) Text))
+ (|>> type.reflection reflection.reflection))
+
+(template [<consumption> <production> <name> <category> <instruction>]
+ [(def: #export (<name> class)
+ (-> (Type <category>) (Bytecode Any))
+ (do ..monad
+ [## TODO: Make sure it's impossible to have indexes greater than U2.
+ index (..lift (//constant/pool.class (//name.internal (..reflection class))))]
+ (..bytecode <consumption> <production> @_ <instruction> [index])))]
+
+ [$0 $1 new Class _.new]
+ [$1 $1 anewarray Object _.anewarray]
+ [$1 $1 checkcast Object _.checkcast]
+ [$1 $1 instanceof Object _.instanceof]
+ )
+
+(def: #export (iinc register increase)
+ (-> Nat U1 (Bytecode Any))
+ (do ..monad
+ [register (..register register)]
+ (..bytecode $0 $0 (/registry.for register) _.iinc [register increase])))
+
+(exception: #export (multiarray_cannot_be_zero_dimensional {class (Type Object)})
+ (exception.report ["Class" (..reflection class)]))
+
+(def: #export (multianewarray class dimensions)
+ (-> (Type Object) U1 (Bytecode Any))
+ (do ..monad
+ [_ (: (Bytecode Any)
+ (case (|> dimensions //unsigned.value)
+ 0 (..throw ..multiarray_cannot_be_zero_dimensional [class])
+ _ (wrap [])))
+ index (..lift (//constant/pool.class (//name.internal (..reflection class))))]
+ (..bytecode (//unsigned.lift/2 dimensions) $1 @_ _.multianewarray [index dimensions])))
+
+(def: (type_size type)
+ (-> (Type Return) Nat)
+ (cond (is? type.void type)
+ 0
+
+ (or (is? type.long type)
+ (is? type.double type))
+ 2
+
+ ## else
+ 1))
+
+(template [<static?> <name> <instruction> <method>]
+ [(def: #export (<name> class method type)
+ (-> (Type Class) Text (Type Method) (Bytecode Any))
+ (let [[inputs output exceptions] (parser.method type)]
+ (do ..monad
+ [index (<| ..lift
+ (<method> (..reflection class))
+ {#//constant/pool.name method
+ #//constant/pool.descriptor (type.descriptor type)})
+ #let [consumption (|> inputs
+ (list\map ..type_size)
+ (list\fold n.+ (if <static?> 0 1))
+ //unsigned.u1
+ try.assume)
+ production (|> output ..type_size //unsigned.u1 try.assume)]]
+ (..bytecode (//unsigned.lift/2 consumption)
+ (//unsigned.lift/2 production)
+ @_
+ <instruction> [index consumption production]))))]
+
+ [#1 invokestatic _.invokestatic //constant/pool.method]
+ [#0 invokevirtual _.invokevirtual //constant/pool.method]
+ [#0 invokespecial _.invokespecial //constant/pool.method]
+ [#0 invokeinterface _.invokeinterface //constant/pool.interface_method]
+ )
+
+(template [<consumption> <name> <1> <2>]
+ [(def: #export (<name> class field type)
+ (-> (Type Class) Text (Type Value) (Bytecode Any))
+ (do ..monad
+ [index (<| ..lift
+ (//constant/pool.field (..reflection class))
+ {#//constant/pool.name field
+ #//constant/pool.descriptor (type.descriptor type)})]
+ (if (or (is? type.long type)
+ (is? type.double type))
+ (..bytecode <consumption> $2 @_ <2> [index])
+ (..bytecode <consumption> $1 @_ <1> [index]))))]
+
+ [$0 getstatic _.getstatic/1 _.getstatic/2]
+ [$1 putstatic _.putstatic/1 _.putstatic/2]
+ [$1 getfield _.getfield/1 _.getfield/2]
+ [$2 putfield _.putfield/1 _.putfield/2]
+ )
+
+(exception: #export (invalid_range_for_try {start Address} {end Address})
+ (exception.report
+ ["Start" (|> start /address.value //unsigned.value %.nat)]
+ ["End" (|> end /address.value //unsigned.value %.nat)]))
+
+(def: #export (try @start @end @handler catch)
+ (-> Label Label Label (Type Class) (Bytecode Any))
+ (do ..monad
+ [@catch (..lift (//constant/pool.class (//name.internal (..reflection catch))))]
+ (function (_ [pool environment tracker])
+ (#try.Success
+ [[pool
+ environment
+ (..acknowledge_label /stack.catch @handler tracker)]
+ [(function (_ resolver)
+ (do try.monad
+ [[_ @start] (..resolve_label @start resolver)
+ [_ @end] (..resolve_label @end resolver)
+ _ (if (/address.after? @start @end)
+ (wrap [])
+ (exception.throw ..invalid_range_for_try [@start @end]))
+ [_ @handler] (..resolve_label @handler resolver)]
+ (wrap [(row.row {#//exception.start @start
+ #//exception.end @end
+ #//exception.handler @handler
+ #//exception.catch @catch})
+ _.empty])))
+ []]]))))
+
+(def: #export (compose pre post)
+ (All [pre post]
+ (-> (Bytecode pre) (Bytecode post) (Bytecode post)))
+ (do ..monad
+ [_ pre]
+ post))
diff --git a/stdlib/source/library/lux/target/jvm/bytecode/address.lux b/stdlib/source/library/lux/target/jvm/bytecode/address.lux
new file mode 100644
index 000000000..8d51a8597
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/bytecode/address.lux
@@ -0,0 +1,74 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ [format
+ [binary (#+ Writer)]]
+ [text
+ ["%" format (#+ Format)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [type
+ abstract]]]
+ ["." // #_
+ [jump (#+ Big_Jump)]
+ ["/#" // #_
+ [encoding
+ ["#." unsigned (#+ U2)]
+ ["#." signed (#+ S4)]]]])
+
+(abstract: #export Address
+ U2
+
+ (def: #export value
+ (-> Address U2)
+ (|>> :representation))
+
+ (def: #export start
+ Address
+ (|> 0 ///unsigned.u2 try.assume :abstraction))
+
+ (def: #export (move distance)
+ (-> U2 (-> Address (Try Address)))
+ (|>> :representation
+ (///unsigned.+/2 distance)
+ (\ try.functor map (|>> :abstraction))))
+
+ (def: with_sign
+ (-> Address (Try S4))
+ (|>> :representation ///unsigned.value .int ///signed.s4))
+
+ (def: #export (jump from to)
+ (-> Address Address (Try Big_Jump))
+ (do try.monad
+ [from (with_sign from)
+ to (with_sign to)]
+ (///signed.-/4 from to)))
+
+ (def: #export (after? reference subject)
+ (-> Address Address Bit)
+ (n.> (|> reference :representation ///unsigned.value)
+ (|> subject :representation ///unsigned.value)))
+
+ (implementation: #export equivalence
+ (Equivalence Address)
+
+ (def: (= reference subject)
+ (\ ///unsigned.equivalence =
+ (:representation reference)
+ (:representation subject))))
+
+ (def: #export writer
+ (Writer Address)
+ (|>> :representation ///unsigned.writer/2))
+
+ (def: #export format
+ (Format Address)
+ (|>> :representation ///unsigned.value %.nat))
+ )
diff --git a/stdlib/source/library/lux/target/jvm/bytecode/environment.lux b/stdlib/source/library/lux/target/jvm/bytecode/environment.lux
new file mode 100644
index 000000000..fdf50d974
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/bytecode/environment.lux
@@ -0,0 +1,108 @@
+(.module:
+ [library
+ [lux (#- Type static)
+ [abstract
+ [monad (#+ do)]
+ [monoid (#+ Monoid)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]]]
+ [/
+ ["/." limit (#+ Limit)
+ ["/." stack (#+ Stack)]
+ ["/." registry (#+ Registry)]]
+ [///
+ [encoding
+ [unsigned (#+ U2)]]
+ [type (#+ Type)
+ [category (#+ Method)]]]])
+
+(type: #export Environment
+ {#limit Limit
+ #stack (Maybe Stack)})
+
+(template [<name> <limit>]
+ [(def: #export (<name> type)
+ (-> (Type Method) (Try Environment))
+ (do try.monad
+ [limit (<limit> type)]
+ (wrap {#limit limit
+ #stack (#.Some /stack.empty)})))]
+
+ [static /limit.static]
+ [virtual /limit.virtual]
+ )
+
+(type: #export Condition
+ (-> Environment (Try Environment)))
+
+(implementation: #export monoid
+ (Monoid Condition)
+
+ (def: identity (|>> #try.Success))
+
+ (def: (compose left right)
+ (function (_ environment)
+ (do try.monad
+ [environment (left environment)]
+ (right environment)))))
+
+(exception: #export discontinuity)
+
+(def: #export (stack environment)
+ (-> Environment (Try Stack))
+ (case (get@ #..stack environment)
+ (#.Some stack)
+ (#try.Success stack)
+
+ #.None
+ (exception.throw ..discontinuity [])))
+
+(def: #export discontinue
+ (-> Environment Environment)
+ (set@ #..stack #.None))
+
+(exception: #export (mismatched_stacks {expected Stack}
+ {actual Stack})
+ (exception.report
+ ["Expected" (/stack.format expected)]
+ ["Actual" (/stack.format actual)]))
+
+(def: #export (continue expected environment)
+ (-> Stack Environment (Try [Stack Environment]))
+ (case (get@ #..stack environment)
+ (#.Some actual)
+ (if (\ /stack.equivalence = expected actual)
+ (#try.Success [actual environment])
+ (exception.throw ..mismatched_stacks [expected actual]))
+
+ #.None
+ (#try.Success [expected (set@ #..stack (#.Some expected) environment)])))
+
+(def: #export (consumes amount)
+ (-> U2 Condition)
+ ## TODO: Revisit this definition once lenses/optics have been implemented,
+ ## since it can probably be simplified with them.
+ (function (_ environment)
+ (do try.monad
+ [previous (..stack environment)
+ current (/stack.pop amount previous)]
+ (wrap (set@ #..stack (#.Some current) environment)))))
+
+(def: #export (produces amount)
+ (-> U2 Condition)
+ (function (_ environment)
+ (do try.monad
+ [previous (..stack environment)
+ current (/stack.push amount previous)
+ #let [limit (|> environment
+ (get@ [#..limit #/limit.stack])
+ (/stack.max current))]]
+ (wrap (|> environment
+ (set@ #..stack (#.Some current))
+ (set@ [#..limit #/limit.stack] limit))))))
+
+(def: #export (has registry)
+ (-> Registry Condition)
+ (|>> (update@ [#..limit #/limit.registry] (/registry.has registry))
+ #try.Success))
diff --git a/stdlib/source/library/lux/target/jvm/bytecode/environment/limit.lux b/stdlib/source/library/lux/target/jvm/bytecode/environment/limit.lux
new file mode 100644
index 000000000..c7e9a8959
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/bytecode/environment/limit.lux
@@ -0,0 +1,58 @@
+(.module:
+ [library
+ [lux (#- Type static)
+ [abstract
+ [monad (#+ do)]
+ [equivalence (#+ Equivalence)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ ["." product]
+ ["." format #_
+ ["#" binary (#+ Writer) ("#\." monoid)]]]
+ [math
+ [number
+ ["n" nat]]]]]
+ ["." / #_
+ ["#." stack (#+ Stack)]
+ ["#." registry (#+ Registry)]
+ [////
+ [type (#+ Type)
+ [category (#+ Method)]]]])
+
+(type: #export Limit
+ {#stack Stack
+ #registry Registry})
+
+(template [<name> <registry>]
+ [(def: #export (<name> type)
+ (-> (Type Method) (Try Limit))
+ (do try.monad
+ [registry (<registry> type)]
+ (wrap {#stack /stack.empty
+ #registry registry})))]
+
+ [static /registry.static]
+ [virtual /registry.virtual]
+ )
+
+(def: #export length
+ ($_ n.+
+ ## u2 max_stack;
+ /stack.length
+ ## u2 max_locals;
+ /registry.length))
+
+(def: #export equivalence
+ (Equivalence Limit)
+ ($_ product.equivalence
+ /stack.equivalence
+ /registry.equivalence
+ ))
+
+(def: #export (writer limit)
+ (Writer Limit)
+ ($_ format\compose
+ (/stack.writer (get@ #stack limit))
+ (/registry.writer (get@ #registry limit))
+ ))
diff --git a/stdlib/source/library/lux/target/jvm/bytecode/environment/limit/registry.lux b/stdlib/source/library/lux/target/jvm/bytecode/environment/limit/registry.lux
new file mode 100644
index 000000000..05872be60
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/bytecode/environment/limit/registry.lux
@@ -0,0 +1,91 @@
+(.module:
+ [library
+ [lux (#- Type for static)
+ [abstract
+ ["." equivalence (#+ Equivalence)]]
+ [control
+ ["." try (#+ Try) ("#\." functor)]]
+ [data
+ [format
+ [binary (#+ Writer)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [type
+ abstract]]]
+ ["." ///// #_
+ [encoding
+ ["#." unsigned (#+ U1 U2)]]
+ ["#." type (#+ Type)
+ [category (#+ Method)]
+ ["#/." parser]]])
+
+(type: #export Register U1)
+
+(def: normal 1)
+(def: wide 2)
+
+(abstract: #export Registry
+ U2
+
+ (def: #export registry
+ (-> U2 Registry)
+ (|>> :abstraction))
+
+ (def: (minimal type)
+ (-> (Type Method) Nat)
+ (let [[inputs output exceptions] (/////type/parser.method type)]
+ (|> inputs
+ (list\map (function (_ input)
+ (if (or (is? /////type.long input)
+ (is? /////type.double input))
+ ..wide
+ ..normal)))
+ (list\fold n.+ 0))))
+
+ (template [<start> <name>]
+ [(def: #export <name>
+ (-> (Type Method) (Try Registry))
+ (|>> ..minimal
+ (n.+ <start>)
+ /////unsigned.u2
+ (try\map ..registry)))]
+
+ [0 static]
+ [1 virtual]
+ )
+
+ (def: #export equivalence
+ (Equivalence Registry)
+ (\ equivalence.functor map
+ (|>> :representation)
+ /////unsigned.equivalence))
+
+ (def: #export writer
+ (Writer Registry)
+ (|>> :representation /////unsigned.writer/2))
+
+ (def: #export (has needed)
+ (-> Registry Registry Registry)
+ (|>> :representation
+ (/////unsigned.max/2 (:representation needed))
+ :abstraction))
+
+ (template [<name> <extra>]
+ [(def: #export <name>
+ (-> Register Registry)
+ (let [extra (|> <extra> /////unsigned.u2 try.assume)]
+ (|>> /////unsigned.lift/2
+ (/////unsigned.+/2 extra)
+ try.assume
+ :abstraction)))]
+
+ [for ..normal]
+ [for_wide ..wide]
+ )
+ )
+
+(def: #export length
+ /////unsigned.bytes/2)
diff --git a/stdlib/source/library/lux/target/jvm/bytecode/environment/limit/stack.lux b/stdlib/source/library/lux/target/jvm/bytecode/environment/limit/stack.lux
new file mode 100644
index 000000000..99a560347
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/bytecode/environment/limit/stack.lux
@@ -0,0 +1,69 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." equivalence (#+ Equivalence)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ ["." maybe]
+ [text
+ ["%" format (#+ Format)]]
+ [format
+ [binary (#+ Writer)]]]
+ [type
+ abstract]]]
+ ["." ///// #_
+ [encoding
+ ["#." unsigned (#+ U2)]]])
+
+(abstract: #export Stack
+ U2
+
+ (template [<frames> <name>]
+ [(def: #export <name>
+ Stack
+ (|> <frames> /////unsigned.u2 maybe.assume :abstraction))]
+
+ [0 empty]
+ [1 catch]
+ )
+
+ (def: #export equivalence
+ (Equivalence Stack)
+ (\ equivalence.functor map
+ (|>> :representation)
+ /////unsigned.equivalence))
+
+ (def: #export writer
+ (Writer Stack)
+ (|>> :representation /////unsigned.writer/2))
+
+ (def: stack
+ (-> U2 Stack)
+ (|>> :abstraction))
+
+ (template [<op> <name>]
+ [(def: #export (<name> amount)
+ (-> U2 (-> Stack (Try Stack)))
+ (|>> :representation
+ (<op> amount)
+ (\ try.functor map ..stack)))]
+
+ [/////unsigned.+/2 push]
+ [/////unsigned.-/2 pop]
+ )
+
+ (def: #export (max left right)
+ (-> Stack Stack Stack)
+ (:abstraction
+ (/////unsigned.max/2 (:representation left)
+ (:representation right))))
+
+ (def: #export format
+ (Format Stack)
+ (|>> :representation /////unsigned.value %.nat))
+ )
+
+(def: #export length
+ /////unsigned.bytes/2)
diff --git a/stdlib/source/library/lux/target/jvm/bytecode/instruction.lux b/stdlib/source/library/lux/target/jvm/bytecode/instruction.lux
new file mode 100644
index 000000000..65e36875f
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/bytecode/instruction.lux
@@ -0,0 +1,714 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]
+ [monoid (#+ Monoid)]]
+ [control
+ ["." function]
+ ["." try]]
+ [data
+ ["." product]
+ ["." binary]
+ ["." format #_
+ ["#" binary (#+ Mutation Specification)]]
+ [collection
+ ["." list]]]
+ [macro
+ ["." template]]
+ [math
+ [number (#+ hex)
+ ["n" nat]]]
+ [type
+ abstract]]]
+ ["." // #_
+ ["#." address (#+ Address)]
+ ["#." jump (#+ Jump Big_Jump)]
+ [environment
+ [limit
+ [registry (#+ Register)]]]
+ ["/#" // #_
+ ["#." index (#+ Index)]
+ ["#." constant (#+ Class Reference)]
+ [encoding
+ ["#." unsigned (#+ U1 U2 U4)]
+ ["#." signed (#+ S1 S2 S4)]]
+ [type
+ [category (#+ Value Method)]]]])
+
+(type: #export Size U2)
+
+(type: #export Estimator
+ (-> Address Size))
+
+(def: fixed
+ (-> Size Estimator)
+ function.constant)
+
+(type: #export Instruction
+ (-> Specification Specification))
+
+(def: #export empty
+ Instruction
+ function.identity)
+
+(def: #export run
+ (-> Instruction Specification)
+ (function.apply format.no_op))
+
+(type: Opcode Nat)
+
+(template [<name> <size>]
+ [(def: <name> Size (|> <size> ///unsigned.u2 try.assume))]
+
+ [opcode_size 1]
+ [register_size 1]
+ [byte_size 1]
+ [index_size 2]
+ [big_jump_size 4]
+ [integer_size 4]
+ )
+
+(def: (nullary' opcode)
+ (-> Opcode Mutation)
+ (function (_ [offset binary])
+ [(n.+ (///unsigned.value ..opcode_size)
+ offset)
+ (try.assume
+ (binary.write/8 offset opcode binary))]))
+
+(def: nullary
+ [Estimator (-> Opcode Instruction)]
+ [(..fixed ..opcode_size)
+ (function (_ opcode [size mutation])
+ [(n.+ (///unsigned.value ..opcode_size)
+ size)
+ (|>> mutation ((nullary' opcode)))])])
+
+(template [<name> <size>]
+ [(def: <name>
+ Size
+ (|> ..opcode_size
+ (///unsigned.+/2 <size>) try.assume))]
+
+ [size/1 ..register_size]
+ [size/2 ..index_size]
+ [size/4 ..big_jump_size]
+ )
+
+(template [<shift> <name> <inputT> <writer> <unwrap>]
+ [(with_expansions [<private> (template.identifier ["'" <name>])]
+ (def: (<private> opcode input0)
+ (-> Opcode <inputT> Mutation)
+ (function (_ [offset binary])
+ [(n.+ (///unsigned.value <shift>) offset)
+ (try.assume
+ (do try.monad
+ [_ (binary.write/8 offset opcode binary)]
+ (<writer> (n.+ (///unsigned.value ..opcode_size) offset)
+ (<unwrap> input0)
+ binary)))]))
+
+ (def: <name>
+ [Estimator (-> Opcode <inputT> Instruction)]
+ [(..fixed <shift>)
+ (function (_ opcode input0 [size mutation])
+ [(n.+ (///unsigned.value <shift>) size)
+ (|>> mutation ((<private> opcode input0)))])]))]
+
+ [..size/1 unary/1 U1 binary.write/8 ///unsigned.value]
+ [..size/2 unary/2 U2 binary.write/16 ///unsigned.value]
+ [..size/2 jump/2 Jump binary.write/16 ///signed.value]
+ [..size/4 jump/4 Big_Jump binary.write/32 ///signed.value]
+ )
+
+(template [<shift> <name> <inputT> <writer>]
+ [(with_expansions [<private> (template.identifier ["'" <name>])]
+ (def: (<private> opcode input0)
+ (-> Opcode <inputT> Mutation)
+ (function (_ [offset binary])
+ [(n.+ (///unsigned.value <shift>) offset)
+ (try.assume
+ (do try.monad
+ [_ (binary.write/8 offset opcode binary)]
+ (<writer> (n.+ (///unsigned.value ..opcode_size) offset)
+ (///signed.value input0)
+ binary)))]))
+
+ (def: <name>
+ [Estimator (-> Opcode <inputT> Instruction)]
+ [(..fixed <shift>)
+ (function (_ opcode input0 [size mutation])
+ [(n.+ (///unsigned.value <shift>) size)
+ (|>> mutation ((<private> opcode input0)))])]))]
+
+ [..size/1 unary/1' S1 binary.write/8]
+ [..size/2 unary/2' S2 binary.write/16]
+ )
+
+(def: size/11
+ Size
+ (|> ..opcode_size
+ (///unsigned.+/2 ..register_size) try.assume
+ (///unsigned.+/2 ..byte_size) try.assume))
+
+(def: (binary/11' opcode input0 input1)
+ (-> Opcode U1 U1 Mutation)
+ (function (_ [offset binary])
+ [(n.+ (///unsigned.value ..size/11) offset)
+ (try.assume
+ (do try.monad
+ [_ (binary.write/8 offset opcode binary)
+ _ (binary.write/8 (n.+ (///unsigned.value ..opcode_size) offset)
+ (///unsigned.value input0)
+ binary)]
+ (binary.write/8 (n.+ (///unsigned.value ..size/1) offset)
+ (///unsigned.value input1)
+ binary)))]))
+
+(def: binary/11
+ [Estimator (-> Opcode U1 U1 Instruction)]
+ [(..fixed ..size/11)
+ (function (_ opcode input0 input1 [size mutation])
+ [(n.+ (///unsigned.value ..size/11) size)
+ (|>> mutation ((binary/11' opcode input0 input1)))])])
+
+(def: size/21
+ Size
+ (|> ..opcode_size
+ (///unsigned.+/2 ..index_size) try.assume
+ (///unsigned.+/2 ..byte_size) try.assume))
+
+(def: (binary/21' opcode input0 input1)
+ (-> Opcode U2 U1 Mutation)
+ (function (_ [offset binary])
+ [(n.+ (///unsigned.value ..size/21) offset)
+ (try.assume
+ (do try.monad
+ [_ (binary.write/8 offset opcode binary)
+ _ (binary.write/16 (n.+ (///unsigned.value ..opcode_size) offset)
+ (///unsigned.value input0)
+ binary)]
+ (binary.write/8 (n.+ (///unsigned.value ..size/2) offset)
+ (///unsigned.value input1)
+ binary)))]))
+
+(def: binary/21
+ [Estimator (-> Opcode U2 U1 Instruction)]
+ [(..fixed ..size/21)
+ (function (_ opcode input0 input1 [size mutation])
+ [(n.+ (///unsigned.value ..size/21) size)
+ (|>> mutation ((binary/21' opcode input0 input1)))])])
+
+(def: size/211
+ Size
+ (|> ..opcode_size
+ (///unsigned.+/2 ..index_size) try.assume
+ (///unsigned.+/2 ..byte_size) try.assume
+ (///unsigned.+/2 ..byte_size) try.assume))
+
+(def: (trinary/211' opcode input0 input1 input2)
+ (-> Opcode U2 U1 U1 Mutation)
+ (function (_ [offset binary])
+ [(n.+ (///unsigned.value ..size/211) offset)
+ (try.assume
+ (do try.monad
+ [_ (binary.write/8 offset opcode binary)
+ _ (binary.write/16 (n.+ (///unsigned.value ..opcode_size) offset)
+ (///unsigned.value input0)
+ binary)
+ _ (binary.write/8 (n.+ (///unsigned.value ..size/2) offset)
+ (///unsigned.value input1)
+ binary)]
+ (binary.write/8 (n.+ (///unsigned.value ..size/21) offset)
+ (///unsigned.value input2)
+ binary)))]))
+
+(def: trinary/211
+ [Estimator (-> Opcode U2 U1 U1 Instruction)]
+ [(..fixed ..size/211)
+ (function (_ opcode input0 input1 input2 [size mutation])
+ [(n.+ (///unsigned.value ..size/211) size)
+ (|>> mutation ((trinary/211' opcode input0 input1 input2)))])])
+
+(abstract: #export Primitive_Array_Type
+ U1
+
+ (def: code
+ (-> Primitive_Array_Type U1)
+ (|>> :representation))
+
+ (template [<code> <name>]
+ [(def: #export <name> (|> <code> ///unsigned.u1 try.assume :abstraction))]
+
+ [04 t_boolean]
+ [05 t_char]
+ [06 t_float]
+ [07 t_double]
+ [08 t_byte]
+ [09 t_short]
+ [10 t_int]
+ [11 t_long]
+ ))
+
+## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-6.html#jvms-6.5
+(with_expansions [<constants> (template [<code> <name>]
+ [[<code> <name> [] []]]
+
+ ["01" aconst_null]
+
+ ["02" iconst_m1]
+ ["03" iconst_0]
+ ["04" iconst_1]
+ ["05" iconst_2]
+ ["06" iconst_3]
+ ["07" iconst_4]
+ ["08" iconst_5]
+
+ ["09" lconst_0]
+ ["0A" lconst_1]
+
+ ["0B" fconst_0]
+ ["0C" fconst_1]
+ ["0D" fconst_2]
+
+ ["0E" dconst_0]
+ ["0F" dconst_1])
+ <register_loads> (template [<code> <name>]
+ [[<code> <name> [[register Register]] [register]]]
+
+ ["15" iload]
+ ["16" lload]
+ ["17" fload]
+ ["18" dload]
+ ["19" aload])
+ <simple_register_loads> (template [<code> <name>]
+ [[<code> <name> [] []]]
+
+ ["1A" iload_0]
+ ["1B" iload_1]
+ ["1C" iload_2]
+ ["1D" iload_3]
+
+ ["1E" lload_0]
+ ["1F" lload_1]
+ ["20" lload_2]
+ ["21" lload_3]
+
+ ["22" fload_0]
+ ["23" fload_1]
+ ["24" fload_2]
+ ["25" fload_3]
+
+ ["26" dload_0]
+ ["27" dload_1]
+ ["28" dload_2]
+ ["29" dload_3]
+
+ ["2A" aload_0]
+ ["2B" aload_1]
+ ["2C" aload_2]
+ ["2D" aload_3])
+ <register_stores> (template [<code> <name>]
+ [[<code> <name> [[register Register]] [register]]]
+
+ ["36" istore]
+ ["37" lstore]
+ ["38" fstore]
+ ["39" dstore]
+ ["3A" astore])
+ <simple_register_stores> (template [<code> <name>]
+ [[<code> <name> [] []]]
+
+ ["3B" istore_0]
+ ["3C" istore_1]
+ ["3D" istore_2]
+ ["3E" istore_3]
+
+ ["3F" lstore_0]
+ ["40" lstore_1]
+ ["41" lstore_2]
+ ["42" lstore_3]
+
+ ["43" fstore_0]
+ ["44" fstore_1]
+ ["45" fstore_2]
+ ["46" fstore_3]
+
+ ["47" dstore_0]
+ ["48" dstore_1]
+ ["49" dstore_2]
+ ["4A" dstore_3]
+
+ ["4B" astore_0]
+ ["4C" astore_1]
+ ["4D" astore_2]
+ ["4E" astore_3])
+ <array_loads> (template [<code> <name>]
+ [[<code> <name> [] []]]
+
+ ["2E" iaload]
+ ["2F" laload]
+ ["30" faload]
+ ["31" daload]
+ ["32" aaload]
+ ["33" baload]
+ ["34" caload]
+ ["35" saload])
+ <array_stores> (template [<code> <name>]
+ [[<code> <name> [] []]]
+
+ ["4f" iastore]
+ ["50" lastore]
+ ["51" fastore]
+ ["52" dastore]
+ ["53" aastore]
+ ["54" bastore]
+ ["55" castore]
+ ["56" sastore])
+ <arithmetic> (template [<code> <name>]
+ [[<code> <name> [] []]]
+
+ ["60" iadd]
+ ["64" isub]
+ ["68" imul]
+ ["6c" idiv]
+ ["70" irem]
+ ["74" ineg]
+ ["78" ishl]
+ ["7a" ishr]
+ ["7c" iushr]
+ ["7e" iand]
+ ["80" ior]
+ ["82" ixor]
+
+ ["61" ladd]
+ ["65" lsub]
+ ["69" lmul]
+ ["6D" ldiv]
+ ["71" lrem]
+ ["75" lneg]
+ ["7F" land]
+ ["81" lor]
+ ["83" lxor]
+
+ ["62" fadd]
+ ["66" fsub]
+ ["6A" fmul]
+ ["6E" fdiv]
+ ["72" frem]
+ ["76" fneg]
+
+ ["63" dadd]
+ ["67" dsub]
+ ["6B" dmul]
+ ["6F" ddiv]
+ ["73" drem]
+ ["77" dneg])
+ <conversions> (template [<code> <name>]
+ [[<code> <name> [] []]]
+
+ ["88" l2i]
+ ["89" l2f]
+ ["8A" l2d]
+
+ ["8B" f2i]
+ ["8C" f2l]
+ ["8D" f2d]
+
+ ["8E" d2i]
+ ["8F" d2l]
+ ["90" d2f]
+
+ ["85" i2l]
+ ["86" i2f]
+ ["87" i2d]
+ ["91" i2b]
+ ["92" i2c]
+ ["93" i2s])
+ <comparisons> (template [<code> <name>]
+ [[<code> <name> [] []]]
+
+ ["94" lcmp]
+
+ ["95" fcmpl]
+ ["96" fcmpg]
+
+ ["97" dcmpl]
+ ["98" dcmpg])
+ <returns> (template [<code> <name>]
+ [[<code> <name> [] []]]
+
+ ["AC" ireturn]
+ ["AD" lreturn]
+ ["AE" freturn]
+ ["AF" dreturn]
+ ["B0" areturn]
+ ["B1" return]
+ )
+ <jumps> (template [<code> <name>]
+ [[<code> <name> [[jump Jump]] [jump]]]
+
+ ["99" ifeq]
+ ["9A" ifne]
+ ["9B" iflt]
+ ["9C" ifge]
+ ["9D" ifgt]
+ ["9E" ifle]
+
+ ["9F" if_icmpeq]
+ ["A0" if_icmpne]
+ ["A1" if_icmplt]
+ ["A2" if_icmpge]
+ ["A3" if_icmpgt]
+ ["A4" if_icmple]
+
+ ["A5" if_acmpeq]
+ ["A6" if_acmpne]
+
+ ["A7" goto]
+ ["A8" jsr]
+
+ ["C6" ifnull]
+ ["C7" ifnonnull])
+ <fields> (template [<code> <name>]
+ [[<code> <name> [[index (Index (Reference Value))]] [(///index.value index)]]]
+
+ ["B2" getstatic/1] ["B2" getstatic/2]
+ ["B3" putstatic/1] ["B3" putstatic/2]
+ ["B4" getfield/1] ["B4" getfield/2]
+ ["B5" putfield/1] ["B5" putfield/2])]
+ (template [<arity> <definitions>]
+ [(with_expansions [<definitions>' (template.splice <definitions>)]
+ (template [<code> <name> <instruction_inputs> <arity_inputs>]
+ [(with_expansions [<inputs>' (template.splice <instruction_inputs>)
+ <input_types> (template [<input_name> <input_type>]
+ [<input_type>]
+
+ <inputs>')
+ <input_names> (template [<input_name> <input_type>]
+ [<input_name>]
+
+ <inputs>')]
+ (def: #export <name>
+ [Estimator (-> [<input_types>] Instruction)]
+ (let [[estimator <arity>'] <arity>]
+ [estimator
+ (function (_ [<input_names>])
+ (`` (<arity>' (hex <code>) (~~ (template.splice <arity_inputs>)))))])))]
+
+ <definitions>'
+ ))]
+
+ [..nullary
+ [["00" nop [] []]
+ <constants>
+ ["57" pop [] []]
+ ["58" pop2 [] []]
+ ["59" dup [] []]
+ ["5A" dup_x1 [] []]
+ ["5B" dup_x2 [] []]
+ ["5C" dup2 [] []]
+ ["5D" dup2_x1 [] []]
+ ["5E" dup2_x2 [] []]
+ ["5F" swap [] []]
+ <simple_register_loads>
+ <array_loads>
+ <simple_register_stores>
+ <array_stores>
+ <arithmetic>
+ ["79" lshl [] []]
+ ["7B" lshr [] []]
+ ["7D" lushr [] []]
+ <conversions>
+ <comparisons>
+ <returns>
+ ["BE" arraylength [] []]
+ ["BF" athrow [] []]
+ ["C2" monitorenter [] []]
+ ["C3" monitorexit [] []]]]
+
+ [..unary/1
+ [["12" ldc [[index U1]] [index]]
+ <register_loads>
+ <register_stores>
+ ["A9" ret [[register Register]] [register]]
+ ["BC" newarray [[type Primitive_Array_Type]] [(..code type)]]]]
+
+ [..unary/1'
+ [["10" bipush [[byte S1]] [byte]]]]
+
+ [..unary/2
+ [["13" ldc_w/integer [[index (Index ///constant.Integer)]] [(///index.value index)]]
+ ["13" ldc_w/float [[index (Index ///constant.Float)]] [(///index.value index)]]
+ ["13" ldc_w/string [[index (Index ///constant.String)]] [(///index.value index)]]
+ ["14" ldc2_w/long [[index (Index ///constant.Long)]] [(///index.value index)]]
+ ["14" ldc2_w/double [[index (Index ///constant.Double)]] [(///index.value index)]]
+ <fields>
+ ["BB" new [[index (Index Class)]] [(///index.value index)]]
+ ["BD" anewarray [[index (Index Class)]] [(///index.value index)]]
+ ["C0" checkcast [[index (Index Class)]] [(///index.value index)]]
+ ["C1" instanceof [[index (Index Class)]] [(///index.value index)]]
+ ["B6" invokevirtual [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index)]]
+ ["B7" invokespecial [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index)]]
+ ["B8" invokestatic [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index)]]]]
+
+ [..unary/2'
+ [["11" sipush [[short S2]] [short]]]]
+
+ [..jump/2
+ [<jumps>]]
+
+ [..jump/4
+ [["C8" goto_w [[jump Big_Jump]] [jump]]
+ ["C9" jsr_w [[jump Big_Jump]] [jump]]]]
+
+ [..binary/11
+ [["84" iinc [[register Register] [byte U1]] [register byte]]]]
+
+ [..binary/21
+ [["C5" multianewarray [[index (Index Class)] [count U1]] [(///index.value index) count]]]]
+
+ [..trinary/211
+ [["B9" invokeinterface [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index) count (try.assume (///unsigned.u1 0))]]]]
+ ))
+
+(def: (switch_padding offset)
+ (-> Nat Nat)
+ (let [parameter_start (n.+ (///unsigned.value ..opcode_size)
+ offset)]
+ (n.% 4
+ (n.- (n.% 4 parameter_start)
+ 4))))
+
+(def: #export tableswitch
+ [(-> Nat Estimator)
+ (-> S4 Big_Jump [Big_Jump (List Big_Jump)] Instruction)]
+ (let [estimator (: (-> Nat Estimator)
+ (function (_ amount_of_afterwards offset)
+ (|> ($_ n.+
+ (///unsigned.value ..opcode_size)
+ (switch_padding (///unsigned.value (//address.value offset)))
+ (///unsigned.value ..big_jump_size)
+ (///unsigned.value ..integer_size)
+ (///unsigned.value ..integer_size)
+ (n.* (///unsigned.value ..big_jump_size)
+ (inc amount_of_afterwards)))
+ ///unsigned.u2
+ try.assume)))]
+ [estimator
+ (function (_ minimum default [at_minimum afterwards])
+ (let [amount_of_afterwards (list.size afterwards)
+ estimator (estimator amount_of_afterwards)]
+ (function (_ [size mutation])
+ (let [padding (switch_padding size)
+ tableswitch_size (try.assume
+ (do {! try.monad}
+ [size (///unsigned.u2 size)]
+ (\ ! map (|>> estimator ///unsigned.value)
+ (//address.move size //address.start))))
+ tableswitch_mutation (: Mutation
+ (function (_ [offset binary])
+ [(n.+ tableswitch_size offset)
+ (try.assume
+ (do {! try.monad}
+ [amount_of_afterwards (|> amount_of_afterwards .int ///signed.s4)
+ maximum (///signed.+/4 minimum amount_of_afterwards)
+ _ (binary.write/8 offset (hex "AA") binary)
+ #let [offset (n.+ (///unsigned.value ..opcode_size) offset)]
+ _ (case padding
+ 3 (do !
+ [_ (binary.write/8 offset 0 binary)]
+ (binary.write/16 (inc offset) 0 binary))
+ 2 (binary.write/16 offset 0 binary)
+ 1 (binary.write/8 offset 0 binary)
+ _ (wrap binary))
+ #let [offset (n.+ padding offset)]
+ _ (binary.write/32 offset (///signed.value default) binary)
+ #let [offset (n.+ (///unsigned.value ..big_jump_size) offset)]
+ _ (binary.write/32 offset (///signed.value minimum) binary)
+ #let [offset (n.+ (///unsigned.value ..integer_size) offset)]
+ _ (binary.write/32 offset (///signed.value maximum) binary)]
+ (loop [offset (n.+ (///unsigned.value ..integer_size) offset)
+ afterwards (: (List Big_Jump)
+ (#.Cons at_minimum afterwards))]
+ (case afterwards
+ #.Nil
+ (wrap binary)
+
+ (#.Cons head tail)
+ (do !
+ [_ (binary.write/32 offset (///signed.value head) binary)]
+ (recur (n.+ (///unsigned.value ..big_jump_size) offset)
+ tail))))))]))]
+ [(n.+ tableswitch_size
+ size)
+ (|>> mutation tableswitch_mutation)]))))]))
+
+(def: #export lookupswitch
+ [(-> Nat Estimator)
+ (-> Big_Jump (List [S4 Big_Jump]) Instruction)]
+ (let [case_size (n.+ (///unsigned.value ..integer_size)
+ (///unsigned.value ..big_jump_size))
+ estimator (: (-> Nat Estimator)
+ (function (_ amount_of_cases offset)
+ (|> ($_ n.+
+ (///unsigned.value ..opcode_size)
+ (switch_padding (///unsigned.value (//address.value offset)))
+ (///unsigned.value ..big_jump_size)
+ (///unsigned.value ..integer_size)
+ (n.* amount_of_cases case_size))
+ ///unsigned.u2
+ try.assume)))]
+ [estimator
+ (function (_ default cases)
+ (let [amount_of_cases (list.size cases)
+ estimator (estimator amount_of_cases)]
+ (function (_ [size mutation])
+ (let [padding (switch_padding size)
+ lookupswitch_size (try.assume
+ (do {! try.monad}
+ [size (///unsigned.u2 size)]
+ (\ ! map (|>> estimator ///unsigned.value)
+ (//address.move size //address.start))))
+ lookupswitch_mutation (: Mutation
+ (function (_ [offset binary])
+ [(n.+ lookupswitch_size offset)
+ (try.assume
+ (do {! try.monad}
+ [_ (binary.write/8 offset (hex "AB") binary)
+ #let [offset (n.+ (///unsigned.value ..opcode_size) offset)]
+ _ (case padding
+ 3 (do !
+ [_ (binary.write/8 offset 0 binary)]
+ (binary.write/16 (inc offset) 0 binary))
+ 2 (binary.write/16 offset 0 binary)
+ 1 (binary.write/8 offset 0 binary)
+ _ (wrap binary))
+ #let [offset (n.+ padding offset)]
+ _ (binary.write/32 offset (///signed.value default) binary)
+ #let [offset (n.+ (///unsigned.value ..big_jump_size) offset)]
+ _ (binary.write/32 offset amount_of_cases binary)]
+ (loop [offset (n.+ (///unsigned.value ..integer_size) offset)
+ cases cases]
+ (case cases
+ #.Nil
+ (wrap binary)
+
+ (#.Cons [value jump] tail)
+ (do !
+ [_ (binary.write/32 offset (///signed.value value) binary)
+ _ (binary.write/32 (n.+ (///unsigned.value ..integer_size) offset) (///signed.value jump) binary)]
+ (recur (n.+ case_size offset)
+ tail))))))]))]
+ [(n.+ lookupswitch_size
+ size)
+ (|>> mutation lookupswitch_mutation)]))))]))
+
+(implementation: #export monoid
+ (Monoid Instruction)
+
+ (def: identity ..empty)
+
+ (def: (compose left right)
+ (|>> left right)))
diff --git a/stdlib/source/library/lux/target/jvm/bytecode/jump.lux b/stdlib/source/library/lux/target/jvm/bytecode/jump.lux
new file mode 100644
index 000000000..2873ef781
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/bytecode/jump.lux
@@ -0,0 +1,27 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." format #_
+ ["#" binary (#+ Writer)]]]]]
+ ["." /// #_
+ [encoding
+ ["#." signed (#+ S2 S4)]]])
+
+(type: #export Jump S2)
+
+(def: #export equivalence
+ (Equivalence Jump)
+ ///signed.equivalence)
+
+(def: #export writer
+ (Writer Jump)
+ ///signed.writer/2)
+
+(type: #export Big_Jump S4)
+
+(def: #export lift
+ (-> Jump Big_Jump)
+ ///signed.lift/4)
diff --git a/stdlib/source/library/lux/target/jvm/class.lux b/stdlib/source/library/lux/target/jvm/class.lux
new file mode 100644
index 000000000..7f6705de8
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/class.lux
@@ -0,0 +1,134 @@
+ (.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ ["." monad (#+ do)]]
+ [control
+ ["." state]
+ ["." try (#+ Try)]]
+ [data
+ ["." product]
+ [format
+ [".F" binary (#+ Writer) ("#\." monoid)]]
+ [collection
+ ["." row (#+ Row)]]]]]
+ ["." // #_
+ ["#." modifier (#+ Modifier modifiers:)]
+ ["#." version (#+ Version Minor Major)]
+ ["#." magic (#+ Magic)]
+ ["#." index (#+ Index)]
+ ["#." attribute (#+ Attribute)]
+ ["#." field (#+ Field)]
+ ["#." method (#+ Method)]
+ [encoding
+ ["#." unsigned]
+ ["#." name (#+ Internal)]]
+ ["#." constant (#+ Constant)
+ ["#/." pool (#+ Pool Resource)]]])
+
+(type: #export #rec Class
+ {#magic Magic
+ #minor_version Minor
+ #major_version Major
+ #constant_pool Pool
+ #modifier (Modifier Class)
+ #this (Index //constant.Class)
+ #super (Index //constant.Class)
+ #interfaces (Row (Index //constant.Class))
+ #fields (Row Field)
+ #methods (Row Method)
+ #attributes (Row Attribute)})
+
+(modifiers: Class
+ ["0001" public]
+ ["0010" final]
+ ["0020" super]
+ ["0200" interface]
+ ["0400" abstract]
+ ["1000" synthetic]
+ ["2000" annotation]
+ ["4000" enum]
+ )
+
+(def: #export equivalence
+ (Equivalence Class)
+ ($_ product.equivalence
+ //unsigned.equivalence
+ //unsigned.equivalence
+ //unsigned.equivalence
+ //constant/pool.equivalence
+ //modifier.equivalence
+ //index.equivalence
+ //index.equivalence
+ (row.equivalence //index.equivalence)
+ (row.equivalence //field.equivalence)
+ (row.equivalence //method.equivalence)
+ (row.equivalence //attribute.equivalence)))
+
+(def: (install_classes this super interfaces)
+ (-> Internal Internal (List Internal)
+ (Resource [(Index //constant.Class) (Index //constant.Class) (Row (Index //constant.Class))]))
+ (do {! //constant/pool.monad}
+ [@this (//constant/pool.class this)
+ @super (//constant/pool.class super)
+ @interfaces (: (Resource (Row (Index //constant.Class)))
+ (monad.fold ! (function (_ interface @interfaces)
+ (do !
+ [@interface (//constant/pool.class interface)]
+ (wrap (row.add @interface @interfaces))))
+ row.empty
+ interfaces))]
+ (wrap [@this @super @interfaces])))
+
+(def: #export (class version modifier
+ this super interfaces
+ fields methods attributes)
+ (-> Major (Modifier Class)
+ Internal Internal (List Internal)
+ (List (Resource Field))
+ (List (Resource Method))
+ (Row Attribute)
+ (Try Class))
+ (do try.monad
+ [[pool [@this @super @interfaces] =fields =methods]
+ (<| (state.run' //constant/pool.empty)
+ (do //constant/pool.monad
+ [classes (install_classes this super interfaces)
+ =fields (monad.seq //constant/pool.monad fields)
+ =methods (monad.seq //constant/pool.monad methods)]
+ (wrap [classes =fields =methods])))]
+ (wrap {#magic //magic.code
+ #minor_version //version.default_minor
+ #major_version version
+ #constant_pool pool
+ #modifier modifier
+ #this @this
+ #super @super
+ #interfaces @interfaces
+ #fields (row.from_list =fields)
+ #methods (row.from_list =methods)
+ #attributes attributes})))
+
+(def: #export (writer class)
+ (Writer Class)
+ (`` ($_ binaryF\compose
+ (~~ (template [<writer> <slot>]
+ [(<writer> (get@ <slot> class))]
+
+ [//magic.writer #magic]
+ [//version.writer #minor_version]
+ [//version.writer #major_version]
+ [//constant/pool.writer #constant_pool]
+ [//modifier.writer #modifier]
+ [//index.writer #this]
+ [//index.writer #super]))
+ (~~ (template [<writer> <slot>]
+ [((binaryF.row/16 <writer>) (get@ <slot> class))]
+
+ [//index.writer #interfaces]
+ [//field.writer #fields]
+ [//method.writer #methods]
+ [//attribute.writer #attributes]
+ ))
+ )))
diff --git a/stdlib/source/library/lux/target/jvm/constant.lux b/stdlib/source/library/lux/target/jvm/constant.lux
new file mode 100644
index 000000000..663dc472f
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/constant.lux
@@ -0,0 +1,246 @@
+(.module:
+ [library
+ [lux #*
+ ["." ffi (#+ import:)]
+ ["@" target]
+ [abstract
+ [monad (#+ do)]
+ ["." equivalence (#+ Equivalence)]]
+ [data
+ ["." sum]
+ ["." product]
+ ["." text]
+ [format
+ [".F" binary (#+ Writer) ("#\." monoid)]]
+ [collection
+ ["." row (#+ Row)]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["." i32 (#+ I32)]
+ ["." i64]
+ ["." int]
+ ["." frac]]]
+ [type
+ abstract]]]
+ ["." / #_
+ ["#." tag]
+ ["/#" // #_
+ ["#." index (#+ Index)]
+ [type
+ ["#." category]
+ ["#." descriptor (#+ Descriptor)]]
+ [encoding
+ ["#." unsigned]]]])
+
+(type: #export UTF8 Text)
+
+(def: utf8_writer
+ (Writer UTF8)
+ binaryF.utf8/16)
+
+(abstract: #export Class
+ (Index UTF8)
+
+ (def: #export index
+ (-> Class (Index UTF8))
+ (|>> :representation))
+
+ (def: #export class
+ (-> (Index UTF8) Class)
+ (|>> :abstraction))
+
+ (def: #export class_equivalence
+ (Equivalence Class)
+ (\ equivalence.functor map
+ ..index
+ //index.equivalence))
+
+ (def: class_writer
+ (Writer Class)
+ (|>> :representation //index.writer))
+ )
+
+(import: java/lang/Float
+ ["#::."
+ (#static floatToRawIntBits #manual [float] int)])
+
+(implementation: #export float_equivalence
+ (Equivalence java/lang/Float)
+
+ (def: (= parameter subject)
+ (for {@.old
+ ("jvm feq" parameter subject)
+
+ @.jvm
+ ("jvm float ="
+ ("jvm object cast" parameter)
+ ("jvm object cast" subject))})))
+
+(import: java/lang/Double
+ ["#::."
+ (#static doubleToRawLongBits [double] long)])
+
+(abstract: #export (Value kind)
+ kind
+
+ (def: #export value
+ (All [kind] (-> (Value kind) kind))
+ (|>> :representation))
+
+ (def: #export (value_equivalence Equivalence<kind>)
+ (All [kind]
+ (-> (Equivalence kind)
+ (Equivalence (Value kind))))
+ (\ equivalence.functor map
+ (|>> :representation)
+ Equivalence<kind>))
+
+ (template [<constructor> <type> <marker>]
+ [(type: #export <type> (Value <marker>))
+
+ (def: #export <constructor>
+ (-> <marker> <type>)
+ (|>> :abstraction))]
+
+ [integer Integer I32]
+ [float Float java/lang/Float]
+ [long Long .Int]
+ [double Double Frac]
+ [string String (Index UTF8)]
+ )
+
+ (template [<writer_name> <type> <write> <writer>]
+ [(def: <writer_name>
+ (Writer <type>)
+ (`` (|>> :representation
+ (~~ (template.splice <write>))
+ (~~ (template.splice <writer>)))))]
+
+ [integer_writer Integer [] [binaryF.bits/32]]
+ [float_writer Float [java/lang/Float::floatToRawIntBits ffi.int_to_long (:as I64)] [i32.i32 binaryF.bits/32]]
+ [long_writer Long [] [binaryF.bits/64]]
+ [double_writer Double [java/lang/Double::doubleToRawLongBits] [binaryF.bits/64]]
+ [string_writer String [] [//index.writer]]
+ )
+ )
+
+(type: #export (Name_And_Type of)
+ {#name (Index UTF8)
+ #descriptor (Index (Descriptor of))})
+
+(type: #export (Reference of)
+ {#class (Index Class)
+ #name_and_type (Index (Name_And_Type of))})
+
+(template [<type> <equivalence> <writer>]
+ [(def: #export <equivalence>
+ (Equivalence (<type> Any))
+ ($_ product.equivalence
+ //index.equivalence
+ //index.equivalence))
+
+ (def: <writer>
+ (Writer (<type> Any))
+ ($_ binaryF.and
+ //index.writer
+ //index.writer))]
+
+ [Name_And_Type name_and_type_equivalence name_and_type_writer]
+ [Reference reference_equivalence reference_writer]
+ )
+
+(type: #export Constant
+ (#UTF8 UTF8)
+ (#Integer Integer)
+ (#Float Float)
+ (#Long Long)
+ (#Double Double)
+ (#Class Class)
+ (#String String)
+ (#Field (Reference //category.Value))
+ (#Method (Reference //category.Method))
+ (#Interface_Method (Reference //category.Method))
+ (#Name_And_Type (Name_And_Type Any)))
+
+(def: #export (size constant)
+ (-> Constant Nat)
+ (case constant
+ (^or (#Long _) (#Double _))
+ 2
+
+ _
+ 1))
+
+(def: #export equivalence
+ (Equivalence Constant)
+ ## TODO: Delete the explicit "implementation" and use the combinator
+ ## version below as soon as the new format for variants is implemented.
+ (implementation
+ (def: (= reference sample)
+ (case [reference sample]
+ (^template [<tag> <equivalence>]
+ [[(<tag> reference) (<tag> sample)]
+ (\ <equivalence> = reference sample)])
+ ([#UTF8 text.equivalence]
+ [#Integer (..value_equivalence i32.equivalence)]
+ [#Long (..value_equivalence int.equivalence)]
+ [#Float (..value_equivalence float_equivalence)]
+ [#Double (..value_equivalence frac.equivalence)]
+ [#Class ..class_equivalence]
+ [#String (..value_equivalence //index.equivalence)]
+ [#Field ..reference_equivalence]
+ [#Method ..reference_equivalence]
+ [#Interface_Method ..reference_equivalence]
+ [#Name_And_Type ..name_and_type_equivalence])
+
+ _
+ false)))
+ ## ($_ sum.equivalence
+ ## ## #UTF8
+ ## text.equivalence
+ ## ## #Long
+ ## (..value_equivalence int.equivalence)
+ ## ## #Double
+ ## (..value_equivalence frac.equivalence)
+ ## ## #Class
+ ## ..class_equivalence
+ ## ## #String
+ ## (..value_equivalence //index.equivalence)
+ ## ## #Field
+ ## ..reference_equivalence
+ ## ## #Method
+ ## ..reference_equivalence
+ ## ## #Interface_Method
+ ## ..reference_equivalence
+ ## ## #Name_And_Type
+ ## ..name_and_type_equivalence
+ ## )
+ )
+
+(def: #export writer
+ (Writer Constant)
+ (with_expansions [<constants> (as_is [#UTF8 /tag.utf8 ..utf8_writer]
+ [#Integer /tag.integer ..integer_writer]
+ [#Float /tag.float ..float_writer]
+ [#Long /tag.long ..long_writer]
+ [#Double /tag.double ..double_writer]
+ [#Class /tag.class ..class_writer]
+ [#String /tag.string ..string_writer]
+ [#Field /tag.field ..reference_writer]
+ [#Method /tag.method ..reference_writer]
+ [#Interface_Method /tag.interface_method ..reference_writer]
+ [#Name_And_Type /tag.name_and_type ..name_and_type_writer]
+ ## TODO: Method_Handle
+ ## TODO: Method_Type
+ ## TODO: Invoke_Dynamic
+ )]
+ (function (_ value)
+ (case value
+ (^template [<case> <tag> <writer>]
+ [(<case> value)
+ (binaryF\compose (/tag.writer <tag>)
+ (<writer> value))])
+ (<constants>)
+ ))))
diff --git a/stdlib/source/library/lux/target/jvm/constant/pool.lux b/stdlib/source/library/lux/target/jvm/constant/pool.lux
new file mode 100644
index 000000000..e7fa465d8
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/constant/pool.lux
@@ -0,0 +1,158 @@
+(.module:
+ [library
+ [lux #*
+ ["." ffi]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ Monad do)]]
+ [control
+ ["." state (#+ State')]
+ ["." try (#+ Try)]]
+ [data
+ ["." product]
+ ["." text]
+ ["." format #_
+ ["#" binary (#+ Writer) ("specification\." monoid)]]
+ [collection
+ ["." row (#+ Row) ("#\." fold)]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["." i32]
+ ["n" nat]
+ ["." int]
+ ["." frac]]]
+ [type
+ abstract]]]
+ ["." // (#+ UTF8 String Class Integer Float Long Double Constant Name_And_Type Reference)
+ [//
+ [encoding
+ ["#." name (#+ Internal External)]
+ ["#." unsigned]]
+ ["#." index (#+ Index)]
+ [type
+ [category (#+ Value Method)]
+ ["#." descriptor (#+ Descriptor)]]]])
+
+(type: #export Pool [Index (Row [Index Constant])])
+
+(def: #export equivalence
+ (Equivalence Pool)
+ (product.equivalence //index.equivalence
+ (row.equivalence (product.equivalence //index.equivalence
+ //.equivalence))))
+
+(type: #export (Resource a)
+ (State' Try Pool a))
+
+(def: #export monad
+ (Monad Resource)
+ (state.with try.monad))
+
+(template: (!add <tag> <equivalence> <value>)
+ (function (_ [current pool])
+ (let [<value>' <value>]
+ (with_expansions [<try_again> (as_is (recur (.inc idx)))]
+ (loop [idx 0]
+ (case (row.nth idx pool)
+ (#try.Success entry)
+ (case entry
+ [index (<tag> reference)]
+ (if (\ <equivalence> = reference <value>')
+ (#try.Success [[current pool]
+ index])
+ <try_again>)
+
+ _
+ <try_again>)
+
+ (#try.Failure _)
+ (let [new (<tag> <value>')]
+ (do {! try.monad}
+ [@new (//unsigned.u2 (//.size new))
+ next (: (Try Index)
+ (|> current
+ //index.value
+ (//unsigned.+/2 @new)
+ (\ ! map //index.index)))]
+ (wrap [[next
+ (row.add [current new] pool)]
+ current])))))))))
+
+(template: (!index <index>)
+ (|> <index> //index.value //unsigned.value))
+
+(type: (Adder of)
+ (-> of (Resource (Index of))))
+
+(template [<name> <type> <tag> <equivalence>]
+ [(def: #export (<name> value)
+ (Adder <type>)
+ (!add <tag> <equivalence> value))]
+
+ [integer Integer #//.Integer (//.value_equivalence i32.equivalence)]
+ [float Float #//.Float (//.value_equivalence //.float_equivalence)]
+ [long Long #//.Long (//.value_equivalence int.equivalence)]
+ [double Double #//.Double (//.value_equivalence frac.equivalence)]
+ [utf8 UTF8 #//.UTF8 text.equivalence]
+ )
+
+(def: #export (string value)
+ (-> Text (Resource (Index String)))
+ (do ..monad
+ [@value (utf8 value)
+ #let [value (//.string @value)]]
+ (!add #//.String (//.value_equivalence //index.equivalence) value)))
+
+(def: #export (class name)
+ (-> Internal (Resource (Index Class)))
+ (do ..monad
+ [@name (utf8 (//name.read name))
+ #let [value (//.class @name)]]
+ (!add #//.Class //.class_equivalence value)))
+
+(def: #export (descriptor value)
+ (All [kind]
+ (-> (Descriptor kind)
+ (Resource (Index (Descriptor kind)))))
+ (let [value (//descriptor.descriptor value)]
+ (!add #//.UTF8 text.equivalence value)))
+
+(type: #export (Member of)
+ {#name UTF8
+ #descriptor (Descriptor of)})
+
+(def: #export (name_and_type [name descriptor])
+ (All [of]
+ (-> (Member of) (Resource (Index (Name_And_Type of)))))
+ (do ..monad
+ [@name (utf8 name)
+ @descriptor (..descriptor descriptor)]
+ (!add #//.Name_And_Type //.name_and_type_equivalence {#//.name @name #//.descriptor @descriptor})))
+
+(template [<name> <tag> <of>]
+ [(def: #export (<name> class member)
+ (-> External (Member <of>) (Resource (Index (Reference <of>))))
+ (do ..monad
+ [@class (..class (//name.internal class))
+ @name_and_type (name_and_type member)]
+ (!add <tag> //.reference_equivalence {#//.class @class #//.name_and_type @name_and_type})))]
+
+ [field #//.Field Value]
+ [method #//.Method Method]
+ [interface_method #//.Interface_Method Method]
+ )
+
+(def: #export writer
+ (Writer Pool)
+ (function (_ [next pool])
+ (row\fold (function (_ [_index post] pre)
+ (specification\compose pre (//.writer post)))
+ (format.bits/16 (!index next))
+ pool)))
+
+(def: #export empty
+ Pool
+ [(|> 1 //unsigned.u2 try.assume //index.index)
+ row.empty])
diff --git a/stdlib/source/library/lux/target/jvm/constant/tag.lux b/stdlib/source/library/lux/target/jvm/constant/tag.lux
new file mode 100644
index 000000000..414de077b
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/constant/tag.lux
@@ -0,0 +1,50 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [control
+ ["." try]]
+ [data
+ [format
+ [binary (#+ Writer)]]]
+ [type
+ abstract]]]
+ ["." /// #_
+ [encoding
+ ["#." unsigned (#+ U1) ("u1//." equivalence)]]])
+
+(abstract: #export Tag
+ U1
+
+ (implementation: #export equivalence
+ (Equivalence Tag)
+ (def: (= reference sample)
+ (u1//= (:representation reference)
+ (:representation sample))))
+
+ (template [<code> <name>]
+ [(def: #export <name>
+ Tag
+ (|> <code> ///unsigned.u1 try.assume :abstraction))]
+
+ [01 utf8]
+ [03 integer]
+ [04 float]
+ [05 long]
+ [06 double]
+ [07 class]
+ [08 string]
+ [09 field]
+ [10 method]
+ [11 interface_method]
+ [12 name_and_type]
+ [15 method_handle]
+ [16 method_type]
+ [18 invoke_dynamic]
+ )
+
+ (def: #export writer
+ (Writer Tag)
+ (|>> :representation ///unsigned.writer/1))
+ )
diff --git a/stdlib/source/library/lux/target/jvm/encoding/name.lux b/stdlib/source/library/lux/target/jvm/encoding/name.lux
new file mode 100644
index 000000000..5a1982d3e
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/encoding/name.lux
@@ -0,0 +1,40 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ ["." text
+ ["%" format (#+ format)]]]
+ [type
+ abstract]]])
+
+(def: #export internal_separator "/")
+(def: #export external_separator ".")
+
+(type: #export External Text)
+
+(abstract: #export Internal
+ Text
+
+ (def: #export internal
+ (-> External Internal)
+ (|>> (text.replace_all ..external_separator
+ ..internal_separator)
+ :abstraction))
+
+ (def: #export read
+ (-> Internal Text)
+ (|>> :representation))
+
+ (def: #export external
+ (-> Internal External)
+ (|>> :representation
+ (text.replace_all ..internal_separator
+ ..external_separator))))
+
+(def: #export sanitize
+ (-> Text External)
+ (|>> ..internal ..external))
+
+(def: #export (qualify package class)
+ (-> Text External External)
+ (format (..sanitize package) ..external_separator class))
diff --git a/stdlib/source/library/lux/target/jvm/encoding/signed.lux b/stdlib/source/library/lux/target/jvm/encoding/signed.lux
new file mode 100644
index 000000000..a914dfc3c
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/encoding/signed.lux
@@ -0,0 +1,107 @@
+(.module:
+ [library
+ [lux (#- int)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ [text
+ ["%" format (#+ format)]]
+ ["." format #_
+ ["#" binary (#+ Writer)]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["." i64]
+ ["n" nat]
+ ["i" int]]]
+ [type
+ abstract]]])
+
+(abstract: #export (Signed brand)
+ Int
+
+ (def: #export value
+ (-> (Signed Any) Int)
+ (|>> :representation))
+
+ (implementation: #export equivalence
+ (All [brand] (Equivalence (Signed brand)))
+ (def: (= reference sample)
+ (i.= (:representation reference) (:representation sample))))
+
+ (implementation: #export order
+ (All [brand] (Order (Signed brand)))
+
+ (def: &equivalence ..equivalence)
+ (def: (< reference sample)
+ (i.< (:representation reference) (:representation sample))))
+
+ (exception: #export (value_exceeds_the_scope {value Int}
+ {scope Nat})
+ (exception.report
+ ["Value" (%.int value)]
+ ["Scope (in bytes)" (%.nat scope)]))
+
+ (template [<bytes> <name> <size> <constructor> <maximum> <+> <->]
+ [(with_expansions [<raw> (template.identifier [<name> "'"])]
+ (abstract: #export <raw> Any)
+ (type: #export <name> (Signed <raw>)))
+
+ (def: #export <size> <bytes>)
+
+ (def: #export <maximum>
+ <name>
+ (|> <bytes> (n.* i64.bits_per_byte) dec i64.mask :abstraction))
+
+ (def: #export <constructor>
+ (-> Int (Try <name>))
+ (let [positive (|> <bytes> (n.* i64.bits_per_byte) i64.mask)
+ negative (|> positive .int (i.right_shift 1) i64.not)]
+ (function (_ value)
+ (if (i.= (if (i.< +0 value)
+ (i64.or negative value)
+ (i64.and positive value))
+ value)
+ (#try.Success (:abstraction value))
+ (exception.throw ..value_exceeds_the_scope [value <size>])))))
+
+ (template [<abstract_operation> <concrete_operation>]
+ [(def: #export (<abstract_operation> parameter subject)
+ (-> <name> <name> (Try <name>))
+ (<constructor>
+ (<concrete_operation> (:representation parameter)
+ (:representation subject))))]
+
+ [<+> i.+]
+ [<-> i.-]
+ )]
+
+ [1 S1 bytes/1 s1 maximum/1 +/1 -/1]
+ [2 S2 bytes/2 s2 maximum/2 +/2 -/2]
+ [4 S4 bytes/4 s4 maximum/4 +/4 -/4]
+ )
+
+ (template [<name> <from> <to>]
+ [(def: #export <name>
+ (-> <from> <to>)
+ (|>> :transmutation))]
+
+ [lift/2 S1 S2]
+ [lift/4 S2 S4]
+ )
+
+ (template [<writer_name> <type> <writer>]
+ [(def: #export <writer_name>
+ (Writer <type>)
+ (|>> :representation <writer>))]
+
+ [writer/1 S1 format.bits/8]
+ [writer/2 S2 format.bits/16]
+ [writer/4 S4 format.bits/32]
+ )
+ )
diff --git a/stdlib/source/library/lux/target/jvm/encoding/unsigned.lux b/stdlib/source/library/lux/target/jvm/encoding/unsigned.lux
new file mode 100644
index 000000000..d8299fa65
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/encoding/unsigned.lux
@@ -0,0 +1,121 @@
+(.module:
+ [library
+ [lux (#- nat)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ [text
+ ["%" format (#+ format)]]
+ ["." format #_
+ ["#" binary (#+ Writer)]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["n" nat]
+ ["." i64]]]
+ [type
+ abstract]]])
+
+(abstract: #export (Unsigned brand)
+ Nat
+
+ (def: #export value
+ (-> (Unsigned Any) Nat)
+ (|>> :representation))
+
+ (implementation: #export equivalence
+ (All [brand] (Equivalence (Unsigned brand)))
+ (def: (= reference sample)
+ (n.= (:representation reference)
+ (:representation sample))))
+
+ (implementation: #export order
+ (All [brand] (Order (Unsigned brand)))
+
+ (def: &equivalence ..equivalence)
+ (def: (< reference sample)
+ (n.< (:representation reference)
+ (:representation sample))))
+
+ (exception: #export (value_exceeds_the_maximum {type Name}
+ {value Nat}
+ {maximum (Unsigned Any)})
+ (exception.report
+ ["Type" (%.name type)]
+ ["Value" (%.nat value)]
+ ["Maximum" (%.nat (:representation maximum))]))
+
+ (exception: #export [brand] (subtraction_cannot_yield_negative_value
+ {type Name}
+ {parameter (Unsigned brand)}
+ {subject (Unsigned brand)})
+ (exception.report
+ ["Type" (%.name type)]
+ ["Parameter" (%.nat (:representation parameter))]
+ ["Subject" (%.nat (:representation subject))]))
+
+ (template [<bytes> <name> <size> <constructor> <maximum> <+> <-> <max>]
+ [(with_expansions [<raw> (template.identifier [<name> "'"])]
+ (abstract: #export <raw> Any)
+ (type: #export <name> (Unsigned <raw>)))
+
+ (def: #export <size> <bytes>)
+
+ (def: #export <maximum>
+ <name>
+ (|> <bytes> (n.* i64.bits_per_byte) i64.mask :abstraction))
+
+ (def: #export (<constructor> value)
+ (-> Nat (Try <name>))
+ (if (n.<= (:representation <maximum>) value)
+ (#try.Success (:abstraction value))
+ (exception.throw ..value_exceeds_the_maximum [(name_of <name>) value <maximum>])))
+
+ (def: #export (<+> parameter subject)
+ (-> <name> <name> (Try <name>))
+ (<constructor>
+ (n.+ (:representation parameter)
+ (:representation subject))))
+
+ (def: #export (<-> parameter subject)
+ (-> <name> <name> (Try <name>))
+ (let [parameter' (:representation parameter)
+ subject' (:representation subject)]
+ (if (n.<= subject' parameter')
+ (#try.Success (:abstraction (n.- parameter' subject')))
+ (exception.throw ..subtraction_cannot_yield_negative_value [(name_of <name>) parameter subject]))))
+
+ (def: #export (<max> left right)
+ (-> <name> <name> <name>)
+ (:abstraction (n.max (:representation left)
+ (:representation right))))]
+
+ [1 U1 bytes/1 u1 maximum/1 +/1 -/1 max/1]
+ [2 U2 bytes/2 u2 maximum/2 +/2 -/2 max/2]
+ [4 U4 bytes/4 u4 maximum/4 +/4 -/4 max/4]
+ )
+
+ (template [<name> <from> <to>]
+ [(def: #export <name>
+ (-> <from> <to>)
+ (|>> :transmutation))]
+
+ [lift/2 U1 U2]
+ [lift/4 U2 U4]
+ )
+
+ (template [<writer_name> <type> <writer>]
+ [(def: #export <writer_name>
+ (Writer <type>)
+ (|>> :representation <writer>))]
+
+ [writer/1 U1 format.bits/8]
+ [writer/2 U2 format.bits/16]
+ [writer/4 U4 format.bits/32]
+ )
+ )
diff --git a/stdlib/source/library/lux/target/jvm/field.lux b/stdlib/source/library/lux/target/jvm/field.lux
new file mode 100644
index 000000000..aa71794a5
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/field.lux
@@ -0,0 +1,70 @@
+(.module:
+ [library
+ [lux (#- Type static)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ [format
+ [".F" binary (#+ Writer) ("#\." monoid)]]
+ [collection
+ ["." row (#+ Row)]]]]]
+ ["." // #_
+ ["." modifier (#+ Modifier modifiers:)]
+ ["#." constant (#+ UTF8)
+ ["#/." pool (#+ Pool Resource)]]
+ ["#." index (#+ Index)]
+ ["#." attribute (#+ Attribute)]
+ ["#." type (#+ Type)
+ [category (#+ Value)]
+ [descriptor (#+ Descriptor)]]])
+
+(type: #export #rec Field
+ {#modifier (Modifier Field)
+ #name (Index UTF8)
+ #descriptor (Index (Descriptor Value))
+ #attributes (Row Attribute)})
+
+(modifiers: Field
+ ["0001" public]
+ ["0002" private]
+ ["0004" protected]
+ ["0008" static]
+ ["0010" final]
+ ["0040" volatile]
+ ["0080" transient]
+ ["1000" synthetic]
+ ["4000" enum]
+ )
+
+(def: #export equivalence
+ (Equivalence Field)
+ ($_ product.equivalence
+ modifier.equivalence
+ //index.equivalence
+ //index.equivalence
+ (row.equivalence //attribute.equivalence)))
+
+(def: #export (writer field)
+ (Writer Field)
+ (`` ($_ binaryF\compose
+ (~~ (template [<writer> <slot>]
+ [(<writer> (get@ <slot> field))]
+
+ [modifier.writer #modifier]
+ [//index.writer #name]
+ [//index.writer #descriptor]
+ [(binaryF.row/16 //attribute.writer) #attributes]))
+ )))
+
+(def: #export (field modifier name type attributes)
+ (-> (Modifier Field) UTF8 (Type Value) (Row Attribute)
+ (Resource Field))
+ (do //constant/pool.monad
+ [@name (//constant/pool.utf8 name)
+ @descriptor (//constant/pool.descriptor (//type.descriptor type))]
+ (wrap {#modifier modifier
+ #name @name
+ #descriptor @descriptor
+ #attributes attributes})))
diff --git a/stdlib/source/library/lux/target/jvm/index.lux b/stdlib/source/library/lux/target/jvm/index.lux
new file mode 100644
index 000000000..851d6903f
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/index.lux
@@ -0,0 +1,38 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." equivalence (#+ Equivalence)]]
+ [data
+ [format
+ [binary (#+ Writer)]]]
+ [type
+ abstract]]]
+ ["." // #_
+ [encoding
+ ["#." unsigned (#+ U2)]]])
+
+(def: #export length
+ //unsigned.bytes/2)
+
+(abstract: #export (Index kind)
+ U2
+
+ (def: #export index
+ (All [kind] (-> U2 (Index kind)))
+ (|>> :abstraction))
+
+ (def: #export value
+ (-> (Index Any) U2)
+ (|>> :representation))
+
+ (def: #export equivalence
+ (All [kind] (Equivalence (Index kind)))
+ (\ equivalence.functor map
+ ..value
+ //unsigned.equivalence))
+
+ (def: #export writer
+ (All [kind] (Writer (Index kind)))
+ (|>> :representation //unsigned.writer/2))
+ )
diff --git a/stdlib/source/library/lux/target/jvm/loader.lux b/stdlib/source/library/lux/target/jvm/loader.lux
new file mode 100644
index 000000000..8b86321ca
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/loader.lux
@@ -0,0 +1,143 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO)]
+ [concurrency
+ ["." atom (#+ Atom)]]]
+ [data
+ ["." binary (#+ Binary)]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." array]
+ ["." dictionary (#+ Dictionary)]]]
+ ["." ffi (#+ import: object do_to)]]])
+
+(type: #export Library
+ (Atom (Dictionary Text Binary)))
+
+(exception: #export (already_stored {class Text})
+ (exception.report
+ ["Class" class]))
+
+(exception: #export (unknown {class Text} {known_classes (List Text)})
+ (exception.report
+ ["Class" class]
+ ["Known classes" (exception.enumerate (|>>) known_classes)]))
+
+(exception: #export (cannot_define {class Text} {error Text})
+ (exception.report
+ ["Class" class]
+ ["Error" error]))
+
+(import: java/lang/Object
+ ["#::."
+ (getClass [] (java/lang/Class java/lang/Object))])
+
+(import: java/lang/String)
+
+(import: java/lang/reflect/Method
+ ["#::."
+ (invoke [java/lang/Object [java/lang/Object]] #try java/lang/Object)])
+
+(import: (java/lang/Class a)
+ ["#::."
+ (getDeclaredMethod [java/lang/String [(java/lang/Class [? < java/lang/Object])]] java/lang/reflect/Method)])
+
+(import: java/lang/Integer
+ ["#::."
+ (#static TYPE (java/lang/Class java/lang/Integer))])
+
+(import: java/lang/reflect/AccessibleObject
+ ["#::."
+ (setAccessible [boolean] void)])
+
+(import: java/lang/ClassLoader
+ ["#::."
+ (loadClass [java/lang/String]
+ #io #try (java/lang/Class java/lang/Object))])
+
+(with_expansions [<elemT> (as_is (java/lang/Class java/lang/Object))]
+ (def: java/lang/ClassLoader::defineClass
+ java/lang/reflect/Method
+ (let [signature (|> (ffi.array <elemT> 4)
+ (ffi.array_write 0 (:as <elemT>
+ (ffi.class_for java/lang/String)))
+ (ffi.array_write 1 (java/lang/Object::getClass (ffi.array byte 0)))
+ (ffi.array_write 2 (:as <elemT>
+ (java/lang/Integer::TYPE)))
+ (ffi.array_write 3 (:as <elemT>
+ (java/lang/Integer::TYPE))))]
+ (do_to (java/lang/Class::getDeclaredMethod "defineClass"
+ signature
+ (ffi.class_for java/lang/ClassLoader))
+ (java/lang/reflect/AccessibleObject::setAccessible true)))))
+
+(def: #export (define class_name bytecode loader)
+ (-> Text Binary java/lang/ClassLoader (Try java/lang/Object))
+ (let [signature (array.from_list (list (:as java/lang/Object
+ class_name)
+ (:as java/lang/Object
+ bytecode)
+ (:as java/lang/Object
+ (|> 0
+ (:as (primitive "java.lang.Long"))
+ ffi.long_to_int))
+ (:as java/lang/Object
+ (|> bytecode
+ binary.size
+ (:as (primitive "java.lang.Long"))
+ ffi.long_to_int))))]
+ (java/lang/reflect/Method::invoke loader signature java/lang/ClassLoader::defineClass)))
+
+(def: #export (new_library _)
+ (-> Any Library)
+ (atom.atom (dictionary.new text.hash)))
+
+(def: #export (memory library)
+ (-> Library java/lang/ClassLoader)
+ (with_expansions [<cast> (for {@.old
+ (<|)
+
+ @.jvm
+ "jvm object cast"})]
+ (<| <cast>
+ (object [] java/lang/ClassLoader []
+ []
+ (java/lang/ClassLoader (findClass self {class_name java/lang/String})
+ (java/lang/Class [? < java/lang/Object])
+ #throws [java/lang/ClassNotFoundException]
+ (let [class_name (:as Text class_name)
+ classes (|> library atom.read io.run)]
+ (case (dictionary.get class_name classes)
+ (#.Some bytecode)
+ (case (..define class_name bytecode (<| <cast> self))
+ (#try.Success class)
+ (:assume class)
+
+ (#try.Failure error)
+ (error! (exception.construct ..cannot_define [class_name error])))
+
+ #.None
+ (error! (exception.construct ..unknown [class_name (dictionary.keys classes)])))))))))
+
+(def: #export (store name bytecode library)
+ (-> Text Binary Library (IO (Try Any)))
+ (do {! io.monad}
+ [library' (atom.read library)]
+ (if (dictionary.key? library' name)
+ (wrap (exception.throw ..already_stored name))
+ (do !
+ [_ (atom.update (dictionary.put name bytecode) library)]
+ (wrap (#try.Success []))))))
+
+(def: #export (load name loader)
+ (-> Text java/lang/ClassLoader
+ (IO (Try (java/lang/Class java/lang/Object))))
+ (java/lang/ClassLoader::loadClass name loader))
diff --git a/stdlib/source/library/lux/target/jvm/magic.lux b/stdlib/source/library/lux/target/jvm/magic.lux
new file mode 100644
index 000000000..70859362b
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/magic.lux
@@ -0,0 +1,20 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ ["." try]]
+ [math
+ [number (#+ hex)]]]]
+ ["." // #_
+ [encoding
+ ["#." unsigned (#+ U4)]]])
+
+(type: #export Magic
+ U4)
+
+(def: #export code
+ Magic
+ (|> (hex "CAFEBABE") //unsigned.u4 try.assume))
+
+(def: #export writer
+ //unsigned.writer/4)
diff --git a/stdlib/source/library/lux/target/jvm/method.lux b/stdlib/source/library/lux/target/jvm/method.lux
new file mode 100644
index 000000000..e832b1667
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/method.lux
@@ -0,0 +1,104 @@
+(.module:
+ [library
+ [lux (#- Type static)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ ["." monad (#+ do)]]
+ [control
+ ["." try]]
+ [data
+ ["." product]
+ ["." format #_
+ ["#" binary (#+ Writer) ("#\." monoid)]]
+ [collection
+ ["." row (#+ Row)]]]]]
+ ["." // #_
+ ["#." modifier (#+ Modifier modifiers:)]
+ ["#." index (#+ Index)]
+ ["#." attribute (#+ Attribute)
+ ["#/." code]]
+ ["#." constant (#+ UTF8)
+ ["#/." pool (#+ Pool Resource)]]
+ ["#." bytecode (#+ Bytecode)
+ ["#/." environment (#+ Environment)]
+ ["#/." instruction]]
+ ["#." type (#+ Type)
+ ["#/." category]
+ ["#." descriptor (#+ Descriptor)]]])
+
+(type: #export #rec Method
+ {#modifier (Modifier Method)
+ #name (Index UTF8)
+ #descriptor (Index (Descriptor //type/category.Method))
+ #attributes (Row Attribute)})
+
+(modifiers: Method
+ ["0001" public]
+ ["0002" private]
+ ["0004" protected]
+ ["0008" static]
+ ["0010" final]
+ ["0020" synchronized]
+ ["0040" bridge]
+ ["0080" var_args]
+ ["0100" native]
+ ["0400" abstract]
+ ["0800" strict]
+ ["1000" synthetic]
+ )
+
+(def: #export (method modifier name type attributes code)
+ (-> (Modifier Method) UTF8 (Type //type/category.Method) (List (Resource Attribute)) (Maybe (Bytecode Any))
+ (Resource Method))
+ (do {! //constant/pool.monad}
+ [@name (//constant/pool.utf8 name)
+ @descriptor (//constant/pool.descriptor (//type.descriptor type))
+ attributes (|> attributes
+ (monad.seq !)
+ (\ ! map row.from_list))
+ attributes (case code
+ (#.Some code)
+ (do !
+ [environment (case (if (//modifier.has? static modifier)
+ (//bytecode/environment.static type)
+ (//bytecode/environment.virtual type))
+ (#try.Success environment)
+ (wrap environment)
+
+ (#try.Failure error)
+ (function (_ _) (#try.Failure error)))
+ [environment exceptions instruction output] (//bytecode.resolve environment code)
+ #let [bytecode (|> instruction //bytecode/instruction.run format.instance)]
+ @code (//attribute.code {#//attribute/code.limit (get@ #//bytecode/environment.limit environment)
+ #//attribute/code.code bytecode
+ #//attribute/code.exception_table exceptions
+ #//attribute/code.attributes (row.row)})]
+ (wrap (row.add @code attributes)))
+
+ #.None
+ (wrap attributes))]
+ (wrap {#modifier modifier
+ #name @name
+ #descriptor @descriptor
+ #attributes attributes})))
+
+(def: #export equivalence
+ (Equivalence Method)
+ ($_ product.equivalence
+ //modifier.equivalence
+ //index.equivalence
+ //index.equivalence
+ (row.equivalence //attribute.equivalence)
+ ))
+
+(def: #export (writer field)
+ (Writer Method)
+ (`` ($_ format\compose
+ (~~ (template [<writer> <slot>]
+ [(<writer> (get@ <slot> field))]
+
+ [//modifier.writer #modifier]
+ [//index.writer #name]
+ [//index.writer #descriptor]
+ [(format.row/16 //attribute.writer) #attributes]))
+ )))
diff --git a/stdlib/source/library/lux/target/jvm/modifier.lux b/stdlib/source/library/lux/target/jvm/modifier.lux
new file mode 100644
index 000000000..109486231
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/modifier.lux
@@ -0,0 +1,88 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." equivalence (#+ Equivalence)]
+ ["." monoid (#+ Monoid)]]
+ [control
+ ["." try]
+ ["<>" parser
+ ["<c>" code]]]
+ [data
+ [format
+ [".F" binary (#+ Writer)]]]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ ["." number (#+ hex)
+ ["." i64]]]
+ [type
+ abstract]]]
+ ["." // #_
+ [encoding
+ ["#." unsigned]]])
+
+(abstract: #export (Modifier of)
+ //unsigned.U2
+
+ (def: #export code
+ (-> (Modifier Any) //unsigned.U2)
+ (|>> :representation))
+
+ (implementation: #export equivalence
+ (All [of] (Equivalence (Modifier of)))
+
+ (def: (= reference sample)
+ (\ //unsigned.equivalence =
+ (:representation reference)
+ (:representation sample))))
+
+ (template: (!wrap value)
+ (|> value
+ //unsigned.u2
+ try.assume
+ :abstraction))
+
+ (template: (!unwrap value)
+ (|> value
+ :representation
+ //unsigned.value))
+
+ (def: #export (has? sub super)
+ (All [of] (-> (Modifier of) (Modifier of) Bit))
+ (let [sub (!unwrap sub)]
+ (|> (!unwrap super)
+ (i64.and sub)
+ (\ i64.equivalence = sub))))
+
+ (implementation: #export monoid
+ (All [of] (Monoid (Modifier of)))
+
+ (def: identity
+ (!wrap (hex "0000")))
+
+ (def: (compose left right)
+ (!wrap (i64.or (!unwrap left) (!unwrap right)))))
+
+ (def: #export empty
+ Modifier
+ (\ ..monoid identity))
+
+ (def: #export writer
+ (All [of] (Writer (Modifier of)))
+ (|>> :representation //unsigned.writer/2))
+
+ (def: modifier
+ (-> Nat Modifier)
+ (|>> !wrap))
+ )
+
+(syntax: #export (modifiers: ofT {options (<>.many <c>.any)})
+ (with_gensyms [g!modifier g!code]
+ (wrap (list (` (template [(~ g!code) (~ g!modifier)]
+ [(def: (~' #export) (~ g!modifier)
+ (..Modifier (~ ofT))
+ ((~! ..modifier) ((~! number.hex) (~ g!code))))]
+
+ (~+ options)))))))
diff --git a/stdlib/source/library/lux/target/jvm/modifier/inner.lux b/stdlib/source/library/lux/target/jvm/modifier/inner.lux
new file mode 100644
index 000000000..fc9bc982c
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/modifier/inner.lux
@@ -0,0 +1,21 @@
+(.module:
+ [library
+ [lux (#- static)
+ [type
+ abstract]]]
+ [// (#+ modifiers:)])
+
+(abstract: #export Inner Any)
+
+(modifiers: Inner
+ ["0001" public]
+ ["0002" private]
+ ["0004" protected]
+ ["0008" static]
+ ["0010" final]
+ ["0200" interface]
+ ["0400" abstract]
+ ["1000" synthetic]
+ ["2000" annotation]
+ ["4000" enum]
+ )
diff --git a/stdlib/source/library/lux/target/jvm/reflection.lux b/stdlib/source/library/lux/target/jvm/reflection.lux
new file mode 100644
index 000000000..e2297f313
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/reflection.lux
@@ -0,0 +1,382 @@
+(.module:
+ [library
+ [lux (#- type)
+ ["." ffi (#+ import:)]
+ ["." type]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ [parser
+ ["<t>" text]]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." fold functor)]
+ ["." array]
+ ["." dictionary]]]
+ [math
+ [number
+ ["n" nat]]]]]
+ ["." // #_
+ [encoding
+ ["#." name (#+ External)]]
+ ["/" type
+ [category (#+ Void Value Return Method Primitive Object Class Array Parameter)]
+ ["#." lux (#+ Mapping)]
+ ["#." descriptor]
+ ["#." reflection]
+ ["#." parser]]])
+
+(import: java/lang/String)
+
+(import: java/lang/Object
+ ["#::."
+ (toString [] java/lang/String)
+ (getClass [] (java/lang/Class java/lang/Object))])
+
+(import: java/lang/reflect/Type
+ ["#::."
+ (getTypeName [] java/lang/String)])
+
+(import: java/lang/reflect/GenericArrayType
+ ["#::."
+ (getGenericComponentType [] java/lang/reflect/Type)])
+
+(import: java/lang/reflect/ParameterizedType
+ ["#::."
+ (getRawType [] java/lang/reflect/Type)
+ (getActualTypeArguments [] [java/lang/reflect/Type])])
+
+(import: (java/lang/reflect/TypeVariable d)
+ ["#::."
+ (getName [] java/lang/String)
+ (getBounds [] [java/lang/reflect/Type])])
+
+(import: (java/lang/reflect/WildcardType d)
+ ["#::."
+ (getLowerBounds [] [java/lang/reflect/Type])
+ (getUpperBounds [] [java/lang/reflect/Type])])
+
+(import: java/lang/reflect/Modifier
+ ["#::."
+ (#static isStatic [int] boolean)
+ (#static isFinal [int] boolean)
+ (#static isInterface [int] boolean)
+ (#static isAbstract [int] boolean)])
+
+(import: java/lang/annotation/Annotation)
+
+(import: java/lang/Deprecated)
+
+(import: java/lang/reflect/Field
+ ["#::."
+ (getDeclaringClass [] (java/lang/Class java/lang/Object))
+ (getModifiers [] int)
+ (getGenericType [] java/lang/reflect/Type)
+ (getDeclaredAnnotations [] [java/lang/annotation/Annotation])])
+
+(import: java/lang/reflect/Method
+ ["#::."
+ (getName [] java/lang/String)
+ (getModifiers [] int)
+ (getDeclaringClass [] (java/lang/Class java/lang/Object))
+ (getTypeParameters [] [(java/lang/reflect/TypeVariable java/lang/reflect/Method)])
+ (getGenericParameterTypes [] [java/lang/reflect/Type])
+ (getGenericReturnType [] java/lang/reflect/Type)
+ (getGenericExceptionTypes [] [java/lang/reflect/Type])])
+
+(import: (java/lang/reflect/Constructor c)
+ ["#::."
+ (getModifiers [] int)
+ (getDeclaringClass [] (java/lang/Class c))
+ (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/reflect/Constructor c))])
+ (getGenericParameterTypes [] [java/lang/reflect/Type])
+ (getGenericExceptionTypes [] [java/lang/reflect/Type])])
+
+(import: (java/lang/Class c)
+ ["#::."
+ (#static forName [java/lang/String] #try (java/lang/Class java/lang/Object))
+ (getName [] java/lang/String)
+ (getModifiers [] int)
+ (isAssignableFrom [(java/lang/Class java/lang/Object)] boolean)
+ (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/Class c))])
+ (getGenericInterfaces [] [java/lang/reflect/Type])
+ (getGenericSuperclass [] #? java/lang/reflect/Type)
+ (getDeclaredField [java/lang/String] #try java/lang/reflect/Field)
+ (getConstructors [] [(java/lang/reflect/Constructor java/lang/Object)])
+ (getDeclaredMethods [] [java/lang/reflect/Method])])
+
+(exception: #export (unknown_class {class External})
+ (exception.report
+ ["Class" (%.text class)]))
+
+(template [<name>]
+ [(exception: #export (<name> {jvm_type java/lang/reflect/Type})
+ (exception.report
+ ["Type" (java/lang/reflect/Type::getTypeName jvm_type)]
+ ["Class" (|> jvm_type java/lang/Object::getClass java/lang/Object::toString)]))]
+
+ [not_a_class]
+ [cannot_convert_to_a_lux_type]
+ )
+
+(def: #export (load name)
+ (-> External (Try (java/lang/Class java/lang/Object)))
+ (case (java/lang/Class::forName name)
+ (#try.Success class)
+ (#try.Success class)
+
+ (#try.Failure _)
+ (exception.throw ..unknown_class name)))
+
+(def: #export (sub? super sub)
+ (-> External External (Try Bit))
+ (do try.monad
+ [super (..load super)
+ sub (..load sub)]
+ (wrap (java/lang/Class::isAssignableFrom sub super))))
+
+(def: (class' parameter reflection)
+ (-> (-> java/lang/reflect/Type (Try (/.Type Parameter)))
+ java/lang/reflect/Type
+ (Try (/.Type Class)))
+ (<| (case (ffi.check java/lang/Class reflection)
+ (#.Some class)
+ (let [class_name (|> class
+ (:as (java/lang/Class java/lang/Object))
+ java/lang/Class::getName)]
+ (`` (if (or (~~ (template [<reflection>]
+ [(text\= (/reflection.reflection <reflection>)
+ class_name)]
+
+ [/reflection.boolean]
+ [/reflection.byte]
+ [/reflection.short]
+ [/reflection.int]
+ [/reflection.long]
+ [/reflection.float]
+ [/reflection.double]
+ [/reflection.char]))
+ (text.starts_with? /descriptor.array_prefix class_name))
+ (exception.throw ..not_a_class reflection)
+ (#try.Success (/.class class_name (list))))))
+ _)
+ (case (ffi.check java/lang/reflect/ParameterizedType reflection)
+ (#.Some reflection)
+ (let [raw (java/lang/reflect/ParameterizedType::getRawType reflection)]
+ (case (ffi.check java/lang/Class raw)
+ (#.Some raw)
+ (do {! try.monad}
+ [paramsT (|> reflection
+ java/lang/reflect/ParameterizedType::getActualTypeArguments
+ array.to_list
+ (monad.map ! parameter))]
+ (wrap (/.class (|> raw
+ (:as (java/lang/Class java/lang/Object))
+ java/lang/Class::getName)
+ paramsT)))
+
+ _
+ (exception.throw ..not_a_class raw)))
+ _)
+ ## else
+ (exception.throw ..cannot_convert_to_a_lux_type reflection)))
+
+(def: #export (parameter reflection)
+ (-> java/lang/reflect/Type (Try (/.Type Parameter)))
+ (<| (case (ffi.check java/lang/reflect/TypeVariable reflection)
+ (#.Some reflection)
+ (#try.Success (/.var (java/lang/reflect/TypeVariable::getName reflection)))
+ _)
+ (case (ffi.check java/lang/reflect/WildcardType reflection)
+ (#.Some reflection)
+ ## TODO: Instead of having single lower/upper bounds, should
+ ## allow for multiple ones.
+ (case [(array.read 0 (java/lang/reflect/WildcardType::getLowerBounds reflection))
+ (array.read 0 (java/lang/reflect/WildcardType::getUpperBounds reflection))]
+ (^template [<pattern> <kind>]
+ [<pattern>
+ (case (ffi.check java/lang/reflect/GenericArrayType bound)
+ (#.Some _)
+ ## TODO: Array bounds should not be "erased" as they
+ ## are right now.
+ (#try.Success /.wildcard)
+
+ _
+ (\ try.monad map <kind> (..class' parameter bound)))])
+ ([[_ (#.Some bound)] /.upper]
+ [[(#.Some bound) _] /.lower])
+
+ _
+ (#try.Success /.wildcard))
+ _)
+ (..class' parameter reflection)))
+
+(def: #export class
+ (-> java/lang/reflect/Type
+ (Try (/.Type Class)))
+ (..class' ..parameter))
+
+(def: #export (type reflection)
+ (-> java/lang/reflect/Type (Try (/.Type Value)))
+ (<| (case (ffi.check java/lang/Class reflection)
+ (#.Some reflection)
+ (let [class_name (|> reflection
+ (:as (java/lang/Class java/lang/Object))
+ java/lang/Class::getName)]
+ (`` (cond (~~ (template [<reflection> <type>]
+ [(text\= (/reflection.reflection <reflection>)
+ class_name)
+ (#try.Success <type>)]
+
+ [/reflection.boolean /.boolean]
+ [/reflection.byte /.byte]
+ [/reflection.short /.short]
+ [/reflection.int /.int]
+ [/reflection.long /.long]
+ [/reflection.float /.float]
+ [/reflection.double /.double]
+ [/reflection.char /.char]))
+ (if (text.starts_with? /descriptor.array_prefix class_name)
+ (<t>.run /parser.value (|> class_name //name.internal //name.read))
+ (#try.Success (/.class class_name (list)))))))
+ _)
+ (case (ffi.check java/lang/reflect/GenericArrayType reflection)
+ (#.Some reflection)
+ (|> reflection
+ java/lang/reflect/GenericArrayType::getGenericComponentType
+ type
+ (\ try.monad map /.array))
+ _)
+ ## else
+ (..parameter reflection)))
+
+(def: #export (return reflection)
+ (-> java/lang/reflect/Type (Try (/.Type Return)))
+ (with_expansions [<else> (as_is (..type reflection))]
+ (case (ffi.check java/lang/Class reflection)
+ (#.Some class)
+ (let [class_name (|> reflection
+ (:as (java/lang/Class java/lang/Object))
+ java/lang/Class::getName)]
+ (if (text\= (/reflection.reflection /reflection.void)
+ class_name)
+ (#try.Success /.void)
+ <else>))
+
+ #.None
+ <else>)))
+
+(exception: #export (cannot_correspond {class (java/lang/Class java/lang/Object)}
+ {type Type})
+ (exception.report
+ ["Class" (java/lang/Object::toString class)]
+ ["Type" (%.type type)]))
+
+(exception: #export (type_parameter_mismatch {expected Nat}
+ {actual Nat}
+ {class (java/lang/Class java/lang/Object)}
+ {type Type})
+ (exception.report
+ ["Expected" (%.nat expected)]
+ ["Actual" (%.nat actual)]
+ ["Class" (java/lang/Object::toString class)]
+ ["Type" (%.type type)]))
+
+(exception: #export (non_jvm_type {type Type})
+ (exception.report
+ ["Type" (%.type type)]))
+
+(def: #export (correspond class type)
+ (-> (java/lang/Class java/lang/Object) Type (Try Mapping))
+ (case type
+ (#.Primitive name params)
+ (let [class_name (java/lang/Class::getName class)
+ class_params (array.to_list (java/lang/Class::getTypeParameters class))
+ num_class_params (list.size class_params)
+ num_type_params (list.size params)]
+ (if (text\= class_name name)
+ (if (n.= num_class_params num_type_params)
+ (|> params
+ (list.zip/2 (list\map (|>> java/lang/reflect/TypeVariable::getName)
+ class_params))
+ (list\fold (function (_ [name paramT] mapping)
+ (dictionary.put name paramT mapping))
+ /lux.fresh)
+ #try.Success)
+ (exception.throw ..type_parameter_mismatch [num_class_params num_type_params class type]))
+ (exception.throw ..cannot_correspond [class type])))
+
+ (#.Named name anonymousT)
+ (correspond class anonymousT)
+
+ (#.Apply inputT abstractionT)
+ (case (type.apply (list inputT) abstractionT)
+ (#.Some outputT)
+ (correspond class outputT)
+
+ #.None
+ (exception.throw ..non_jvm_type [type]))
+
+ _
+ (exception.throw ..non_jvm_type [type])))
+
+(exception: #export (mistaken_field_owner {field java/lang/reflect/Field}
+ {owner (java/lang/Class java/lang/Object)}
+ {target (java/lang/Class java/lang/Object)})
+ (exception.report
+ ["Field" (java/lang/Object::toString field)]
+ ["Owner" (java/lang/Object::toString owner)]
+ ["Target" (java/lang/Object::toString target)]))
+
+(template [<name>]
+ [(exception: #export (<name> {field Text}
+ {class (java/lang/Class java/lang/Object)})
+ (exception.report
+ ["Field" (%.text field)]
+ ["Class" (java/lang/Object::toString class)]))]
+
+ [unknown_field]
+ [not_a_static_field]
+ [not_a_virtual_field]
+ )
+
+(def: #export (field field target)
+ (-> Text (java/lang/Class java/lang/Object) (Try java/lang/reflect/Field))
+ (case (java/lang/Class::getDeclaredField field target)
+ (#try.Success field)
+ (let [owner (java/lang/reflect/Field::getDeclaringClass field)]
+ (if (is? owner target)
+ (#try.Success field)
+ (exception.throw ..mistaken_field_owner [field owner target])))
+
+ (#try.Failure _)
+ (exception.throw ..unknown_field [field target])))
+
+(def: #export deprecated?
+ (-> (array.Array java/lang/annotation/Annotation) Bit)
+ (|>> array.to_list
+ (list.all (|>> (ffi.check java/lang/Deprecated)))
+ list.empty?
+ not))
+
+(template [<name> <exception> <then?> <else?>]
+ [(def: #export (<name> field class)
+ (-> Text (java/lang/Class java/lang/Object) (Try [Bit Bit (/.Type Value)]))
+ (do {! try.monad}
+ [fieldJ (..field field class)
+ #let [modifiers (java/lang/reflect/Field::getModifiers fieldJ)]]
+ (case (java/lang/reflect/Modifier::isStatic modifiers)
+ <then?> (|> fieldJ
+ java/lang/reflect/Field::getGenericType
+ ..type
+ (\ ! map (|>> [(java/lang/reflect/Modifier::isFinal modifiers)
+ (..deprecated? (java/lang/reflect/Field::getDeclaredAnnotations fieldJ))])))
+ <else?> (exception.throw <exception> [field class]))))]
+
+ [static_field ..not_a_static_field #1 #0]
+ [virtual_field ..not_a_virtual_field #0 #1]
+ )
diff --git a/stdlib/source/library/lux/target/jvm/type.lux b/stdlib/source/library/lux/target/jvm/type.lux
new file mode 100644
index 000000000..e11ef5c99
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/type.lux
@@ -0,0 +1,205 @@
+(.module:
+ [library
+ [lux (#- Type int char)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]]
+ [data
+ ["." maybe]
+ ["." text
+ ["%" format (#+ Format)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [type
+ abstract]]]
+ ["." // #_
+ [encoding
+ ["#." name (#+ External)]]]
+ ["." / #_
+ [category (#+ Void Value' Value Return' Return Method Primitive Object Class Array Var Parameter Declaration)]
+ ["#." signature (#+ Signature)]
+ ["#." descriptor (#+ Descriptor)]
+ ["#." reflection (#+ Reflection)]])
+
+(abstract: #export (Type category)
+ [(Signature category) (Descriptor category) (Reflection category)]
+
+ (type: #export Argument
+ [Text (Type Value)])
+
+ (type: #export (Typed a)
+ [(Type Value) a])
+
+ (type: #export Constraint
+ {#name Text
+ #super_class (Type Class)
+ #super_interfaces (List (Type Class))})
+
+ (template [<name> <style>]
+ [(def: #export (<name> type)
+ (All [category] (-> (Type category) (<style> category)))
+ (let [[signature descriptor reflection] (:representation type)]
+ <name>))]
+
+ [signature Signature]
+ [descriptor Descriptor]
+ )
+
+ (def: #export (reflection type)
+ (All [category]
+ (-> (Type (<| Return' Value' category))
+ (Reflection (<| Return' Value' category))))
+ (let [[signature descriptor reflection] (:representation type)]
+ reflection))
+
+ (template [<category> <name> <signature> <descriptor> <reflection>]
+ [(def: #export <name>
+ (Type <category>)
+ (:abstraction [<signature> <descriptor> <reflection>]))]
+
+ [Void void /signature.void /descriptor.void /reflection.void]
+ [Primitive boolean /signature.boolean /descriptor.boolean /reflection.boolean]
+ [Primitive byte /signature.byte /descriptor.byte /reflection.byte]
+ [Primitive short /signature.short /descriptor.short /reflection.short]
+ [Primitive int /signature.int /descriptor.int /reflection.int]
+ [Primitive long /signature.long /descriptor.long /reflection.long]
+ [Primitive float /signature.float /descriptor.float /reflection.float]
+ [Primitive double /signature.double /descriptor.double /reflection.double]
+ [Primitive char /signature.char /descriptor.char /reflection.char]
+ )
+
+ (def: #export (array type)
+ (-> (Type Value) (Type Array))
+ (:abstraction
+ [(/signature.array (..signature type))
+ (/descriptor.array (..descriptor type))
+ (/reflection.array (..reflection type))]))
+
+ (def: #export (class name parameters)
+ (-> External (List (Type Parameter)) (Type Class))
+ (:abstraction
+ [(/signature.class name (list\map ..signature parameters))
+ (/descriptor.class name)
+ (/reflection.class name)]))
+
+ (def: #export (declaration name variables)
+ (-> External (List (Type Var)) (Type Declaration))
+ (:abstraction
+ [(/signature.declaration name (list\map ..signature variables))
+ (/descriptor.declaration name)
+ (/reflection.declaration name)]))
+
+ (def: #export (as_class type)
+ (-> (Type Declaration) (Type Class))
+ (:abstraction
+ (let [[signature descriptor reflection] (:representation type)]
+ [(/signature.as_class signature)
+ (/descriptor.as_class descriptor)
+ (/reflection.as_class reflection)])))
+
+ (def: #export wildcard
+ (Type Parameter)
+ (:abstraction
+ [/signature.wildcard
+ /descriptor.wildcard
+ /reflection.wildcard]))
+
+ (def: #export (var name)
+ (-> Text (Type Var))
+ (:abstraction
+ [(/signature.var name)
+ /descriptor.var
+ /reflection.var]))
+
+ (def: #export (lower bound)
+ (-> (Type Class) (Type Parameter))
+ (:abstraction
+ (let [[signature descriptor reflection] (:representation bound)]
+ [(/signature.lower signature)
+ (/descriptor.lower descriptor)
+ (/reflection.lower reflection)])))
+
+ (def: #export (upper bound)
+ (-> (Type Class) (Type Parameter))
+ (:abstraction
+ (let [[signature descriptor reflection] (:representation bound)]
+ [(/signature.upper signature)
+ (/descriptor.upper descriptor)
+ (/reflection.upper reflection)])))
+
+ (def: #export (method [inputs output exceptions])
+ (-> [(List (Type Value))
+ (Type Return)
+ (List (Type Class))]
+ (Type Method))
+ (:abstraction
+ [(/signature.method [(list\map ..signature inputs)
+ (..signature output)
+ (list\map ..signature exceptions)])
+ (/descriptor.method [(list\map ..descriptor inputs)
+ (..descriptor output)])
+ (:assume ..void)]))
+
+ (implementation: #export equivalence
+ (All [category] (Equivalence (Type category)))
+
+ (def: (= parameter subject)
+ (\ /signature.equivalence =
+ (..signature parameter)
+ (..signature subject))))
+
+ (implementation: #export hash
+ (All [category] (Hash (Type category)))
+
+ (def: &equivalence ..equivalence)
+ (def: hash (|>> ..signature (\ /signature.hash hash))))
+
+ (def: #export (primitive? type)
+ (-> (Type Value) (Either (Type Object)
+ (Type Primitive)))
+ (if (`` (or (~~ (template [<type>]
+ [(\ ..equivalence = (: (Type Value) <type>) type)]
+
+ [..boolean]
+ [..byte]
+ [..short]
+ [..int]
+ [..long]
+ [..float]
+ [..double]
+ [..char]))))
+ (|> type (:as (Type Primitive)) #.Right)
+ (|> type (:as (Type Object)) #.Left)))
+
+ (def: #export (void? type)
+ (-> (Type Return) (Either (Type Value)
+ (Type Void)))
+ (if (`` (or (~~ (template [<type>]
+ [(\ ..equivalence = (: (Type Return) <type>) type)]
+
+ [..void]))))
+ (|> type (:as (Type Void)) #.Right)
+ (|> type (:as (Type Value)) #.Left)))
+ )
+
+(def: #export (class? type)
+ (-> (Type Value) (Maybe External))
+ (let [repr (|> type ..descriptor /descriptor.descriptor)]
+ (if (and (text.starts_with? /descriptor.class_prefix repr)
+ (text.ends_with? /descriptor.class_suffix repr))
+ (let [prefix_size (text.size /descriptor.class_prefix)
+ suffix_size (text.size /descriptor.class_suffix)
+ name_size (|> (text.size repr)
+ (n.- prefix_size)
+ (n.- suffix_size))]
+ (|> repr
+ (text.clip prefix_size name_size)
+ (\ maybe.monad map (|>> //name.internal //name.external))))
+ #.None)))
+
+(def: #export format
+ (All [a] (Format (Type a)))
+ (|>> ..signature /signature.signature))
diff --git a/stdlib/source/library/lux/target/jvm/type/alias.lux b/stdlib/source/library/lux/target/jvm/type/alias.lux
new file mode 100644
index 000000000..56ffbe127
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/type/alias.lux
@@ -0,0 +1,116 @@
+(.module:
+ [library
+ [lux (#- Type int char type primitive)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<t>" text (#+ Parser)]]]
+ [data
+ ["." maybe]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary (#+ Dictionary)]]]]]
+ ["." // (#+ Type)
+ [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
+ ["#." descriptor]
+ ["#." signature (#+ Signature)]
+ ["#." reflection]
+ ["#." parser]
+ ["/#" // #_
+ [encoding
+ ["#." name]]]])
+
+(type: #export Aliasing
+ (Dictionary Text Text))
+
+(def: #export fresh
+ Aliasing
+ (dictionary.new text.hash))
+
+(def: (var aliasing)
+ (-> Aliasing (Parser (Type Var)))
+ (do <>.monad
+ [var //parser.var']
+ (wrap (|> aliasing
+ (dictionary.get var)
+ (maybe.default var)
+ //.var))))
+
+(def: (class parameter)
+ (-> (Parser (Type Parameter)) (Parser (Type Class)))
+ (|> (do <>.monad
+ [name //parser.class_name
+ parameters (|> (<>.some parameter)
+ (<>.after (<t>.this //signature.parameters_start))
+ (<>.before (<t>.this //signature.parameters_end))
+ (<>.default (list)))]
+ (wrap (//.class name parameters)))
+ (<>.after (<t>.this //descriptor.class_prefix))
+ (<>.before (<t>.this //descriptor.class_suffix))))
+
+(template [<name> <prefix> <bound> <constructor>]
+ [(def: <name>
+ (-> (Parser (Type Class)) (Parser (Type Parameter)))
+ (|>> (<>.after (<t>.this <prefix>))
+ (\ <>.monad map <bound>)))]
+
+ [lower //signature.lower_prefix //.lower ..Lower]
+ [upper //signature.upper_prefix //.upper ..Upper]
+ )
+
+(def: (parameter aliasing)
+ (-> Aliasing (Parser (Type Parameter)))
+ (<>.rec
+ (function (_ parameter)
+ (let [class (..class parameter)]
+ ($_ <>.either
+ (..var aliasing)
+ //parser.wildcard
+ (..lower class)
+ (..upper class)
+ class
+ )))))
+
+(def: (value aliasing)
+ (-> Aliasing (Parser (Type Value)))
+ (<>.rec
+ (function (_ value)
+ ($_ <>.either
+ //parser.primitive
+ (parameter aliasing)
+ (//parser.array' value)
+ ))))
+
+(def: (inputs aliasing)
+ (-> Aliasing (Parser (List (Type Value))))
+ (|> (<>.some (..value aliasing))
+ (<>.after (<t>.this //signature.arguments_start))
+ (<>.before (<t>.this //signature.arguments_end))))
+
+(def: (return aliasing)
+ (-> Aliasing (Parser (Type Return)))
+ ($_ <>.either
+ //parser.void
+ (..value aliasing)
+ ))
+
+(def: (exception aliasing)
+ (-> Aliasing (Parser (Type Class)))
+ (|> (..class (..parameter aliasing))
+ (<>.after (<t>.this //signature.exception_prefix))))
+
+(def: #export (method aliasing type)
+ (-> Aliasing (Type Method) (Type Method))
+ (|> type
+ //.signature
+ //signature.signature
+ (<t>.run (do <>.monad
+ [inputs (..inputs aliasing)
+ return (..return aliasing)
+ exceptions (<>.some (..exception aliasing))]
+ (wrap (//.method [inputs return exceptions]))))
+ try.assume))
diff --git a/stdlib/source/library/lux/target/jvm/type/box.lux b/stdlib/source/library/lux/target/jvm/type/box.lux
new file mode 100644
index 000000000..9479ef218
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/type/box.lux
@@ -0,0 +1,19 @@
+(.module:
+ [library
+ [lux (#- int char)]]
+ [///
+ [encoding
+ [name (#+ External)]]])
+
+(template [<name> <box>]
+ [(def: #export <name> External <box>)]
+
+ [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"]
+ )
diff --git a/stdlib/source/library/lux/target/jvm/type/category.lux b/stdlib/source/library/lux/target/jvm/type/category.lux
new file mode 100644
index 000000000..f6c17a280
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/type/category.lux
@@ -0,0 +1,36 @@
+(.module:
+ [library
+ [lux #*
+ [macro
+ ["." template]]
+ [type
+ abstract]]])
+
+(abstract: #export Void' Any)
+(abstract: #export (Value' kind) Any)
+(abstract: #export (Return' kind) Any)
+(abstract: #export Method Any)
+
+(type: #export Return (<| Return' Any))
+(type: #export Value (<| Return' Value' Any))
+(type: #export Void (<| Return' Void'))
+
+(abstract: #export (Object' brand) Any)
+(type: #export Object (<| Return' Value' Object' Any))
+
+(abstract: #export (Parameter' brand) Any)
+(type: #export Parameter (<| Return' Value' Object' Parameter' Any))
+
+(template [<parents> <child>]
+ [(with_expansions [<raw> (template.identifier [<child> "'"])]
+ (abstract: #export <raw> Any)
+ (type: #export <child>
+ (`` (<| Return' Value' (~~ (template.splice <parents>)) <raw>))))]
+
+ [[] Primitive]
+ [[Object' Parameter'] Var]
+ [[Object' Parameter'] Class]
+ [[Object'] Array]
+ )
+
+(abstract: #export Declaration Any)
diff --git a/stdlib/source/library/lux/target/jvm/type/descriptor.lux b/stdlib/source/library/lux/target/jvm/type/descriptor.lux
new file mode 100644
index 000000000..2cdbeb6ee
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/type/descriptor.lux
@@ -0,0 +1,123 @@
+(.module:
+ [library
+ [lux (#- int char)
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." maybe]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [type
+ abstract]]]
+ ["." // #_
+ [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)]
+ ["/#" // #_
+ [encoding
+ ["#." name (#+ Internal External)]]]])
+
+(abstract: #export (Descriptor category)
+ Text
+
+ (def: #export descriptor
+ (-> (Descriptor Any) Text)
+ (|>> :representation))
+
+ (template [<sigil> <category> <name>]
+ [(def: #export <name>
+ (Descriptor <category>)
+ (:abstraction <sigil>))]
+
+ ["V" Void void]
+ ["Z" Primitive boolean]
+ ["B" Primitive byte]
+ ["S" Primitive short]
+ ["I" Primitive int]
+ ["J" Primitive long]
+ ["F" Primitive float]
+ ["D" Primitive double]
+ ["C" Primitive char]
+ )
+
+ (def: #export class_prefix "L")
+ (def: #export class_suffix ";")
+
+ (def: #export class
+ (-> External (Descriptor Class))
+ (|>> ///name.internal
+ ///name.read
+ (text.enclose [..class_prefix ..class_suffix])
+ :abstraction))
+
+ (def: #export (declaration name)
+ (-> External (Descriptor Declaration))
+ (:transmutation (..class name)))
+
+ (def: #export as_class
+ (-> (Descriptor Declaration) (Descriptor Class))
+ (|>> :transmutation))
+
+ (template [<name> <category>]
+ [(def: #export <name>
+ (Descriptor <category>)
+ (:transmutation
+ (..class "java.lang.Object")))]
+
+ [var Var]
+ [wildcard Parameter]
+ )
+
+ (def: #export (lower descriptor)
+ (-> (Descriptor Class) (Descriptor Parameter))
+ ..wildcard)
+
+ (def: #export upper
+ (-> (Descriptor Class) (Descriptor Parameter))
+ (|>> :transmutation))
+
+ (def: #export array_prefix "[")
+
+ (def: #export array
+ (-> (Descriptor Value)
+ (Descriptor Array))
+ (|>> :representation
+ (format ..array_prefix)
+ :abstraction))
+
+ (def: #export (method [inputs output])
+ (-> [(List (Descriptor Value))
+ (Descriptor Return)]
+ (Descriptor Method))
+ (:abstraction
+ (format (|> inputs
+ (list\map ..descriptor)
+ (text.join_with "")
+ (text.enclose ["(" ")"]))
+ (:representation output))))
+
+ (implementation: #export equivalence
+ (All [category] (Equivalence (Descriptor category)))
+
+ (def: (= parameter subject)
+ (text\= (:representation parameter) (:representation subject))))
+
+ (def: #export class_name
+ (-> (Descriptor Object) Internal)
+ (let [prefix_size (text.size ..class_prefix)
+ suffix_size (text.size ..class_suffix)]
+ (function (_ descriptor)
+ (let [repr (:representation descriptor)]
+ (if (text.starts_with? ..array_prefix repr)
+ (///name.internal repr)
+ (|> repr
+ (text.clip prefix_size
+ (|> (text.size repr)
+ (n.- prefix_size)
+ (n.- suffix_size)))
+ (\ maybe.monad map ///name.internal)
+ maybe.assume))))))
+ )
diff --git a/stdlib/source/library/lux/target/jvm/type/lux.lux b/stdlib/source/library/lux/target/jvm/type/lux.lux
new file mode 100644
index 000000000..45fd34c8d
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/type/lux.lux
@@ -0,0 +1,189 @@
+(.module:
+ [library
+ [lux (#- int char type primitive)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception (#+ exception:)]
+ ["<>" parser ("#\." monad)
+ ["<t>" text (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." array]
+ ["." dictionary (#+ Dictionary)]]]
+ [type
+ abstract
+ ["." check (#+ Check) ("#\." monad)]]]]
+ ["." //
+ [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
+ ["#." descriptor]
+ ["#." signature]
+ ["#." reflection]
+ ["#." parser]
+ ["/#" // #_
+ [encoding
+ ["#." name]]]])
+
+(template [<name>]
+ [(abstract: #export (<name> class) Any)]
+
+ [Lower] [Upper]
+ )
+
+(type: #export Mapping
+ (Dictionary Text Type))
+
+(def: #export fresh
+ Mapping
+ (dictionary.new text.hash))
+
+(exception: #export (unknown_var {var Text})
+ (exception.report
+ ["Var" (%.text var)]))
+
+(def: void
+ (Parser (Check Type))
+ (<>.after //parser.void
+ (<>\wrap (check\wrap .Any))))
+
+(template [<name> <parser> <reflection>]
+ [(def: <name>
+ (Parser (Check Type))
+ (<>.after <parser>
+ (<>\wrap (check\wrap (#.Primitive (//reflection.reflection <reflection>) #.Nil)))))]
+
+ [boolean //parser.boolean //reflection.boolean]
+ [byte //parser.byte //reflection.byte]
+ [short //parser.short //reflection.short]
+ [int //parser.int //reflection.int]
+ [long //parser.long //reflection.long]
+ [float //parser.float //reflection.float]
+ [double //parser.double //reflection.double]
+ [char //parser.char //reflection.char]
+ )
+
+(def: primitive
+ (Parser (Check Type))
+ ($_ <>.either
+ ..boolean
+ ..byte
+ ..short
+ ..int
+ ..long
+ ..float
+ ..double
+ ..char
+ ))
+
+(def: wildcard
+ (Parser (Check Type))
+ (<>.after //parser.wildcard
+ (<>\wrap (check\map product.right
+ check.existential))))
+
+(def: (var mapping)
+ (-> Mapping (Parser (Check Type)))
+ (do <>.monad
+ [var //parser.var']
+ (wrap (case (dictionary.get var mapping)
+ #.None
+ (check.throw ..unknown_var [var])
+
+ (#.Some type)
+ (check\wrap type)))))
+
+(def: (class' parameter)
+ (-> (Parser (Check Type)) (Parser (Check Type)))
+ (|> (do <>.monad
+ [name //parser.class_name
+ parameters (|> (<>.some parameter)
+ (<>.after (<t>.this //signature.parameters_start))
+ (<>.before (<t>.this //signature.parameters_end))
+ (<>.default (list)))]
+ (wrap (do {! check.monad}
+ [parameters (monad.seq ! parameters)]
+ (wrap (#.Primitive name parameters)))))
+ (<>.after (<t>.this //descriptor.class_prefix))
+ (<>.before (<t>.this //descriptor.class_suffix))))
+
+(template [<name> <prefix> <constructor>]
+ [(def: <name>
+ (-> (Parser (Check Type)) (Parser (Check Type)))
+ (|> (<>.after (<t>.this <prefix>))
+ ## TODO: Re-enable Lower and Upper, instead of using the simplified limit.
+ ## (<>\map (check\map (|>> <ctor> .type)))
+ ))]
+
+ [lower //signature.lower_prefix ..Lower]
+ [upper //signature.upper_prefix ..Upper]
+ )
+
+(def: (parameter mapping)
+ (-> Mapping (Parser (Check Type)))
+ (<>.rec
+ (function (_ parameter)
+ (let [class (..class' parameter)]
+ ($_ <>.either
+ (..var mapping)
+ ..wildcard
+ (..lower class)
+ (..upper class)
+ class
+ )))))
+
+(def: #export class
+ (-> Mapping (Parser (Check Type)))
+ (|>> ..parameter ..class'))
+
+(def: array
+ (-> (Parser (Check Type)) (Parser (Check Type)))
+ (|>> (<>\map (check\map (function (_ elementT)
+ (case elementT
+ (#.Primitive name #.Nil)
+ (if (`` (or (~~ (template [<reflection>]
+ [(text\= (//reflection.reflection <reflection>) name)]
+
+ [//reflection.boolean]
+ [//reflection.byte]
+ [//reflection.short]
+ [//reflection.int]
+ [//reflection.long]
+ [//reflection.float]
+ [//reflection.double]
+ [//reflection.char]))))
+ (#.Primitive (|> name //reflection.class //reflection.array //reflection.reflection) #.Nil)
+ (|> elementT array.Array .type))
+
+ _
+ (|> elementT array.Array .type)))))
+ (<>.after (<t>.this //descriptor.array_prefix))))
+
+(def: #export (type mapping)
+ (-> Mapping (Parser (Check Type)))
+ (<>.rec
+ (function (_ type)
+ ($_ <>.either
+ ..primitive
+ (parameter mapping)
+ (..array type)
+ ))))
+
+(def: #export (return mapping)
+ (-> Mapping (Parser (Check Type)))
+ ($_ <>.either
+ ..void
+ (..type mapping)
+ ))
+
+(def: #export (check operation input)
+ (All [a] (-> (Parser (Check a)) Text (Check a)))
+ (case (<t>.run operation input)
+ (#try.Success check)
+ check
+
+ (#try.Failure error)
+ (check.fail error)))
diff --git a/stdlib/source/library/lux/target/jvm/type/parser.lux b/stdlib/source/library/lux/target/jvm/type/parser.lux
new file mode 100644
index 000000000..5b9a3e1af
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/type/parser.lux
@@ -0,0 +1,253 @@
+(.module:
+ [library
+ [lux (#- Type int char primitive)
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["." function]
+ ["<>" parser ("#\." monad)
+ ["<t>" text (#+ Parser)]]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list]]]]]
+ ["." // (#+ Type)
+ [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)]
+ ["#." signature]
+ ["#." descriptor]
+ ["." // #_
+ [encoding
+ ["#." name (#+ External)]]]])
+
+(template [<category> <name> <signature> <type>]
+ [(def: #export <name>
+ (Parser (Type <category>))
+ (<>.after (<t>.this (//signature.signature <signature>))
+ (<>\wrap <type>)))]
+
+ [Void void //signature.void //.void]
+ [Primitive boolean //signature.boolean //.boolean]
+ [Primitive byte //signature.byte //.byte]
+ [Primitive short //signature.short //.short]
+ [Primitive int //signature.int //.int]
+ [Primitive long //signature.long //.long]
+ [Primitive float //signature.float //.float]
+ [Primitive double //signature.double //.double]
+ [Primitive char //signature.char //.char]
+ [Parameter wildcard //signature.wildcard //.wildcard]
+ )
+
+(def: #export primitive
+ (Parser (Type Primitive))
+ ($_ <>.either
+ ..boolean
+ ..byte
+ ..short
+ ..int
+ ..long
+ ..float
+ ..double
+ ..char
+ ))
+
+(def: var/head
+ (format "abcdefghijklmnopqrstuvwxyz"
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ "_"))
+
+(def: var/tail
+ (format var/head
+ "0123456789$"))
+
+(def: class/set
+ (format var/tail //name.internal_separator))
+
+(template [<type> <name> <head> <tail> <adapter>]
+ [(def: #export <name>
+ (Parser <type>)
+ (\ <>.functor map <adapter>
+ (<t>.slice (<t>.and! (<t>.one_of! <head>)
+ (<t>.some! (<t>.one_of! <tail>))))))]
+
+ [External class_name class/set class/set (|>> //name.internal //name.external)]
+ [Text var_name var/head var/tail function.identity]
+ )
+
+(def: #export var'
+ (Parser Text)
+ (|> ..var_name
+ (<>.after (<t>.this //signature.var_prefix))
+ (<>.before (<t>.this //descriptor.class_suffix))))
+
+(def: #export var
+ (Parser (Type Var))
+ (<>\map //.var ..var'))
+
+(def: #export var?
+ (-> (Type Value) (Maybe Text))
+ (|>> //.signature
+ //signature.signature
+ (<t>.run ..var')
+ try.to_maybe))
+
+(def: #export name
+ (-> (Type Var) Text)
+ (|>> //.signature
+ //signature.signature
+ (<t>.run ..var')
+ try.assume))
+
+(template [<name> <prefix> <constructor>]
+ [(def: <name>
+ (-> (Parser (Type Class)) (Parser (Type Parameter)))
+ (|>> (<>.after (<t>.this <prefix>))
+ (<>\map <constructor>)))]
+
+ [lower //signature.lower_prefix //.lower]
+ [upper //signature.upper_prefix //.upper]
+ )
+
+(def: (class'' parameter)
+ (-> (Parser (Type Parameter)) (Parser [External (List (Type Parameter))]))
+ (|> (do <>.monad
+ [name ..class_name
+ parameters (|> (<>.some parameter)
+ (<>.after (<t>.this //signature.parameters_start))
+ (<>.before (<t>.this //signature.parameters_end))
+ (<>.default (list)))]
+ (wrap [name parameters]))
+ (<>.after (<t>.this //descriptor.class_prefix))
+ (<>.before (<t>.this //descriptor.class_suffix))))
+
+(def: class'
+ (-> (Parser (Type Parameter)) (Parser (Type Class)))
+ (|>> ..class''
+ (\ <>.monad map (product.uncurry //.class))))
+
+(def: #export parameter
+ (Parser (Type Parameter))
+ (<>.rec
+ (function (_ parameter)
+ (let [class (..class' parameter)]
+ ($_ <>.either
+ ..var
+ ..wildcard
+ (..lower class)
+ (..upper class)
+ class
+ )))))
+
+(def: #export array'
+ (-> (Parser (Type Value)) (Parser (Type Array)))
+ (|>> (<>.after (<t>.this //descriptor.array_prefix))
+ (<>\map //.array)))
+
+(def: #export class
+ (Parser (Type Class))
+ (..class' ..parameter))
+
+(template [<name> <prefix> <constructor>]
+ [(def: #export <name>
+ (-> (Type Value) (Maybe (Type Class)))
+ (|>> //.signature
+ //signature.signature
+ (<t>.run (<>.after (<t>.this <prefix>) ..class))
+ try.to_maybe))]
+
+ [lower? //signature.lower_prefix //.lower]
+ [upper? //signature.upper_prefix //.upper]
+ )
+
+(def: #export read_class
+ (-> (Type Class) [External (List (Type Parameter))])
+ (|>> //.signature
+ //signature.signature
+ (<t>.run (..class'' ..parameter))
+ try.assume))
+
+(def: #export value
+ (Parser (Type Value))
+ (<>.rec
+ (function (_ value)
+ ($_ <>.either
+ ..primitive
+ ..parameter
+ (..array' value)
+ ))))
+
+(def: #export array
+ (Parser (Type Array))
+ (..array' ..value))
+
+(def: #export object
+ (Parser (Type Object))
+ ($_ <>.either
+ ..class
+ ..array))
+
+(def: inputs
+ (|> (<>.some ..value)
+ (<>.after (<t>.this //signature.arguments_start))
+ (<>.before (<t>.this //signature.arguments_end))))
+
+(def: #export return
+ (Parser (Type Return))
+ (<>.either ..void
+ ..value))
+
+(def: exception
+ (Parser (Type Class))
+ (|> (..class' ..parameter)
+ (<>.after (<t>.this //signature.exception_prefix))))
+
+(def: #export method
+ (-> (Type Method)
+ [(List (Type Value)) (Type Return) (List (Type Class))])
+ (let [parser (do <>.monad
+ [inputs ..inputs
+ return ..return
+ exceptions (<>.some ..exception)]
+ (wrap [inputs return exceptions]))]
+ (|>> //.signature
+ //signature.signature
+ (<t>.run parser)
+ try.assume)))
+
+(template [<name> <category> <parser>]
+ [(def: #export <name>
+ (-> (Type Value) (Maybe <category>))
+ (|>> //.signature
+ //signature.signature
+ (<t>.run <parser>)
+ try.to_maybe))]
+
+ [array? (Type Value)
+ (do <>.monad
+ [_ (<t>.this //descriptor.array_prefix)]
+ ..value)]
+ [class? [External (List (Type Parameter))]
+ (..class'' ..parameter)]
+
+ [primitive? (Type Primitive) ..primitive]
+ [wildcard? (Type Parameter) ..wildcard]
+ [parameter? (Type Parameter) ..parameter]
+ [object? (Type Object) ..object]
+ )
+
+(def: #export declaration
+ (-> (Type Declaration) [External (List (Type Var))])
+ (let [declaration' (: (Parser [External (List (Type Var))])
+ (|> (<>.and ..class_name
+ (|> (<>.some ..var)
+ (<>.after (<t>.this //signature.parameters_start))
+ (<>.before (<t>.this //signature.parameters_end))
+ (<>.default (list))))
+ (<>.after (<t>.this //descriptor.class_prefix))
+ (<>.before (<t>.this //descriptor.class_suffix))))]
+ (|>> //.signature
+ //signature.signature
+ (<t>.run declaration')
+ try.assume)))
diff --git a/stdlib/source/library/lux/target/jvm/type/reflection.lux b/stdlib/source/library/lux/target/jvm/type/reflection.lux
new file mode 100644
index 000000000..78ef5a45c
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/type/reflection.lux
@@ -0,0 +1,104 @@
+(.module:
+ [library
+ [lux (#- int char)
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]
+ [type
+ abstract]]]
+ ["." // #_
+ [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)]
+ ["#." descriptor]
+ [//
+ [encoding
+ ["#." name (#+ External)]]]])
+
+(abstract: #export (Reflection category)
+ Text
+
+ (def: #export reflection
+ (-> (Reflection Any) Text)
+ (|>> :representation))
+
+ (implementation: #export equivalence
+ (All [category] (Equivalence (Reflection category)))
+
+ (def: (= parameter subject)
+ (text\= (:representation parameter) (:representation subject))))
+
+ (template [<category> <name> <reflection>]
+ [(def: #export <name>
+ (Reflection <category>)
+ (:abstraction <reflection>))]
+
+ [Void void "void"]
+ [Primitive boolean "boolean"]
+ [Primitive byte "byte"]
+ [Primitive short "short"]
+ [Primitive int "int"]
+ [Primitive long "long"]
+ [Primitive float "float"]
+ [Primitive double "double"]
+ [Primitive char "char"]
+ )
+
+ (def: #export class
+ (-> External (Reflection Class))
+ (|>> :abstraction))
+
+ (def: #export (declaration name)
+ (-> External (Reflection Declaration))
+ (:transmutation (..class name)))
+
+ (def: #export as_class
+ (-> (Reflection Declaration) (Reflection Class))
+ (|>> :transmutation))
+
+ (def: #export (array element)
+ (-> (Reflection Value) (Reflection Array))
+ (let [element' (:representation element)
+ elementR (`` (cond (text.starts_with? //descriptor.array_prefix element')
+ element'
+
+ (~~ (template [<primitive> <descriptor>]
+ [(\ ..equivalence = <primitive> element)
+ (//descriptor.descriptor <descriptor>)]
+
+ [..boolean //descriptor.boolean]
+ [..byte //descriptor.byte]
+ [..short //descriptor.short]
+ [..int //descriptor.int]
+ [..long //descriptor.long]
+ [..float //descriptor.float]
+ [..double //descriptor.double]
+ [..char //descriptor.char]))
+
+ (|> element'
+ //descriptor.class
+ //descriptor.descriptor
+ (text.replace_all //name.internal_separator
+ //name.external_separator))))]
+ (|> elementR
+ (format //descriptor.array_prefix)
+ :abstraction)))
+
+ (template [<name> <category>]
+ [(def: #export <name>
+ (Reflection <category>)
+ (:transmutation
+ (..class "java.lang.Object")))]
+
+ [var Var]
+ [wildcard Parameter]
+ )
+
+ (def: #export (lower reflection)
+ (-> (Reflection Class) (Reflection Parameter))
+ ..wildcard)
+
+ (def: #export upper
+ (-> (Reflection Class) (Reflection Parameter))
+ (|>> :transmutation))
+ )
diff --git a/stdlib/source/library/lux/target/jvm/type/signature.lux b/stdlib/source/library/lux/target/jvm/type/signature.lux
new file mode 100644
index 000000000..0b21807dd
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/type/signature.lux
@@ -0,0 +1,134 @@
+(.module:
+ [library
+ [lux (#- int char)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]]
+ [data
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [type
+ abstract]]]
+ ["." // #_
+ [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)]
+ ["#." descriptor]
+ ["/#" // #_
+ [encoding
+ ["#." name (#+ External)]]]])
+
+(abstract: #export (Signature category)
+ Text
+
+ (def: #export signature
+ (-> (Signature Any) Text)
+ (|>> :representation))
+
+ (template [<category> <name> <descriptor>]
+ [(def: #export <name>
+ (Signature <category>)
+ (:abstraction (//descriptor.descriptor <descriptor>)))]
+
+ [Void void //descriptor.void]
+ [Primitive boolean //descriptor.boolean]
+ [Primitive byte //descriptor.byte]
+ [Primitive short //descriptor.short]
+ [Primitive int //descriptor.int]
+ [Primitive long //descriptor.long]
+ [Primitive float //descriptor.float]
+ [Primitive double //descriptor.double]
+ [Primitive char //descriptor.char]
+ )
+
+ (def: #export array
+ (-> (Signature Value) (Signature Array))
+ (|>> :representation
+ (format //descriptor.array_prefix)
+ :abstraction))
+
+ (def: #export wildcard
+ (Signature Parameter)
+ (:abstraction "*"))
+
+ (def: #export var_prefix "T")
+
+ (def: #export var
+ (-> Text (Signature Var))
+ (|>> (text.enclose [..var_prefix //descriptor.class_suffix])
+ :abstraction))
+
+ (def: #export lower_prefix "-")
+ (def: #export upper_prefix "+")
+
+ (template [<name> <prefix>]
+ [(def: #export <name>
+ (-> (Signature Class) (Signature Parameter))
+ (|>> :representation (format <prefix>) :abstraction))]
+
+ [lower ..lower_prefix]
+ [upper ..upper_prefix]
+ )
+
+ (def: #export parameters_start "<")
+ (def: #export parameters_end ">")
+
+ (def: #export (class name parameters)
+ (-> External (List (Signature Parameter)) (Signature Class))
+ (:abstraction
+ (format //descriptor.class_prefix
+ (|> name ///name.internal ///name.read)
+ (case parameters
+ #.Nil
+ ""
+
+ _
+ (format ..parameters_start
+ (|> parameters
+ (list\map ..signature)
+ (text.join_with ""))
+ ..parameters_end))
+ //descriptor.class_suffix)))
+
+ (def: #export (declaration name variables)
+ (-> External (List (Signature Var)) (Signature Declaration))
+ (:transmutation (..class name variables)))
+
+ (def: #export as_class
+ (-> (Signature Declaration) (Signature Class))
+ (|>> :transmutation))
+
+ (def: #export arguments_start "(")
+ (def: #export arguments_end ")")
+
+ (def: #export exception_prefix "^")
+
+ (def: #export (method [inputs output exceptions])
+ (-> [(List (Signature Value))
+ (Signature Return)
+ (List (Signature Class))]
+ (Signature Method))
+ (:abstraction
+ (format (|> inputs
+ (list\map ..signature)
+ (text.join_with "")
+ (text.enclose [..arguments_start
+ ..arguments_end]))
+ (:representation output)
+ (|> exceptions
+ (list\map (|>> :representation (format ..exception_prefix)))
+ (text.join_with "")))))
+
+ (implementation: #export equivalence
+ (All [category] (Equivalence (Signature category)))
+
+ (def: (= parameter subject)
+ (text\= (:representation parameter)
+ (:representation subject))))
+
+ (implementation: #export hash
+ (All [category] (Hash (Signature category)))
+
+ (def: &equivalence ..equivalence)
+ (def: hash (|>> :representation text\hash)))
+ )
diff --git a/stdlib/source/library/lux/target/jvm/version.lux b/stdlib/source/library/lux/target/jvm/version.lux
new file mode 100644
index 000000000..0aaf297de
--- /dev/null
+++ b/stdlib/source/library/lux/target/jvm/version.lux
@@ -0,0 +1,38 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ ["." try]]]]
+ ["." // #_
+ [encoding
+ ["#." unsigned (#+ U2)]]])
+
+(type: #export Version U2)
+(type: #export Minor Version)
+(type: #export Major Version)
+
+(def: #export default_minor
+ Minor
+ (|> 0 //unsigned.u2 try.assume))
+
+(template [<number> <name>]
+ [(def: #export <name>
+ Major
+ (|> <number> //unsigned.u2 try.assume))]
+
+ [45 v1_1]
+ [46 v1_2]
+ [47 v1_3]
+ [48 v1_4]
+ [49 v5_0]
+ [50 v6_0]
+ [51 v7]
+ [52 v8]
+ [53 v9]
+ [54 v10]
+ [55 v11]
+ [56 v12]
+ )
+
+(def: #export writer
+ //unsigned.writer/2)
diff --git a/stdlib/source/library/lux/target/lua.lux b/stdlib/source/library/lux/target/lua.lux
new file mode 100644
index 000000000..7e0202481
--- /dev/null
+++ b/stdlib/source/library/lux/target/lua.lux
@@ -0,0 +1,416 @@
+(.module:
+ [library
+ [lux (#- Location Code int if cond function or and not let ^)
+ ["@" target]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]
+ ["." enum]]
+ [control
+ [pipe (#+ case> cond> new>)]
+ [parser
+ ["<.>" code]]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." template]
+ ["." code]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]
+ ["f" frac]]]
+ [type
+ abstract]]])
+
+(def: nest
+ (-> Text Text)
+ (.let [nested_new_line (format text.new_line text.tab)]
+ (|>> (format text.new_line)
+ (text.replace_all text.new_line nested_new_line))))
+
+(def: input_separator ", ")
+
+(abstract: #export (Code brand)
+ Text
+
+ (implementation: #export equivalence
+ (All [brand] (Equivalence (Code brand)))
+
+ (def: (= reference subject)
+ (\ text.equivalence = (:representation reference) (:representation subject))))
+
+ (implementation: #export hash
+ (All [brand] (Hash (Code brand)))
+
+ (def: &equivalence ..equivalence)
+ (def: hash (|>> :representation (\ text.hash hash))))
+
+ (def: #export manual
+ (-> Text Code)
+ (|>> :abstraction))
+
+ (def: #export code
+ (-> (Code Any) Text)
+ (|>> :representation))
+
+ (template [<type> <super>+]
+ [(with_expansions [<brand> (template.identifier [<type> "'"])]
+ (abstract: (<brand> brand) Any)
+ (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))]
+
+ [Expression [Code]]
+ [Computation [Expression' Code]]
+ [Location [Computation' Expression' Code]]
+ [Statement [Code]]
+ )
+
+ (template [<type> <super>+]
+ [(with_expansions [<brand> (template.identifier [<type> "'"])]
+ (abstract: #export <brand> Any)
+ (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))]
+
+ [Literal [Computation' Expression' Code]]
+ [Var [Location' Computation' Expression' Code]]
+ [Access [Location' Computation' Expression' Code]]
+ [Label [Code]]
+ )
+
+ (def: #export nil
+ Literal
+ (:abstraction "nil"))
+
+ (def: #export bool
+ (-> Bit Literal)
+ (|>> (case> #0 "false"
+ #1 "true")
+ :abstraction))
+
+ (def: #export int
+ (-> Int Literal)
+ ## Integers must be turned into hexadecimal to avoid quirks in how Lua parses integers.
+ ## In particular, the number -9223372036854775808 will be incorrectly parsed as a float by Lua.
+ (.let [to_hex (\ n.hex encode)]
+ (|>> .nat
+ to_hex
+ (format "0x")
+ :abstraction)))
+
+ (def: #export float
+ (-> Frac Literal)
+ (|>> (cond> [(f.= f.positive_infinity)]
+ [(new> "(1.0/0.0)" [])]
+
+ [(f.= f.negative_infinity)]
+ [(new> "(-1.0/0.0)" [])]
+
+ [(f.= f.not_a_number)]
+ [(new> "(0.0/0.0)" [])]
+
+ ## else
+ [%.frac (text.replace_all "+" "")])
+ :abstraction))
+
+ (def: sanitize
+ (-> Text Text)
+ (`` (|>> (~~ (template [<find> <replace>]
+ [(text.replace_all <find> <replace>)]
+
+ ["\" "\\"]
+ [text.tab "\t"]
+ [text.vertical_tab "\v"]
+ [text.null "\0"]
+ [text.back_space "\b"]
+ [text.form_feed "\f"]
+ [text.new_line "\n"]
+ [text.carriage_return "\r"]
+ [text.double_quote (format "\" text.double_quote)]
+ ))
+ )))
+
+ (def: #export string
+ (-> Text Literal)
+ (|>> ..sanitize (text.enclose' text.double_quote) :abstraction))
+
+ (def: #export multi
+ (-> (List Expression) Literal)
+ (|>> (list\map ..code)
+ (text.join_with ..input_separator)
+ :abstraction))
+
+ (def: #export array
+ (-> (List Expression) Literal)
+ (|>> (list\map ..code)
+ (text.join_with ..input_separator)
+ (text.enclose ["{" "}"])
+ :abstraction))
+
+ (def: #export table
+ (-> (List [Text Expression]) Literal)
+ (|>> (list\map (.function (_ [key value])
+ (format key " = " (:representation value))))
+ (text.join_with ..input_separator)
+ (text.enclose ["{" "}"])
+ :abstraction))
+
+ (def: #export (nth idx array)
+ (-> Expression Expression Access)
+ (:abstraction (format (:representation array) "[" (:representation idx) "]")))
+
+ (def: #export (the field table)
+ (-> Text Expression Computation)
+ (:abstraction (format (:representation table) "." field)))
+
+ (def: #export length
+ (-> Expression Computation)
+ (|>> :representation
+ (text.enclose ["#(" ")"])
+ :abstraction))
+
+ (def: #export (apply/* args func)
+ (-> (List Expression) Expression Computation)
+ (|> args
+ (list\map ..code)
+ (text.join_with ..input_separator)
+ (text.enclose ["(" ")"])
+ (format (:representation func))
+ :abstraction))
+
+ (def: #export (do method args table)
+ (-> Text (List Expression) Expression Computation)
+ (|> args
+ (list\map ..code)
+ (text.join_with ..input_separator)
+ (text.enclose ["(" ")"])
+ (format (:representation table) ":" method)
+ :abstraction))
+
+ (template [<op> <name>]
+ [(def: #export (<name> parameter subject)
+ (-> Expression Expression Expression)
+ (:abstraction (format "("
+ (:representation subject)
+ " " <op> " "
+ (:representation parameter)
+ ")")))]
+
+ ["==" =]
+ ["<" <]
+ ["<=" <=]
+ [">" >]
+ [">=" >=]
+ ["+" +]
+ ["-" -]
+ ["*" *]
+ ["^" ^]
+ ["/" /]
+ ["//" //]
+ ["%" %]
+ [".." concat]
+
+ ["or" or]
+ ["and" and]
+ ["|" bit_or]
+ ["&" bit_and]
+ ["~" bit_xor]
+
+ ["<<" bit_shl]
+ [">>" bit_shr]
+ )
+
+ (template [<name> <unary>]
+ [(def: #export (<name> subject)
+ (-> Expression Expression)
+ (:abstraction (format "(" <unary> " " (:representation subject) ")")))]
+
+ [not "not"]
+ [negate "-"]
+ )
+
+ (template [<name> <type>]
+ [(def: #export <name>
+ (-> Text <type>)
+ (|>> :abstraction))]
+
+ [var Var]
+ [label Label]
+ )
+
+ (def: #export statement
+ (-> Expression Statement)
+ (|>> :representation :abstraction))
+
+ (def: #export (then pre! post!)
+ (-> Statement Statement Statement)
+ (:abstraction
+ (format (:representation pre!)
+ text.new_line
+ (:representation post!))))
+
+ (def: locations
+ (-> (List Location) Text)
+ (|>> (list\map ..code)
+ (text.join_with ..input_separator)))
+
+ (def: #export (local vars)
+ (-> (List Var) Statement)
+ (:abstraction (format "local " (..locations vars))))
+
+ (def: #export (set vars value)
+ (-> (List Location) Expression Statement)
+ (:abstraction (format (..locations vars) " = " (:representation value))))
+
+ (def: #export (let vars value)
+ (-> (List Var) Expression Statement)
+ (:abstraction (format "local " (..locations vars) " = " (:representation value))))
+
+ (def: #export (local/1 var value)
+ (-> Var Expression Statement)
+ (:abstraction (format "local " (:representation var) " = " (:representation value))))
+
+ (def: #export (if test then! else!)
+ (-> Expression Statement Statement Statement)
+ (:abstraction (format "if " (:representation test)
+ text.new_line "then" (..nest (:representation then!))
+ text.new_line "else" (..nest (:representation else!))
+ text.new_line "end")))
+
+ (def: #export (when test then!)
+ (-> Expression Statement Statement)
+ (:abstraction (format "if " (:representation test)
+ text.new_line "then" (..nest (:representation then!))
+ text.new_line "end")))
+
+ (def: #export (while test body!)
+ (-> Expression Statement Statement)
+ (:abstraction
+ (format "while " (:representation test) " do"
+ (..nest (:representation body!))
+ text.new_line "end")))
+
+ (def: #export (repeat until body!)
+ (-> Expression Statement Statement)
+ (:abstraction
+ (format "repeat"
+ (..nest (:representation body!))
+ text.new_line "until " (:representation until))))
+
+ (def: #export (for_in vars source body!)
+ (-> (List Var) Expression Statement Statement)
+ (:abstraction
+ (format "for " (|> vars
+ (list\map ..code)
+ (text.join_with ..input_separator))
+ " in " (:representation source) " do"
+ (..nest (:representation body!))
+ text.new_line "end")))
+
+ (def: #export (for_step var from to step body!)
+ (-> Var Expression Expression Expression Statement
+ Statement)
+ (:abstraction
+ (format "for " (:representation var)
+ " = " (:representation from)
+ ..input_separator (:representation to)
+ ..input_separator (:representation step) " do"
+ (..nest (:representation body!))
+ text.new_line "end")))
+
+ (def: #export (return value)
+ (-> Expression Statement)
+ (:abstraction (format "return " (:representation value))))
+
+ (def: #export (closure args body!)
+ (-> (List Var) Statement Expression)
+ (|> (format "function " (|> args
+ ..locations
+ (text.enclose ["(" ")"]))
+ (..nest (:representation body!))
+ text.new_line "end")
+ (text.enclose ["(" ")"])
+ :abstraction))
+
+ (template [<name> <code>]
+ [(def: #export (<name> name args body!)
+ (-> Var (List Var) Statement Statement)
+ (:abstraction
+ (format <code> " " (:representation name)
+ (|> args
+ ..locations
+ (text.enclose ["(" ")"]))
+ (..nest (:representation body!))
+ text.new_line "end")))]
+
+ [function "function"]
+ [local_function "local function"]
+ )
+
+ (def: #export break
+ Statement
+ (:abstraction "break"))
+
+ (def: #export (set_label label)
+ (-> Label Statement)
+ (:abstraction (format "::" (:representation label) "::")))
+
+ (def: #export (go_to label)
+ (-> Label Statement)
+ (:abstraction (format "goto " (:representation label))))
+ )
+
+(def: #export (cond clauses else!)
+ (-> (List [Expression Statement]) Statement Statement)
+ (list\fold (.function (_ [test then!] next!)
+ (..if test then! next!))
+ else!
+ (list.reverse clauses)))
+
+(syntax: (arity_inputs {arity <code>.nat})
+ (wrap (case arity
+ 0 (.list)
+ _ (|> (dec arity)
+ (enum.range n.enum 0)
+ (list\map (|>> %.nat code.local_identifier))))))
+
+(syntax: (arity_types {arity <code>.nat})
+ (wrap (list.repeat arity (` ..Expression))))
+
+(template [<arity> <function>+]
+ [(with_expansions [<apply> (template.identifier ["apply/" <arity>])
+ <inputs> (arity_inputs <arity>)
+ <types> (arity_types <arity>)
+ <definitions> (template.splice <function>+)]
+ (def: #export (<apply> function <inputs>)
+ (-> Expression <types> Computation)
+ (..apply/* (.list <inputs>) function))
+
+ (template [<function>]
+ [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>]))
+ (<apply> (..var <function>))))]
+
+ <definitions>))]
+
+ [1
+ [["error"]
+ ["print"]
+ ["require"]
+ ["type"]
+ ["ipairs"]]]
+
+ [2
+ [["print"]
+ ["error"]]]
+
+ [3
+ [["print"]]]
+
+ [4
+ []]
+
+ [5
+ []]
+ )
diff --git a/stdlib/source/library/lux/target/php.lux b/stdlib/source/library/lux/target/php.lux
new file mode 100644
index 000000000..6a3e01fbb
--- /dev/null
+++ b/stdlib/source/library/lux/target/php.lux
@@ -0,0 +1,545 @@
+(.module:
+ [library
+ [lux (#- Location Code Global static int if cond or and not comment for try)
+ ["@" target]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]
+ ["." enum]]
+ [control
+ [pipe (#+ case> cond> new>)]
+ [parser
+ ["<.>" code]]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." template]
+ ["." code]]
+ [math
+ [number
+ ["n" nat]
+ ["f" frac]]]
+ [type
+ abstract]]])
+
+(def: input_separator ", ")
+(def: statement_suffix ";")
+
+(def: nest
+ (-> Text Text)
+ (.let [nested_new_line (format text.new_line text.tab)]
+ (|>> (format text.new_line)
+ (text.replace_all text.new_line nested_new_line))))
+
+(def: block
+ (-> Text Text)
+ (|>> ..nest (text.enclose ["{" (format text.new_line "}")])))
+
+(def: group
+ (-> Text Text)
+ (text.enclose ["(" ")"]))
+
+(abstract: #export (Code brand)
+ Text
+
+ (implementation: #export equivalence
+ (All [brand] (Equivalence (Code brand)))
+
+ (def: (= reference subject)
+ (\ text.equivalence = (:representation reference) (:representation subject))))
+
+ (implementation: #export hash
+ (All [brand] (Hash (Code brand)))
+
+ (def: &equivalence ..equivalence)
+ (def: hash (|>> :representation (\ text.hash hash))))
+
+ (def: #export manual
+ (-> Text Code)
+ (|>> :abstraction))
+
+ (def: #export code
+ (-> (Code Any) Text)
+ (|>> :representation))
+
+ (template [<type> <super>+]
+ [(with_expansions [<brand> (template.identifier [<type> "'"])]
+ (abstract: (<brand> brand) Any)
+ (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))]
+
+ [Expression [Code]]
+ [Computation [Expression' Code]]
+ [Location [Computation' Expression' Code]]
+ [Statement [Code]]
+ )
+
+ (template [<type> <super>+]
+ [(with_expansions [<brand> (template.identifier [<type> "'"])]
+ (abstract: #export <brand> Any)
+ (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))]
+
+ [Literal [Computation' Expression' Code]]
+ [Var [Location' Computation' Expression' Code]]
+ [Access [Location' Computation' Expression' Code]]
+ [Constant [Location' Computation' Expression' Code]]
+ [Global [Location' Computation' Expression' Code]]
+ [Label [Code]]
+ )
+
+ (type: #export Argument
+ {#reference? Bit
+ #var Var})
+
+ (def: #export ;
+ (-> Expression Statement)
+ (|>> :representation
+ (text.suffix ..statement_suffix)
+ :abstraction))
+
+ (def: #export var
+ (-> Text Var)
+ (|>> (format "$") :abstraction))
+
+ (template [<name> <type>]
+ [(def: #export <name>
+ (-> Text <type>)
+ (|>> :abstraction))]
+
+ [constant Constant]
+ [label Label]
+ )
+
+ (def: #export (set_label label)
+ (-> Label Statement)
+ (:abstraction (format (:representation label) ":")))
+
+ (def: #export (go_to label)
+ (-> Label Statement)
+ (:abstraction
+ (format "goto " (:representation label) ..statement_suffix)))
+
+ (def: #export null
+ Literal
+ (:abstraction "NULL"))
+
+ (def: #export bool
+ (-> Bit Literal)
+ (|>> (case> #0 "false"
+ #1 "true")
+ :abstraction))
+
+ (def: #export int
+ (-> Int Literal)
+ (.let [to_hex (\ n.hex encode)]
+ (|>> .nat
+ to_hex
+ (format "0x")
+ :abstraction)))
+
+ (def: #export float
+ (-> Frac Literal)
+ (|>> (cond> [(f.= f.positive_infinity)]
+ [(new> "+INF" [])]
+
+ [(f.= f.negative_infinity)]
+ [(new> "-INF" [])]
+
+ [(f.= f.not_a_number)]
+ [(new> "NAN" [])]
+
+ ## else
+ [%.frac])
+ :abstraction))
+
+ (def: sanitize
+ (-> Text Text)
+ (`` (|>> (~~ (template [<find> <replace>]
+ [(text.replace_all <find> <replace>)]
+
+ ["\" "\\"]
+ [text.tab "\t"]
+ [text.vertical_tab "\v"]
+ [text.null "\0"]
+ [text.back_space "\b"]
+ [text.form_feed "\f"]
+ [text.new_line "\n"]
+ [text.carriage_return "\r"]
+ [text.double_quote (format "\" text.double_quote)]
+ ["$" "\$"]
+ ))
+ )))
+
+ (def: #export string
+ (-> Text Literal)
+ (|>> ..sanitize
+ (text.enclose [text.double_quote text.double_quote])
+ :abstraction))
+
+ (def: arguments
+ (-> (List Expression) Text)
+ (|>> (list\map ..code) (text.join_with ..input_separator) ..group))
+
+ (def: #export (apply/* args func)
+ (-> (List Expression) Expression Computation)
+ (|> (format (:representation func) (..arguments args))
+ :abstraction))
+
+ ## TODO: Remove when no longer using JPHP.
+ (def: #export (apply/*' args func)
+ (-> (List Expression) Expression Computation)
+ (apply/* (list& func args) (..constant "call_user_func")))
+
+ (def: parameters
+ (-> (List Argument) Text)
+ (|>> (list\map (function (_ [reference? var])
+ (.if reference?
+ (format "&" (:representation var))
+ (:representation var))))
+ (text.join_with ..input_separator)
+ ..group))
+
+ (template [<name> <reference?>]
+ [(def: #export <name>
+ (-> Var Argument)
+ (|>> [<reference?>]))]
+
+ [parameter #0]
+ [reference #1]
+ )
+
+ (def: #export (closure uses arguments body!)
+ (-> (List Argument) (List Argument) Statement Literal)
+ (let [uses (case uses
+ #.Nil
+ ""
+
+ _
+ (format "use " (..parameters uses)))]
+ (|> (format "function " (..parameters arguments)
+ " " uses " "
+ (..block (:representation body!)))
+ ..group
+ :abstraction)))
+
+ (syntax: (arity_inputs {arity <code>.nat})
+ (wrap (case arity
+ 0 (.list)
+ _ (|> (dec arity)
+ (enum.range n.enum 0)
+ (list\map (|>> %.nat code.local_identifier))))))
+
+ (syntax: (arity_types {arity <code>.nat})
+ (wrap (list.repeat arity (` ..Expression))))
+
+ (template [<arity> <function>+]
+ [(with_expansions [<apply> (template.identifier ["apply/" <arity>])
+ <inputs> (arity_inputs <arity>)
+ <types> (arity_types <arity>)
+ <definitions> (template.splice <function>+)]
+ (def: #export (<apply> function [<inputs>])
+ (-> Expression [<types>] Computation)
+ (..apply/* (.list <inputs>) function))
+
+ (template [<function>]
+ [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>]))
+ (<apply> (..constant <function>))))]
+
+ <definitions>))]
+
+ [0
+ [["func_num_args"]
+ ["func_get_args"]
+ ["time"]
+ ["phpversion"]]]
+
+ [1
+ [["isset"]
+ ["var_dump"]
+ ["is_null"]
+ ["empty"]
+ ["count"]
+ ["array_pop"]
+ ["array_reverse"]
+ ["intval"]
+ ["floatval"]
+ ["strval"]
+ ["ord"]
+ ["chr"]
+ ["print"]
+ ["exit"]
+ ["iconv_strlen"] ["strlen"]
+ ["log"]
+ ["ceil"]
+ ["floor"]
+ ["is_nan"]]]
+
+ [2
+ [["intdiv"]
+ ["fmod"]
+ ["number_format"]
+ ["array_key_exists"]
+ ["call_user_func_array"]
+ ["array_slice"]
+ ["array_push"]
+ ["pack"]
+ ["unpack"]
+ ["iconv_strpos"] ["strpos"]
+ ["pow"]
+ ["max"]]]
+
+ [3
+ [["array_fill"]
+ ["array_slice"]
+ ["array_splice"]
+ ["iconv"]
+ ["iconv_strpos"] ["strpos"]
+ ["iconv_substr"] ["substr"]]]
+ )
+
+ (def: #export (key_value key value)
+ (-> Expression Expression Expression)
+ (:abstraction (format (:representation key) " => " (:representation value))))
+
+ (def: #export (array/* values)
+ (-> (List Expression) Literal)
+ (|> values
+ (list\map ..code)
+ (text.join_with ..input_separator)
+ ..group
+ (format "array")
+ :abstraction))
+
+ (def: #export (array_merge/+ required optionals)
+ (-> Expression (List Expression) Computation)
+ (..apply/* (list& required optionals) (..constant "array_merge")))
+
+ (def: #export (array/** kvs)
+ (-> (List [Expression Expression]) Literal)
+ (|> kvs
+ (list\map (function (_ [key value])
+ (format (:representation key) " => " (:representation value))))
+ (text.join_with ..input_separator)
+ ..group
+ (format "array")
+ :abstraction))
+
+ (def: #export (new constructor inputs)
+ (-> Constant (List Expression) Computation)
+ (|> (format "new " (:representation constructor) (arguments inputs))
+ :abstraction))
+
+ (def: #export (the field object)
+ (-> Text Expression Computation)
+ (|> (format (:representation object) "->" field)
+ :abstraction))
+
+ (def: #export (do method inputs object)
+ (-> Text (List Expression) Expression Computation)
+ (|> (format (:representation (..the method object))
+ (..arguments inputs))
+ :abstraction))
+
+ (def: #export (nth idx array)
+ (-> Expression Expression Access)
+ (|> (format (:representation array) "[" (:representation idx) "]")
+ :abstraction))
+
+ (def: #export (global name)
+ (-> Text Global)
+ (|> (..var "GLOBALS") (..nth (..string name)) :transmutation))
+
+ (def: #export (? test then else)
+ (-> Expression Expression Expression Computation)
+ (|> (format (..group (:representation test)) " ? "
+ (..group (:representation then)) " : "
+ (..group (:representation else)))
+ ..group
+ :abstraction))
+
+ (template [<name> <op>]
+ [(def: #export (<name> parameter subject)
+ (-> Expression Expression Computation)
+ (|> (format (:representation subject) " " <op> " " (:representation parameter))
+ ..group
+ :abstraction))]
+
+ [or "||"]
+ [and "&&"]
+ [== "=="]
+ [=== "==="]
+ [< "<"]
+ [<= "<="]
+ [> ">"]
+ [>= ">="]
+ [+ "+"]
+ [- "-"]
+ [* "*"]
+ [/ "/"]
+ [% "%"]
+ [bit_or "|"]
+ [bit_and "&"]
+ [bit_xor "^"]
+ [bit_shl "<<"]
+ [bit_shr ">>"]
+ [concat "."]
+ )
+
+ (template [<unary> <name>]
+ [(def: #export <name>
+ (-> Computation Computation)
+ (|>> :representation (format <unary>) :abstraction))]
+
+ ["!" not]
+ ["~" bit_not]
+ ["-" negate]
+ )
+
+ (def: #export (set var value)
+ (-> Location Expression Computation)
+ (|> (format (:representation var) " = " (:representation value))
+ ..group
+ :abstraction))
+
+ (def: #export (set! var value)
+ (-> Location Expression Statement)
+ (:abstraction (format (:representation var) " = " (:representation value) ";")))
+
+ (def: #export (set? var)
+ (-> Var Computation)
+ (..apply/1 [var] (..constant "isset")))
+
+ (template [<name> <modifier>]
+ [(def: #export <name>
+ (-> Var Statement)
+ (|>> :representation (format <modifier> " ") (text.suffix ..statement_suffix) :abstraction))]
+
+ [define_global "global"]
+ )
+
+ (template [<name> <modifier> <location>]
+ [(def: #export (<name> location value)
+ (-> <location> Expression Statement)
+ (:abstraction (format <modifier> " " (:representation location)
+ " = " (:representation value)
+ ..statement_suffix)))]
+
+ [define_static "static" Var]
+ [define_constant "const" Constant]
+ )
+
+ (def: #export (if test then! else!)
+ (-> Expression Statement Statement Statement)
+ (:abstraction
+ (format "if" (..group (:representation test)) " "
+ (..block (:representation then!))
+ " else "
+ (..block (:representation else!)))))
+
+ (def: #export (when test then!)
+ (-> Expression Statement Statement)
+ (:abstraction
+ (format "if" (..group (:representation test)) " "
+ (..block (:representation then!)))))
+
+ (def: #export (then pre! post!)
+ (-> Statement Statement Statement)
+ (:abstraction
+ (format (:representation pre!)
+ text.new_line
+ (:representation post!))))
+
+ (def: #export (while test body!)
+ (-> Expression Statement Statement)
+ (:abstraction
+ (format "while" (..group (:representation test)) " "
+ (..block (:representation body!)))))
+
+ (def: #export (do_while test body!)
+ (-> Expression Statement Statement)
+ (:abstraction
+ (format "do " (..block (:representation body!))
+ " while" (..group (:representation test))
+ ..statement_suffix)))
+
+ (def: #export (for_each array value body!)
+ (-> Expression Var Statement Statement)
+ (:abstraction
+ (format "foreach(" (:representation array)
+ " as " (:representation value)
+ ") " (..block (:representation body!)))))
+
+ (type: #export Except
+ {#class Constant
+ #exception Var
+ #handler Statement})
+
+ (def: (catch except)
+ (-> Except Text)
+ (let [declaration (format (:representation (get@ #class except))
+ " " (:representation (get@ #exception except)))]
+ (format "catch" (..group declaration) " "
+ (..block (:representation (get@ #handler except))))))
+
+ (def: #export (try body! excepts)
+ (-> Statement (List Except) Statement)
+ (:abstraction
+ (format "try " (..block (:representation body!))
+ text.new_line
+ (|> excepts
+ (list\map catch)
+ (text.join_with text.new_line)))))
+
+ (template [<name> <keyword>]
+ [(def: #export <name>
+ (-> Expression Statement)
+ (|>> :representation (format <keyword> " ") (text.suffix ..statement_suffix) :abstraction))]
+
+ [throw "throw"]
+ [return "return"]
+ [echo "echo"]
+ )
+
+ (def: #export (define name value)
+ (-> Constant Expression Expression)
+ (..apply/2 (..constant "define")
+ [(|> name :representation ..string)
+ value]))
+
+ (def: #export (define_function name arguments body!)
+ (-> Constant (List Argument) Statement Statement)
+ (:abstraction
+ (format "function " (:representation name)
+ (..parameters arguments)
+ " "
+ (..block (:representation body!)))))
+
+ (template [<name> <keyword>]
+ [(def: #export <name>
+ Statement
+ (|> <keyword>
+ (text.suffix ..statement_suffix)
+ :abstraction))]
+
+ [break "break"]
+ [continue "continue"]
+ )
+
+ (def: #export splat
+ (-> Expression Expression)
+ (|>> :representation (format "...") :abstraction))
+ )
+
+(def: #export (cond clauses else!)
+ (-> (List [Expression Statement]) Statement Statement)
+ (list\fold (function (_ [test then!] next!)
+ (..if test then! next!))
+ else!
+ (list.reverse clauses)))
+
+(def: #export command_line_arguments
+ Var
+ (..var "argv"))
diff --git a/stdlib/source/library/lux/target/python.lux b/stdlib/source/library/lux/target/python.lux
new file mode 100644
index 000000000..49c3d8612
--- /dev/null
+++ b/stdlib/source/library/lux/target/python.lux
@@ -0,0 +1,501 @@
+(.module:
+ [library
+ [lux (#- Location Code not or and list if cond int comment exec try)
+ ["@" target]
+ ["." ffi]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]
+ ["." enum]]
+ [control
+ [pipe (#+ new> case> cond>)]
+ [parser
+ ["<.>" code]]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." template]
+ ["." code]]
+ [math
+ [number
+ ["n" nat]
+ ["f" frac]]]
+ [type
+ abstract]]])
+
+(def: expression
+ (-> Text Text)
+ (text.enclose ["(" ")"]))
+
+(for {@.old (as_is (ffi.import: java/lang/CharSequence)
+ (ffi.import: java/lang/String
+ ["#::."
+ (replace [java/lang/CharSequence java/lang/CharSequence] java/lang/String)]))}
+ (as_is))
+
+(def: nest
+ (-> Text Text)
+ (.let [nested_new_line (format text.new_line text.tab)]
+ (for {@.old (|>> (format text.new_line)
+ (:as java/lang/String)
+ (java/lang/String::replace (:as java/lang/CharSequence text.new_line)
+ (:as java/lang/CharSequence nested_new_line)))}
+ (|>> (format text.new_line)
+ (text.replace_all text.new_line nested_new_line)))))
+
+(abstract: #export (Code brand)
+ Text
+
+ (implementation: #export equivalence
+ (All [brand] (Equivalence (Code brand)))
+
+ (def: (= reference subject)
+ (\ text.equivalence = (:representation reference) (:representation subject))))
+
+ (implementation: #export hash
+ (All [brand] (Hash (Code brand)))
+
+ (def: &equivalence ..equivalence)
+ (def: hash (|>> :representation (\ text.hash hash))))
+
+ (def: #export manual
+ (-> Text Code)
+ (|>> :abstraction))
+
+ (def: #export code
+ (-> (Code Any) Text)
+ (|>> :representation))
+
+ (template [<type> <super>]
+ [(with_expansions [<brand> (template.identifier [<type> "'"])]
+ (`` (abstract: #export (<brand> brand) Any))
+ (`` (type: #export (<type> brand)
+ (<super> (<brand> brand)))))]
+
+ [Expression Code]
+ [Computation Expression]
+ [Location Computation]
+ [Var Location]
+ [Statement Code]
+ )
+
+ (template [<type> <super>]
+ [(with_expansions [<brand> (template.identifier [<type> "'"])]
+ (`` (abstract: #export <brand> Any))
+ (`` (type: #export <type> (<super> <brand>))))]
+
+ [Literal Computation]
+ [Access Location]
+ [Loop Statement]
+ [Label Code]
+ )
+
+ (template [<var> <brand>]
+ [(abstract: #export <brand> Any)
+
+ (type: #export <var> (Var <brand>))]
+
+ [SVar Single]
+ [PVar Poly]
+ [KVar Keyword]
+ )
+
+ (def: #export var
+ (-> Text SVar)
+ (|>> :abstraction))
+
+ (template [<name> <brand> <prefix>]
+ [(def: #export <name>
+ (-> SVar (Var <brand>))
+ (|>> :representation (format <prefix>) :abstraction))]
+
+ [poly Poly "*"]
+ [keyword Keyword "**"]
+ )
+
+ (def: #export none
+ Literal
+ (:abstraction "None"))
+
+ (def: #export bool
+ (-> Bit Literal)
+ (|>> (case> #0 "False"
+ #1 "True")
+ :abstraction))
+
+ (def: #export int
+ (-> Int Literal)
+ (|>> %.int :abstraction))
+
+ (def: #export (long value)
+ (-> Int Literal)
+ (:abstraction (format (%.int value) "L")))
+
+ (def: #export float
+ (-> Frac Literal)
+ (`` (|>> (cond> (~~ (template [<test> <python>]
+ [[<test>]
+ [(new> (format "float(" text.double_quote <python> text.double_quote ")") [])]]
+
+ [(f.= f.positive_infinity) "inf"]
+ [(f.= f.negative_infinity) "-inf"]
+ [f.not_a_number? "nan"]
+ ))
+
+ ## else
+ [%.frac])
+ :abstraction)))
+
+ (def: sanitize
+ (-> Text Text)
+ (`` (|>> (~~ (template [<find> <replace>]
+ [(text.replace_all <find> <replace>)]
+
+ ["\" "\\"]
+ [text.tab "\t"]
+ [text.vertical_tab "\v"]
+ [text.null "\0"]
+ [text.back_space "\b"]
+ [text.form_feed "\f"]
+ [text.new_line "\n"]
+ [text.carriage_return "\r"]
+ [text.double_quote (format "\" text.double_quote)]
+ ))
+ )))
+
+ (def: #export string
+ (-> Text Literal)
+ (|>> ..sanitize
+ (text.enclose [text.double_quote text.double_quote])
+ :abstraction))
+
+ (def: #export unicode
+ (-> Text Literal)
+ (|>> ..string
+ :representation
+ (format "u")
+ :abstraction))
+
+ (def: (composite_literal left_delimiter right_delimiter entry_serializer)
+ (All [a]
+ (-> Text Text (-> a Text)
+ (-> (List a) Literal)))
+ (function (_ entries)
+ (<| :abstraction
+ ## ..expression
+ (format left_delimiter
+ (|> entries
+ (list\map entry_serializer)
+ (text.join_with ", "))
+ right_delimiter))))
+
+ (template [<name> <pre> <post>]
+ [(def: #export <name>
+ (-> (List (Expression Any)) Literal)
+ (composite_literal <pre> <post> ..code))]
+
+ [tuple "(" ")"]
+ [list "[" "]"]
+ )
+
+ (def: #export (slice from to list)
+ (-> (Expression Any) (Expression Any) (Expression Any) Access)
+ (<| :abstraction
+ ## ..expression
+ (format (:representation list) "[" (:representation from) ":" (:representation to) "]")))
+
+ (def: #export (slice_from from list)
+ (-> (Expression Any) (Expression Any) Access)
+ (<| :abstraction
+ ## ..expression
+ (format (:representation list) "[" (:representation from) ":]")))
+
+ (def: #export dict
+ (-> (List [(Expression Any) (Expression Any)]) (Computation Any))
+ (composite_literal "{" "}" (.function (_ [k v]) (format (:representation k) " : " (:representation v)))))
+
+ (def: #export (apply/* func args)
+ (-> (Expression Any) (List (Expression Any)) (Computation Any))
+ (<| :abstraction
+ ## ..expression
+ (format (:representation func) "(" (text.join_with ", " (list\map ..code args)) ")")))
+
+ (template [<name> <brand> <prefix>]
+ [(def: (<name> var)
+ (-> (Expression Any) Text)
+ (format <prefix> (:representation var)))]
+
+ [splat_poly Poly "*"]
+ [splat_keyword Keyword "**"]
+ )
+
+ (template [<name> <splat>]
+ [(def: #export (<name> args extra func)
+ (-> (List (Expression Any)) (Expression Any) (Expression Any) (Computation Any))
+ (<| :abstraction
+ ## ..expression
+ (format (:representation func)
+ (format "(" (|> args
+ (list\map (function (_ arg) (format (:representation arg) ", ")))
+ (text.join_with ""))
+ (<splat> extra) ")"))))]
+
+ [apply_poly splat_poly]
+ [apply_keyword splat_keyword]
+ )
+
+ (def: #export (the name object)
+ (-> Text (Expression Any) (Computation Any))
+ (:abstraction (format (:representation object) "." name)))
+
+ (def: #export (do method args object)
+ (-> Text (List (Expression Any)) (Expression Any) (Computation Any))
+ (..apply/* (..the method object) args))
+
+ (template [<name> <apply>]
+ [(def: #export (<name> args extra method)
+ (-> (List (Expression Any)) (Expression Any) Text
+ (-> (Expression Any) (Computation Any)))
+ (|>> (..the method) (<apply> args extra)))]
+
+ [do_poly apply_poly]
+ [do_keyword apply_keyword]
+ )
+
+ (def: #export (nth idx array)
+ (-> (Expression Any) (Expression Any) Location)
+ (:abstraction (format (:representation array) "[" (:representation idx) "]")))
+
+ (def: #export (? test then else)
+ (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any))
+ (<| :abstraction
+ ..expression
+ (format (:representation then) " if " (:representation test) " else " (:representation else))))
+
+ (template [<name> <op>]
+ [(def: #export (<name> param subject)
+ (-> (Expression Any) (Expression Any) (Computation Any))
+ (<| :abstraction
+ ..expression
+ (format (:representation subject) " " <op> " " (:representation param))))]
+
+ [is "is"]
+ [= "=="]
+ [< "<"]
+ [<= "<="]
+ [> ">"]
+ [>= ">="]
+ [+ "+"]
+ [- "-"]
+ [* "*"]
+ [/ "/"]
+ [// "//"]
+ [% "%"]
+ [** "**"]
+ [bit_or "|"]
+ [bit_and "&"]
+ [bit_xor "^"]
+ [bit_shl "<<"]
+ [bit_shr ">>"]
+
+ [or "or"]
+ [and "and"]
+ )
+
+ (template [<name> <unary>]
+ [(def: #export (<name> subject)
+ (-> (Expression Any) (Computation Any))
+ (<| :abstraction
+ ## ..expression
+ (format <unary> " " (:representation subject))))]
+
+ [not "not"]
+ [negate "-"]
+ )
+
+ (def: #export (lambda arguments body)
+ (-> (List (Var Any)) (Expression Any) (Computation Any))
+ (<| :abstraction
+ ..expression
+ (format "lambda " (|> arguments (list\map ..code) (text.join_with ", ")) ": "
+ (:representation body))))
+
+ (def: #export (set vars value)
+ (-> (List (Location Any)) (Expression Any) (Statement Any))
+ (:abstraction
+ (format (|> vars (list\map ..code) (text.join_with ", "))
+ " = "
+ (:representation value))))
+
+ (def: #export (delete where)
+ (-> (Location Any) (Statement Any))
+ (:abstraction (format "del " (:representation where))))
+
+ (def: #export (if test then! else!)
+ (-> (Expression Any) (Statement Any) (Statement Any) (Statement Any))
+ (:abstraction
+ (format "if " (:representation test) ":"
+ (..nest (:representation then!))
+ text.new_line "else:"
+ (..nest (:representation else!)))))
+
+ (def: #export (when test then!)
+ (-> (Expression Any) (Statement Any) (Statement Any))
+ (:abstraction
+ (format "if " (:representation test) ":"
+ (..nest (:representation then!)))))
+
+ (def: #export (then pre! post!)
+ (-> (Statement Any) (Statement Any) (Statement Any))
+ (:abstraction
+ (format (:representation pre!)
+ text.new_line
+ (:representation post!))))
+
+ (template [<keyword> <0>]
+ [(def: #export <0>
+ (Statement Any)
+ (:abstraction <keyword>))]
+
+ ["break" break]
+ ["continue" continue]
+ )
+
+ (def: #export (while test body! else!)
+ (-> (Expression Any) (Statement Any) (Maybe (Statement Any)) Loop)
+ (:abstraction
+ (format "while " (:representation test) ":"
+ (..nest (:representation body!))
+ (case else!
+ (#.Some else!)
+ (format text.new_line "else:"
+ (..nest (:representation else!)))
+
+ #.None
+ ""))))
+
+ (def: #export (for_in var inputs body!)
+ (-> SVar (Expression Any) (Statement Any) Loop)
+ (:abstraction
+ (format "for " (:representation var) " in " (:representation inputs) ":"
+ (..nest (:representation body!)))))
+
+ (def: #export statement
+ (-> (Expression Any) (Statement Any))
+ (|>> :transmutation))
+
+ (def: #export pass
+ (Statement Any)
+ (:abstraction "pass"))
+
+ (type: #export Except
+ {#classes (List SVar)
+ #exception SVar
+ #handler (Statement Any)})
+
+ (def: #export (try body! excepts)
+ (-> (Statement Any) (List Except) (Statement Any))
+ (:abstraction
+ (format "try:"
+ (..nest (:representation body!))
+ (|> excepts
+ (list\map (function (_ [classes exception catch!])
+ (format text.new_line "except (" (text.join_with ", " (list\map ..code classes))
+ ") as " (:representation exception) ":"
+ (..nest (:representation catch!)))))
+ (text.join_with "")))))
+
+ (template [<name> <keyword> <pre>]
+ [(def: #export (<name> value)
+ (-> (Expression Any) (Statement Any))
+ (:abstraction
+ (format <keyword> (<pre> (:representation value)))))]
+
+ [raise "raise " |>]
+ [return "return " |>]
+ [print "print" ..expression]
+ )
+
+ (def: #export (exec code globals)
+ (-> (Expression Any) (Maybe (Expression Any)) (Statement Any))
+ (let [extra (case globals
+ (#.Some globals)
+ (.list globals)
+
+ #.None
+ (.list))]
+ (:abstraction
+ (format "exec" (:representation (..tuple (list& code extra)))))))
+
+ (def: #export (def name args body)
+ (-> SVar (List (Ex [k] (Var k))) (Statement Any) (Statement Any))
+ (:abstraction
+ (format "def " (:representation name)
+ "(" (|> args (list\map ..code) (text.join_with ", ")) "):"
+ (..nest (:representation body)))))
+
+ (def: #export (import module_name)
+ (-> Text (Statement Any))
+ (:abstraction (format "import " module_name)))
+
+ (def: #export (comment commentary on)
+ (All [brand] (-> Text (Code brand) (Code brand)))
+ (:abstraction (format "# " (..sanitize commentary) text.new_line
+ (:representation on))))
+ )
+
+(def: #export (cond clauses else!)
+ (-> (List [(Expression Any) (Statement Any)]) (Statement Any) (Statement Any))
+ (list\fold (.function (_ [test then!] next!)
+ (..if test then! next!))
+ else!
+ (list.reverse clauses)))
+
+(syntax: (arity_inputs {arity <code>.nat})
+ (wrap (case arity
+ 0 (.list)
+ _ (|> (dec arity)
+ (enum.range n.enum 0)
+ (list\map (|>> %.nat code.local_identifier))))))
+
+(syntax: (arity_types {arity <code>.nat})
+ (wrap (list.repeat arity (` (Expression Any)))))
+
+(template [<arity> <function>+]
+ [(with_expansions [<apply> (template.identifier ["apply/" <arity>])
+ <inputs> (arity_inputs <arity>)
+ <types> (arity_types <arity>)
+ <definitions> (template.splice <function>+)]
+ (def: #export (<apply> function <inputs>)
+ (-> (Expression Any) <types> (Computation Any))
+ (..apply/* function (.list <inputs>)))
+
+ (template [<function>]
+ [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>]))
+ (<apply> (..var <function>))))]
+
+ <definitions>))]
+
+ [1
+ [["str"]
+ ["ord"]
+ ["float"]
+ ["int"]
+ ["len"]
+ ["chr"]
+ ["unichr"]
+ ["unicode"]
+ ["repr"]
+ ["__import__"]
+ ["Exception"]]]
+
+ [2
+ []]
+
+ [3
+ []]
+ )
diff --git a/stdlib/source/library/lux/target/r.lux b/stdlib/source/library/lux/target/r.lux
new file mode 100644
index 000000000..fee2e206b
--- /dev/null
+++ b/stdlib/source/library/lux/target/r.lux
@@ -0,0 +1,386 @@
+(.module:
+ [library
+ [lux (#- Code or and list if function cond not int)
+ [control
+ [pipe (#+ case> cond> new>)]
+ ["." function]
+ [parser
+ ["<.>" code]]]
+ [data
+ ["." maybe ("#\." functor)]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." template]
+ ["." code]]
+ [math
+ [number
+ ["f" frac]]]
+ [type
+ abstract]]])
+
+(abstract: #export (Code kind)
+ Text
+
+ {}
+
+ (template [<type> <super>+]
+ [(with_expansions [<kind> (template.identifier [<type> "'"])]
+ (abstract: #export (<kind> kind) Any)
+ (`` (type: #export <type> (|> Any <kind> (~~ (template.splice <super>+))))))]
+
+ [Expression [Code]]
+ )
+
+ (template [<type> <super>+]
+ [(with_expansions [<kind> (template.identifier [<type> "'"])]
+ (abstract: #export (<kind> kind) Any)
+ (`` (type: #export (<type> <brand>) (|> <brand> <kind> (~~ (template.splice <super>+))))))]
+
+ [Var [Expression' Code]]
+ )
+
+ (template [<var> <kind>]
+ [(abstract: #export <kind> Any)
+ (type: #export <var> (Var <kind>))]
+
+ [SVar Single]
+ [PVar Poly]
+ )
+
+ (def: #export var
+ (-> Text SVar)
+ (|>> :abstraction))
+
+ (def: #export var_args
+ PVar
+ (:abstraction "..."))
+
+ (def: #export manual
+ (-> Text Code)
+ (|>> :abstraction))
+
+ (def: #export code
+ (-> (Code Any) Text)
+ (|>> :representation))
+
+ (def: (self_contained code)
+ (-> Text Expression)
+ (:abstraction
+ (format "(" code ")")))
+
+ (def: nested_new_line
+ (format text.new_line text.tab))
+
+ (def: nest
+ (-> Text Text)
+ (|>> (text.replace_all text.new_line ..nested_new_line)
+ (format ..nested_new_line)))
+
+ (def: (_block expression)
+ (-> Text Text)
+ (format "{" (nest expression) text.new_line "}"))
+
+ (def: #export (block expression)
+ (-> Expression Expression)
+ (:abstraction
+ (format "{"
+ (..nest (:representation expression))
+ text.new_line "}")))
+
+ (template [<name> <r>]
+ [(def: #export <name>
+ Expression
+ (:abstraction <r>))]
+
+ [null "NULL"]
+ [n/a "NA"]
+ )
+
+ (template [<name>]
+ [(def: #export <name> Expression n/a)]
+
+ [not_available]
+ [not_applicable]
+ [no_answer]
+ )
+
+ (def: #export bool
+ (-> Bit Expression)
+ (|>> (case> #0 "FALSE"
+ #1 "TRUE")
+ :abstraction))
+
+ (def: #export int
+ (-> Int Expression)
+ (|>> %.int :abstraction))
+
+ (def: #export float
+ (-> Frac Expression)
+ (|>> (cond> [(f.= f.positive_infinity)]
+ [(new> "1.0/0.0" [])]
+
+ [(f.= f.negative_infinity)]
+ [(new> "-1.0/0.0" [])]
+
+ [(f.= f.not_a_number)]
+ [(new> "0.0/0.0" [])]
+
+ ## else
+ [%.frac])
+ ..self_contained))
+
+ (def: sanitize
+ (-> Text Text)
+ (`` (|>> (~~ (template [<find> <replace>]
+ [(text.replace_all <find> <replace>)]
+
+ ["\" "\\"]
+ ["|" "\|"]
+ [text.alarm "\a"]
+ [text.back_space "\b"]
+ [text.tab "\t"]
+ [text.new_line "\n"]
+ [text.carriage_return "\r"]
+ [text.double_quote (format "\" text.double_quote)]
+ ))
+ )))
+
+ (def: #export string
+ (-> Text Expression)
+ (|>> ..sanitize %.text :abstraction))
+
+ (def: #export (slice from to list)
+ (-> Expression Expression Expression Expression)
+ (..self_contained
+ (format (:representation list)
+ "[" (:representation from) ":" (:representation to) "]")))
+
+ (def: #export (slice_from from list)
+ (-> Expression Expression Expression)
+ (..self_contained
+ (format (:representation list)
+ "[-1" ":-" (:representation from) "]")))
+
+ (def: #export (apply args func)
+ (-> (List Expression) Expression Expression)
+ (let [func (:representation func)
+ spacing (|> " " (list.repeat (text.size func)) (text.join_with ""))]
+ (:abstraction
+ (format func "("
+ (|> args
+ (list\map ..code)
+ (text.join_with (format "," text.new_line))
+ ..nest)
+ ")"))))
+
+ (template [<name> <function>]
+ [(def: #export (<name> members)
+ (-> (List Expression) Expression)
+ (..apply members (..var <function>)))]
+
+ [vector "c"]
+ [list "list"]
+ )
+
+ (def: #export named_list
+ (-> (List [Text Expression]) Expression)
+ (|>> (list\map (.function (_ [key value])
+ (:abstraction (format key "=" (:representation value)))))
+ ..list))
+
+ (def: #export (apply_kw args kw_args func)
+ (-> (List Expression) (List [Text Expression]) Expression Expression)
+ (..self_contained
+ (format (:representation func)
+ (format "("
+ (text.join_with "," (list\map ..code args)) ","
+ (text.join_with "," (list\map (.function (_ [key val])
+ (format key "=" (:representation val)))
+ kw_args))
+ ")"))))
+
+ (syntax: (arity_inputs {arity <code>.nat})
+ (wrap (case arity
+ 0 (.list)
+ _ (|> arity
+ list.indices
+ (list\map (|>> %.nat code.local_identifier))))))
+
+ (syntax: (arity_types {arity <code>.nat})
+ (wrap (list.repeat arity (` ..Expression))))
+
+ (template [<arity> <function>+]
+ [(with_expansions [<apply> (template.identifier ["apply/" <arity>])
+ <inputs> (arity_inputs <arity>)
+ <types> (arity_types <arity>)
+ <definitions> (template.splice <function>+)]
+ (def: #export (<apply> function [<inputs>])
+ (-> Expression [<types>] Expression)
+ (..apply (.list <inputs>) function))
+
+ (template [<function>]
+ [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>]))
+ (-> [<types>] Expression)
+ (<apply> (..var <function>))))]
+
+ <definitions>))]
+
+ [0
+ [["commandArgs"]]]
+ [1
+ [["intToUtf8"]]]
+ [2
+ [["paste"]]]
+ )
+
+ (def: #export as::integer
+ (-> Expression Expression)
+ (..apply/1 (..var "as.integer")))
+
+ (def: #export (nth idx list)
+ (-> Expression Expression Expression)
+ (..self_contained
+ (format (:representation list) "[[" (:representation idx) "]]")))
+
+ (def: #export (if test then else)
+ (-> Expression Expression Expression Expression)
+ (:abstraction
+ (format "if(" (:representation test) ")"
+ " " (.._block (:representation then))
+ " else " (.._block (:representation else)))))
+
+ (def: #export (when test then)
+ (-> Expression Expression Expression)
+ (:abstraction
+ (format "if(" (:representation test) ") {"
+ (.._block (:representation then))
+ text.new_line "}")))
+
+ (def: #export (cond clauses else)
+ (-> (List [Expression Expression]) Expression Expression)
+ (list\fold (.function (_ [test then] next)
+ (if test then next))
+ else
+ (list.reverse clauses)))
+
+ (template [<name> <op>]
+ [(def: #export (<name> param subject)
+ (-> Expression Expression Expression)
+ (..self_contained
+ (format (:representation subject)
+ " " <op> " "
+ (:representation param))))]
+
+ [= "=="]
+ [< "<"]
+ [<= "<="]
+ [> ">"]
+ [>= ">="]
+ [+ "+"]
+ [- "-"]
+ [* "*"]
+ [/ "/"]
+ [%% "%%"]
+ [** "**"]
+ [or "||"]
+ [and "&&"]
+ )
+
+ (template [<name> <func>]
+ [(def: #export (<name> param subject)
+ (-> Expression Expression Expression)
+ (..apply (.list subject param) (..var <func>)))]
+
+ [bit_or "bitwOr"]
+ [bit_and "bitwAnd"]
+ [bit_xor "bitwXor"]
+ [bit_shl "bitwShiftL"]
+ [bit_ushr "bitwShiftR"]
+ )
+
+ (def: #export (bit_not subject)
+ (-> Expression Expression)
+ (..apply (.list subject) (..var "bitwNot")))
+
+ (template [<name> <op>]
+ [(def: #export <name>
+ (-> Expression Expression)
+ (|>> :representation (format <op>) ..self_contained))]
+
+ [not "!"]
+ [negate "-"]
+ )
+
+ (def: #export (length list)
+ (-> Expression Expression)
+ (..apply (.list list) (..var "length")))
+
+ (def: #export (range from to)
+ (-> Expression Expression Expression)
+ (..self_contained
+ (format (:representation from) ":" (:representation to))))
+
+ (def: #export (function inputs body)
+ (-> (List (Ex [k] (Var k))) Expression Expression)
+ (let [args (|> inputs (list\map ..code) (text.join_with ", "))]
+ (..self_contained
+ (format "function(" args ") "
+ (.._block (:representation body))))))
+
+ (def: #export (try body warning error finally)
+ (-> Expression (Maybe Expression) (Maybe Expression) (Maybe Expression) Expression)
+ (let [optional (: (-> Text (Maybe Expression) (-> Text Text) Text)
+ (.function (_ parameter value preparation)
+ (|> value
+ (maybe\map (|>> :representation preparation (format ", " parameter " = ")))
+ (maybe.default ""))))]
+ (..self_contained
+ (format "tryCatch("
+ (.._block (:representation body))
+ (optional "warning" warning function.identity)
+ (optional "error" error function.identity)
+ (optional "finally" finally .._block)
+ ")"))))
+
+ (def: #export (while test body)
+ (-> Expression Expression Expression)
+ (..self_contained
+ (format "while (" (:representation test) ") "
+ (.._block (:representation body)))))
+
+ (def: #export (for_in var inputs body)
+ (-> SVar Expression Expression Expression)
+ (..self_contained
+ (format "for (" (:representation var) " in " (:representation inputs) ")"
+ (.._block (:representation body)))))
+
+ (template [<name> <keyword>]
+ [(def: #export (<name> message)
+ (-> Expression Expression)
+ (..apply (.list message) (..var <keyword>)))]
+
+ [stop "stop"]
+ [print "print"]
+ )
+
+ (def: #export (set! var value)
+ (-> SVar Expression Expression)
+ (..self_contained
+ (format (:representation var) " <- " (:representation value))))
+
+ (def: #export (set_nth! idx value list)
+ (-> Expression Expression SVar Expression)
+ (..self_contained
+ (format (:representation list) "[[" (:representation idx) "]] <- " (:representation value))))
+
+ (def: #export (then pre post)
+ (-> Expression Expression Expression)
+ (:abstraction
+ (format (:representation pre)
+ text.new_line
+ (:representation post))))
+ )
diff --git a/stdlib/source/library/lux/target/ruby.lux b/stdlib/source/library/lux/target/ruby.lux
new file mode 100644
index 000000000..3eb4f07b9
--- /dev/null
+++ b/stdlib/source/library/lux/target/ruby.lux
@@ -0,0 +1,473 @@
+(.module:
+ [library
+ [lux (#- Location Code static int if cond function or and not comment)
+ ["@" target]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]
+ ["." enum]]
+ [control
+ [pipe (#+ case> cond> new>)]
+ [parser
+ ["<.>" code]]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." template]
+ ["." code]]
+ [math
+ [number
+ ["n" nat]
+ ["f" frac]]]
+ [type
+ abstract]]])
+
+(def: input_separator ", ")
+(def: statement_suffix ";")
+
+(def: nest
+ (-> Text Text)
+ (.let [nested_new_line (format text.new_line text.tab)]
+ (|>> (format text.new_line)
+ (text.replace_all text.new_line nested_new_line))))
+
+(abstract: #export (Code brand)
+ Text
+
+ (implementation: #export code_equivalence
+ (All [brand] (Equivalence (Code brand)))
+
+ (def: (= reference subject)
+ (\ text.equivalence = (:representation reference) (:representation subject))))
+
+ (implementation: #export code_hash
+ (All [brand] (Hash (Code brand)))
+
+ (def: &equivalence ..code_equivalence)
+ (def: hash (|>> :representation (\ text.hash hash))))
+
+ (def: #export manual
+ (-> Text Code)
+ (|>> :abstraction))
+
+ (def: #export code
+ (-> (Code Any) Text)
+ (|>> :representation))
+
+ (template [<type> <super>+]
+ [(with_expansions [<brand> (template.identifier [<type> "'"])]
+ (abstract: (<brand> brand) Any)
+ (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))]
+
+ [Expression [Code]]
+ [Computation [Expression' Code]]
+ [Location [Computation' Expression' Code]]
+ [Var [Location' Computation' Expression' Code]]
+ [LVar [Var' Location' Computation' Expression' Code]]
+ [Statement [Code]]
+ )
+
+ (template [<type> <super>+]
+ [(with_expansions [<brand> (template.identifier [<type> "'"])]
+ (abstract: #export <brand> Any)
+ (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))]
+
+ [Literal [Computation' Expression' Code]]
+ [Access [Location' Computation' Expression' Code]]
+ [GVar [Var' Location' Computation' Expression' Code]]
+ [IVar [Var' Location' Computation' Expression' Code]]
+ [SVar [Var' Location' Computation' Expression' Code]]
+ [LVar* [LVar' Var' Location' Computation' Expression' Code]]
+ [LVar** [LVar' Var' Location' Computation' Expression' Code]]
+ )
+
+ (template [<var> <prefix> <constructor>]
+ [(def: #export <constructor>
+ (-> Text <var>)
+ (|>> (format <prefix>) :abstraction))]
+
+ [GVar "$" global]
+ [IVar "@" instance]
+ [SVar "@@" static]
+ )
+
+ (def: #export local
+ (-> Text LVar)
+ (|>> :abstraction))
+
+ (template [<var> <prefix> <modifier> <unpacker>]
+ [(template [<name> <input> <output>]
+ [(def: #export <name>
+ (-> <input> <output>)
+ (|>> :representation (format <prefix>) :abstraction))]
+
+ [<modifier> LVar <var>]
+ [<unpacker> Expression Computation]
+ )]
+
+ [LVar* "*" variadic splat]
+ [LVar** "**" variadic_kv double_splat]
+ )
+
+ (template [<ruby_name> <lux_name>]
+ [(def: #export <lux_name>
+ (..global <ruby_name>))]
+
+ ["@" latest_error]
+ ["_" last_string_read]
+ ["." last_line_number_read]
+ ["&" last_string_matched]
+ ["~" last_regexp_match]
+ ["=" case_insensitivity_flag]
+ ["/" input_record_separator]
+ ["\" output_record_separator]
+ ["0" script_name]
+ ["$" process_id]
+ ["?" exit_status]
+ )
+
+ (template [<ruby_name> <lux_name>]
+ [(def: #export <lux_name>
+ (..local <ruby_name>))]
+
+ ["ARGV" command_line_arguments]
+ )
+
+ (def: #export nil
+ Literal
+ (:abstraction "nil"))
+
+ (def: #export bool
+ (-> Bit Literal)
+ (|>> (case> #0 "false"
+ #1 "true")
+ :abstraction))
+
+ (def: sanitize
+ (-> Text Text)
+ (`` (|>> (~~ (template [<find> <replace>]
+ [(text.replace_all <find> <replace>)]
+
+ ["\" "\\"]
+ [text.tab "\t"]
+ [text.vertical_tab "\v"]
+ [text.null "\0"]
+ [text.back_space "\b"]
+ [text.form_feed "\f"]
+ [text.new_line "\n"]
+ [text.carriage_return "\r"]
+ [text.double_quote (format "\" text.double_quote)]
+ ))
+ )))
+
+ (template [<format> <name> <type> <prep>]
+ [(def: #export <name>
+ (-> <type> Literal)
+ (|>> <prep> <format> :abstraction))]
+
+ [%.int int Int (<|)]
+ [%.text string Text ..sanitize]
+ [(<|) symbol Text (format ":")]
+ )
+
+ (def: #export float
+ (-> Frac Literal)
+ (|>> (cond> [(f.= f.positive_infinity)]
+ [(new> "(+1.0/0.0)" [])]
+
+ [(f.= f.negative_infinity)]
+ [(new> "(-1.0/0.0)" [])]
+
+ [(f.= f.not_a_number)]
+ [(new> "(+0.0/-0.0)" [])]
+
+ ## else
+ [%.frac])
+ :abstraction))
+
+ (def: #export (array_range from to array)
+ (-> Expression Expression Expression Computation)
+ (|> (format (:representation from) ".." (:representation to))
+ (text.enclose ["[" "]"])
+ (format (:representation array))
+ :abstraction))
+
+ (def: #export array
+ (-> (List Expression) Literal)
+ (|>> (list\map (|>> :representation))
+ (text.join_with ..input_separator)
+ (text.enclose ["[" "]"])
+ :abstraction))
+
+ (def: #export hash
+ (-> (List [Expression Expression]) Literal)
+ (|>> (list\map (.function (_ [k v])
+ (format (:representation k) " => " (:representation v))))
+ (text.join_with ..input_separator)
+ (text.enclose ["{" "}"])
+ :abstraction))
+
+ (def: #export (apply/* args func)
+ (-> (List Expression) Expression Computation)
+ (|> args
+ (list\map (|>> :representation))
+ (text.join_with ..input_separator)
+ (text.enclose ["(" ")"])
+ (format (:representation func))
+ :abstraction))
+
+ (def: #export (apply_lambda/* args lambda)
+ (-> (List Expression) Expression Computation)
+ (|> args
+ (list\map (|>> :representation))
+ (text.join_with ..input_separator)
+ (text.enclose ["[" "]"])
+ (format (:representation lambda))
+ :abstraction))
+
+ (def: #export (the field object)
+ (-> Text Expression Access)
+ (:abstraction (format (:representation object) "." field)))
+
+ (def: #export (nth idx array)
+ (-> Expression Expression Access)
+ (|> (:representation idx)
+ (text.enclose ["[" "]"])
+ (format (:representation array))
+ :abstraction))
+
+ (def: #export (? test then else)
+ (-> Expression Expression Expression Computation)
+ (|> (format (:representation test) " ? "
+ (:representation then) " : "
+ (:representation else))
+ (text.enclose ["(" ")"])
+ :abstraction))
+
+ (def: #export statement
+ (-> Expression Statement)
+ (|>> :representation
+ (text.suffix ..statement_suffix)
+ :abstraction))
+
+ (def: #export (then pre! post!)
+ (-> Statement Statement Statement)
+ (:abstraction
+ (format (:representation pre!)
+ text.new_line
+ (:representation post!))))
+
+ (def: #export (set vars value)
+ (-> (List Location) Expression Statement)
+ (:abstraction
+ (format (|> vars
+ (list\map (|>> :representation))
+ (text.join_with ..input_separator))
+ " = " (:representation value) ..statement_suffix)))
+
+ (def: (block content)
+ (-> Text Text)
+ (format content
+ text.new_line "end" ..statement_suffix))
+
+ (def: #export (if test then! else!)
+ (-> Expression Statement Statement Statement)
+ (<| :abstraction
+ ..block
+ (format "if " (:representation test)
+ (..nest (:representation then!))
+ text.new_line "else"
+ (..nest (:representation else!)))))
+
+ (template [<name> <block>]
+ [(def: #export (<name> test then!)
+ (-> Expression Statement Statement)
+ (<| :abstraction
+ ..block
+ (format <block> " " (:representation test)
+ (..nest (:representation then!)))))]
+
+ [when "if"]
+ [while "while"]
+ )
+
+ (def: #export (for_in var array iteration!)
+ (-> LVar Expression Statement Statement)
+ (<| :abstraction
+ ..block
+ (format "for " (:representation var)
+ " in " (:representation array)
+ " do "
+ (..nest (:representation iteration!)))))
+
+ (type: #export Rescue
+ {#classes (List Text)
+ #exception LVar
+ #rescue Statement})
+
+ (def: #export (begin body! rescues)
+ (-> Statement (List Rescue) Statement)
+ (<| :abstraction
+ ..block
+ (format "begin" (..nest (:representation body!))
+ (|> rescues
+ (list\map (.function (_ [classes exception rescue])
+ (format text.new_line "rescue " (text.join_with ..input_separator classes)
+ " => " (:representation exception)
+ (..nest (:representation rescue)))))
+ (text.join_with text.new_line)))))
+
+ (def: #export (catch expectation body!)
+ (-> Expression Statement Statement)
+ (<| :abstraction
+ ..block
+ (format "catch(" (:representation expectation) ") do"
+ (..nest (:representation body!)))))
+
+ (def: #export (return value)
+ (-> Expression Statement)
+ (:abstraction (format "return " (:representation value) ..statement_suffix)))
+
+ (def: #export (raise message)
+ (-> Expression Computation)
+ (:abstraction (format "raise " (:representation message))))
+
+ (template [<name> <keyword>]
+ [(def: #export <name>
+ Statement
+ (|> <keyword>
+ (text.suffix ..statement_suffix)
+ :abstraction))]
+
+ [next "next"]
+ [redo "redo"]
+ [break "break"]
+ )
+
+ (def: #export (function name args body!)
+ (-> LVar (List LVar) Statement Statement)
+ (<| :abstraction
+ ..block
+ (format "def " (:representation name)
+ (|> args
+ (list\map (|>> :representation))
+ (text.join_with ..input_separator)
+ (text.enclose ["(" ")"]))
+ (..nest (:representation body!)))))
+
+ (def: #export (lambda name args body!)
+ (-> (Maybe LVar) (List Var) Statement Literal)
+ (let [proc (|> (format (|> args
+ (list\map (|>> :representation))
+ (text.join_with ..input_separator)
+ (text.enclose' "|"))
+ (..nest (:representation body!)))
+ (text.enclose ["{" "}"])
+ (format "lambda "))]
+ (|> (case name
+ #.None
+ proc
+
+ (#.Some name)
+ (format (:representation name) " = " proc))
+ (text.enclose ["(" ")"])
+ :abstraction)))
+
+ (template [<op> <name>]
+ [(def: #export (<name> parameter subject)
+ (-> Expression Expression Computation)
+ (:abstraction (format "(" (:representation subject) " " <op> " " (:representation parameter) ")")))]
+
+ ["==" =]
+ [ "<" <]
+ ["<=" <=]
+ [ ">" >]
+ [">=" >=]
+
+ [ "+" +]
+ [ "-" -]
+ [ "*" *]
+ [ "/" /]
+ [ "%" %]
+ ["**" pow]
+
+ ["||" or]
+ ["&&" and]
+ [ "|" bit_or]
+ [ "&" bit_and]
+ [ "^" bit_xor]
+
+ ["<<" bit_shl]
+ [">>" bit_shr]
+ )
+
+ (template [<unary> <name>]
+ [(def: #export (<name> subject)
+ (-> Expression Computation)
+ (:abstraction (format "(" <unary> (:representation subject) ")")))]
+
+ ["!" not]
+ ["-" negate]
+ )
+
+ (def: #export (comment commentary on)
+ (All [brand] (-> Text (Code brand) (Code brand)))
+ (:abstraction (format "# " (..sanitize commentary) text.new_line
+ (:representation on))))
+ )
+
+(def: #export (do method args object)
+ (-> Text (List Expression) Expression Computation)
+ (|> object (..the method) (..apply/* args)))
+
+(def: #export (cond clauses else!)
+ (-> (List [Expression Statement]) Statement Statement)
+ (list\fold (.function (_ [test then!] next!)
+ (..if test then! next!))
+ else!
+ (list.reverse clauses)))
+
+(syntax: (arity_inputs {arity <code>.nat})
+ (wrap (case arity
+ 0 (.list)
+ _ (|> (dec arity)
+ (enum.range n.enum 0)
+ (list\map (|>> %.nat code.local_identifier))))))
+
+(syntax: (arity_types {arity <code>.nat})
+ (wrap (list.repeat arity (` ..Expression))))
+
+(template [<arity> <function>+]
+ [(with_expansions [<apply> (template.identifier ["apply/" <arity>])
+ <inputs> (arity_inputs <arity>)
+ <types> (arity_types <arity>)
+ <definitions> (template.splice <function>+)]
+ (def: #export (<apply> function <inputs>)
+ (-> Expression <types> Computation)
+ (..apply/* (.list <inputs>) function))
+
+ (template [<function>]
+ [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>]))
+ (<apply> (..local <function>))))]
+
+ <definitions>))]
+
+ [1
+ [["print"]
+ ["require"]]]
+
+ [2
+ [["print"]]]
+
+ [3
+ [["print"]]]
+ )
+
+(def: #export throw/1
+ (-> Expression Statement)
+ (|>> (..apply/1 (..local "throw"))
+ ..statement))
diff --git a/stdlib/source/library/lux/target/scheme.lux b/stdlib/source/library/lux/target/scheme.lux
new file mode 100644
index 000000000..8e1308e04
--- /dev/null
+++ b/stdlib/source/library/lux/target/scheme.lux
@@ -0,0 +1,380 @@
+(.module:
+ [library
+ [lux (#- Code int or and if cond let)
+ ["@" target]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]]
+ [control
+ [pipe (#+ new> cond> case>)]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold monoid)]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["n" nat]
+ ["f" frac]]]
+ [type
+ abstract]]])
+
+(def: nest
+ (-> Text Text)
+ (.let [nested_new_line (format text.new_line text.tab)]
+ (text.replace_all text.new_line nested_new_line)))
+
+(abstract: #export (Code k)
+ Text
+
+ (implementation: #export equivalence
+ (All [brand] (Equivalence (Code brand)))
+
+ (def: (= reference subject)
+ (\ text.equivalence = (:representation reference) (:representation subject))))
+
+ (implementation: #export hash
+ (All [brand] (Hash (Code brand)))
+
+ (def: &equivalence ..equivalence)
+ (def: hash (|>> :representation (\ text.hash hash))))
+
+ (template [<type> <brand> <super>+]
+ [(abstract: #export (<brand> brand) Any)
+ (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+)))))]
+
+ [Expression Expression' [Code]]
+ )
+
+ (template [<type> <brand> <super>+]
+ [(abstract: #export <brand> Any)
+ (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+)))))]
+
+ [Var Var' [Expression' Code]]
+ [Computation Computation' [Expression' Code]]
+ )
+
+ (type: #export Arguments
+ {#mandatory (List Var)
+ #rest (Maybe Var)})
+
+ (def: #export manual
+ (-> Text Code)
+ (|>> :abstraction))
+
+ (def: #export code
+ (-> (Code Any) Text)
+ (|>> :representation))
+
+ (def: #export var
+ (-> Text Var)
+ (|>> :abstraction))
+
+ (def: (arguments [mandatory rest])
+ (-> Arguments (Code Any))
+ (case rest
+ (#.Some rest)
+ (case mandatory
+ #.Nil
+ rest
+
+ _
+ (|> (format " . " (:representation rest))
+ (format (|> mandatory
+ (list\map ..code)
+ (text.join_with " ")))
+ (text.enclose ["(" ")"])
+ :abstraction))
+
+ #.None
+ (|> mandatory
+ (list\map ..code)
+ (text.join_with " ")
+ (text.enclose ["(" ")"])
+ :abstraction)))
+
+ (def: #export nil
+ Computation
+ (:abstraction "'()"))
+
+ (def: #export bool
+ (-> Bit Computation)
+ (|>> (case> #0 "#f"
+ #1 "#t")
+ :abstraction))
+
+ (def: #export int
+ (-> Int Computation)
+ (|>> %.int :abstraction))
+
+ (def: #export float
+ (-> Frac Computation)
+ (|>> (cond> [(f.= f.positive_infinity)]
+ [(new> "+inf.0" [])]
+
+ [(f.= f.negative_infinity)]
+ [(new> "-inf.0" [])]
+
+ [f.not_a_number?]
+ [(new> "+nan.0" [])]
+
+ ## else
+ [%.frac])
+ :abstraction))
+
+ (def: #export positive_infinity Computation (..float f.positive_infinity))
+ (def: #export negative_infinity Computation (..float f.negative_infinity))
+ (def: #export not_a_number Computation (..float f.not_a_number))
+
+ (def: sanitize
+ (-> Text Text)
+ (`` (|>> (~~ (template [<find> <replace>]
+ [(text.replace_all <find> <replace>)]
+
+ ["\" "\\"]
+ ["|" "\|"]
+ [text.alarm "\a"]
+ [text.back_space "\b"]
+ [text.tab "\t"]
+ [text.new_line "\n"]
+ [text.carriage_return "\r"]
+ [text.double_quote (format "\" text.double_quote)]
+ ))
+ )))
+
+ (def: #export string
+ (-> Text Computation)
+ (|>> ..sanitize %.text :abstraction))
+
+ (def: #export symbol
+ (-> Text Computation)
+ (|>> (format "'") :abstraction))
+
+ (def: form
+ (-> (List (Code Any)) Code)
+ (.let [nested_new_line (format text.new_line text.tab)]
+ (|>> (case> #.Nil
+ (:abstraction "()")
+
+ (#.Cons head tail)
+ (|> tail
+ (list\map (|>> :representation nest))
+ (#.Cons (:representation head))
+ (text.join_with nested_new_line)
+ (text.enclose ["(" ")"])
+ :abstraction)))))
+
+ (def: #export (apply/* args func)
+ (-> (List Expression) Expression Computation)
+ (..form (#.Cons func args)))
+
+ (template [<name> <function>]
+ [(def: #export (<name> members)
+ (-> (List Expression) Computation)
+ (..apply/* members (..var <function>)))]
+
+ [vector/* "vector"]
+ [list/* "list"]
+ )
+
+ (def: #export apply/0
+ (-> Expression Computation)
+ (..apply/* (list)))
+
+ (template [<lux_name> <scheme_name>]
+ [(def: #export <lux_name>
+ (apply/0 (..var <scheme_name>)))]
+
+ [newline/0 "newline"]
+ )
+
+ (template [<apply> <arg>+ <type>+ <function>+]
+ [(`` (def: #export (<apply> procedure)
+ (-> Expression (~~ (template.splice <type>+)) Computation)
+ (function (_ (~~ (template.splice <arg>+)))
+ (..apply/* (list (~~ (template.splice <arg>+))) procedure))))
+
+ (`` (template [<definition> <function>]
+ [(def: #export <definition> (<apply> (..var <function>)))]
+
+ (~~ (template.splice <function>+))))]
+
+ [apply/1 [_0] [Expression]
+ [[exact/1 "exact"]
+ [integer->char/1 "integer->char"]
+ [char->integer/1 "char->integer"]
+ [number->string/1 "number->string"]
+ [string->number/1 "string->number"]
+ [floor/1 "floor"]
+ [truncate/1 "truncate"]
+ [string/1 "string"]
+ [string?/1 "string?"]
+ [length/1 "length"]
+ [values/1 "values"]
+ [null?/1 "null?"]
+ [car/1 "car"]
+ [cdr/1 "cdr"]
+ [raise/1 "raise"]
+ [error-object-message/1 "error-object-message"]
+ [make-vector/1 "make-vector"]
+ [vector-length/1 "vector-length"]
+ [not/1 "not"]
+ [string-hash/1 "string-hash"]
+ [reverse/1 "reverse"]
+ [display/1 "display"]
+ [exit/1 "exit"]
+ [string-length/1 "string-length"]
+ [load-relative/1 "load-relative"]]]
+
+ [apply/2 [_0 _1] [Expression Expression]
+ [[append/2 "append"]
+ [cons/2 "cons"]
+ [make-vector/2 "make-vector"]
+ ## [vector-ref/2 "vector-ref"]
+ [list-tail/2 "list-tail"]
+ [map/2 "map"]
+ [string-ref/2 "string-ref"]
+ [string-append/2 "string-append"]
+ [make-string/2 "make-string"]]]
+
+ [apply/3 [_0 _1 _2] [Expression Expression Expression]
+ [[substring/3 "substring"]
+ [vector-set!/3 "vector-set!"]
+ [string-contains/3 "string-contains"]]]
+
+ [apply/5 [_0 _1 _2 _3 _4] [Expression Expression Expression Expression Expression]
+ [[vector-copy!/5 "vector-copy!"]]]
+ )
+
+ ## TODO: define "vector-ref/2" like a normal apply/2 function.
+ ## "vector-ref/2" as an 'invoke' is problematic, since it only works
+ ## in Kawa.
+ ## However, the way Kawa defines "vector-ref" causes trouble,
+ ## because it does a runtime type-check which throws an error when
+ ## it checks against custom values/objects/classes made for
+ ## JVM<->Scheme interop.
+ ## There are 2 ways to deal with this:
+ ## 0. To fork Kawa, and get rid of the type-check so the normal
+ ## "vector-ref" can be used instead.
+ ## 1. To carry on, and then, when it's time to compile the compiler
+ ## itself into Scheme, switch from 'invoke' to normal 'vector-ref'.
+ ## Either way, the 'invoke' needs to go away.
+ (def: #export (vector-ref/2 vector index)
+ (-> Expression Expression Computation)
+ (..form (list (..var "invoke") vector (..symbol "getRaw") index)))
+
+ (template [<lux_name> <scheme_name>]
+ [(def: #export (<lux_name> param subject)
+ (-> Expression Expression Computation)
+ (..apply/2 (..var <scheme_name>) subject param))]
+
+ [=/2 "="]
+ [eq?/2 "eq?"]
+ [eqv?/2 "eqv?"]
+ [</2 "<"]
+ [<=/2 "<="]
+ [>/2 ">"]
+ [>=/2 ">="]
+ [string=?/2 "string=?"]
+ [string<?/2 "string<?"]
+ [+/2 "+"]
+ [-/2 "-"]
+ [//2 "/"]
+ [*/2 "*"]
+ [expt/2 "expt"]
+ [remainder/2 "remainder"]
+ [quotient/2 "quotient"]
+ [mod/2 "mod"]
+ [arithmetic-shift/2 "arithmetic-shift"]
+ [bitwise-and/2 "bitwise-and"]
+ [bitwise-ior/2 "bitwise-ior"]
+ [bitwise-xor/2 "bitwise-xor"]
+ )
+
+ (template [<lux_name> <scheme_name>]
+ [(def: #export <lux_name>
+ (-> (List Expression) Computation)
+ (|>> (list& (..var <scheme_name>)) ..form))]
+
+ [or "or"]
+ [and "and"]
+ )
+
+ (template [<lux_name> <scheme_name> <var> <pre>]
+ [(def: #export (<lux_name> bindings body)
+ (-> (List [<var> Expression]) Expression Computation)
+ (..form (list (..var <scheme_name>)
+ (|> bindings
+ (list\map (function (_ [binding/name binding/value])
+ (..form (list (|> binding/name <pre>)
+ binding/value))))
+ ..form)
+ body)))]
+
+ [let "let" Var (<|)]
+ [let* "let*" Var (<|)]
+ [letrec "letrec" Var (<|)]
+ [let_values "let-values" Arguments ..arguments]
+ [let*_values "let*-values" Arguments ..arguments]
+ [letrec_values "letrec-values" Arguments ..arguments]
+ )
+
+ (def: #export (if test then else)
+ (-> Expression Expression Expression Computation)
+ (..form (list (..var "if") test then else)))
+
+ (def: #export (when test then)
+ (-> Expression Expression Computation)
+ (..form (list (..var "when") test then)))
+
+ (def: #export (lambda arguments body)
+ (-> Arguments Expression Computation)
+ (..form (list (..var "lambda")
+ (..arguments arguments)
+ body)))
+
+ (def: #export (define_function name arguments body)
+ (-> Var Arguments Expression Computation)
+ (..form (list (..var "define")
+ (|> arguments
+ (update@ #mandatory (|>> (#.Cons name)))
+ ..arguments)
+ body)))
+
+ (def: #export (define_constant name value)
+ (-> Var Expression Computation)
+ (..form (list (..var "define") name value)))
+
+ (def: #export begin
+ (-> (List Expression) Computation)
+ (|>> (#.Cons (..var "begin")) ..form))
+
+ (def: #export (set! name value)
+ (-> Var Expression Computation)
+ (..form (list (..var "set!") name value)))
+
+ (def: #export (with_exception_handler handler body)
+ (-> Expression Expression Computation)
+ (..form (list (..var "with-exception-handler") handler body)))
+
+ (def: #export (call_with_current_continuation body)
+ (-> Expression Computation)
+ (..form (list (..var "call-with-current-continuation") body)))
+
+ (def: #export (guard variable clauses else body)
+ (-> Var (List [Expression Expression]) (Maybe Expression) Expression Computation)
+ (..form (list (..var "guard")
+ (..form (|> (case else
+ #.None
+ (list)
+
+ (#.Some else)
+ (list (..form (list (..var "else") else))))
+ (list\compose (list\map (function (_ [when then])
+ (..form (list when then)))
+ clauses))
+ (list& variable)))
+ body)))
+ )
diff --git a/stdlib/source/library/lux/test.lux b/stdlib/source/library/lux/test.lux
new file mode 100644
index 000000000..6e28624ce
--- /dev/null
+++ b/stdlib/source/library/lux/test.lux
@@ -0,0 +1,419 @@
+(.module: {#.doc "Tools for unit & property-based/generative testing."}
+ [library
+ [lux (#- and for)
+ ["." meta]
+ ["." debug]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]
+ ["." exception (#+ exception:)]
+ ["." io]
+ [concurrency
+ ["." atom (#+ Atom)]
+ ["." promise (#+ Promise) ("#\." monad)]]
+ ["<>" parser
+ ["<.>" code]]]
+ [data
+ ["." maybe]
+ ["." product]
+ ["." name]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." set (#+ Set)]
+ ["." dictionary #_
+ ["#" ordered (#+ Dictionary)]]]]
+ [time
+ ["." instant]
+ ["." duration (#+ Duration)]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]
+ [number (#+ hex)
+ ["n" nat]
+ ["f" frac]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [world
+ ["." program]]]])
+
+(type: #export Tally
+ {#successes Nat
+ #failures Nat
+ #expected_coverage (Set Name)
+ #actual_coverage (Set Name)})
+
+(def: (add_tally parameter subject)
+ (-> Tally Tally Tally)
+ {#successes (n.+ (get@ #successes parameter) (get@ #successes subject))
+ #failures (n.+ (get@ #failures parameter) (get@ #failures subject))
+ #expected_coverage (set.union (get@ #expected_coverage parameter)
+ (get@ #expected_coverage subject))
+ #actual_coverage (set.union (get@ #actual_coverage parameter)
+ (get@ #actual_coverage subject))})
+
+(def: start
+ Tally
+ {#successes 0
+ #failures 0
+ #expected_coverage (set.new name.hash)
+ #actual_coverage (set.new name.hash)})
+
+(template [<name> <category>]
+ [(def: <name>
+ Tally
+ (update@ <category> .inc ..start))]
+
+ [success #successes]
+ [failure #failures]
+ )
+
+(type: #export Assertion
+ (Promise [Tally Text]))
+
+(type: #export Test
+ (Random Assertion))
+
+(def: separator
+ text.new_line)
+
+(def: #export (and' left right)
+ {#.doc "Sequencing combinator."}
+ (-> Assertion Assertion Assertion)
+ (let [[read! write!] (: [(Promise [Tally Text])
+ (promise.Resolver [Tally Text])]
+ (promise.promise []))
+ _ (|> left
+ (promise.await (function (_ [l_tally l_documentation])
+ (promise.await (function (_ [r_tally r_documentation])
+ (write! [(add_tally l_tally r_tally)
+ (format l_documentation ..separator r_documentation)]))
+ right)))
+ io.run)]
+ read!))
+
+(def: #export (and left right)
+ {#.doc "Sequencing combinator."}
+ (-> Test Test Test)
+ (do {! random.monad}
+ [left left]
+ (\ ! map (..and' left) right)))
+
+(def: context_prefix
+ text.tab)
+
+(def: #export (context description)
+ (-> Text Test Test)
+ (random\map (promise\map (function (_ [tally documentation])
+ [tally (|> documentation
+ (text.split_all_with ..separator)
+ (list\map (|>> (format context_prefix)))
+ (text.join_with ..separator)
+ (format description ..separator))]))))
+
+(def: failure_prefix "[Failure] ")
+(def: success_prefix "[Success] ")
+
+(def: #export fail
+ (-> Text Test)
+ (|>> (format ..failure_prefix)
+ [..failure]
+ promise\wrap
+ random\wrap))
+
+(def: #export (assert message condition)
+ {#.doc "Check that a condition is #1, and fail with the given message otherwise."}
+ (-> Text Bit Assertion)
+ (<| promise\wrap
+ (if condition
+ [..success (format ..success_prefix message)]
+ [..failure (format ..failure_prefix message)])))
+
+(def: #export (test message condition)
+ {#.doc "Check that a condition is #1, and fail with the given message otherwise."}
+ (-> Text Bit Test)
+ (random\wrap (..assert message condition)))
+
+(def: #export (lift message random)
+ (-> Text (Random Bit) Test)
+ (random\map (..assert message) random))
+
+(def: pcg32_magic_inc
+ Nat
+ (hex "FEDCBA9876543210"))
+
+(type: #export Seed
+ {#.doc "The seed value used for random testing (if that feature is used)."}
+ Nat)
+
+(def: #export (seed value test)
+ (-> Seed Test Test)
+ (function (_ prng)
+ (let [[_ result] (random.run (random.pcg32 [..pcg32_magic_inc value])
+ test)]
+ [prng result])))
+
+(def: failed?
+ (-> Tally Bit)
+ (|>> (get@ #failures) (n.> 0)))
+
+(def: (times_failure seed documentation)
+ (-> Seed Text Text)
+ (format documentation ..separator ..separator
+ "Failed with this seed: " (%.nat seed)))
+
+(exception: #export must_try_test_at_least_once)
+
+(def: #export (times amount test)
+ (-> Nat Test Test)
+ (case amount
+ 0 (..fail (exception.construct ..must_try_test_at_least_once []))
+ _ (do random.monad
+ [seed random.nat]
+ (function (recur prng)
+ (let [[prng' instance] (random.run (random.pcg32 [..pcg32_magic_inc seed]) test)]
+ [prng' (do {! promise.monad}
+ [[tally documentation] instance]
+ (if (..failed? tally)
+ (wrap [tally (times_failure seed documentation)])
+ (case amount
+ 1 instance
+ _ (|> test
+ (times (dec amount))
+ (random.run prng')
+ product.right))))])))))
+
+(def: (description duration tally)
+ (-> Duration Tally Text)
+ (let [successes (get@ #successes tally)
+ failures (get@ #failures tally)
+ missing (set.difference (get@ #actual_coverage tally)
+ (get@ #expected_coverage tally))
+ unexpected (set.difference (get@ #expected_coverage tally)
+ (get@ #actual_coverage tally))
+ report (: (-> (Set Name) Text)
+ (|>> set.to_list
+ (list.sort (\ name.order <))
+ (exception.enumerate %.name)))
+ expected_definitions_to_cover (set.size (get@ #expected_coverage tally))
+ unexpected_definitions_covered (set.size unexpected)
+ actual_definitions_covered (n.- unexpected_definitions_covered
+ (set.size (get@ #actual_coverage tally)))
+ coverage (case expected_definitions_to_cover
+ 0 "N/A"
+ expected (let [missing_ratio (f./ (n.frac expected)
+ (n.frac (set.size missing)))
+ max_percent +100.0
+ done_percent (|> +1.0
+ (f.- missing_ratio)
+ (f.* max_percent))]
+ (if (f.= max_percent done_percent)
+ "100%"
+ (let [raw (|> done_percent
+ %.frac
+ (text.replace_once "+" ""))]
+ (|> raw
+ (text.clip 0 (if (f.>= +10.0 done_percent)
+ 5 ## XX.XX
+ 4 ## X.XX
+ ))
+ (maybe.default raw)
+ (text.suffix "%"))))))]
+ (exception.report
+ ["Duration" (%.duration duration)]
+ ["# Tests" (%.nat (n.+ successes failures))]
+ ["# Successes" (%.nat successes)]
+ ["# Failures" (%.nat failures)]
+ ["# Expected definitions to cover" (%.nat expected_definitions_to_cover)]
+ ["# Actual definitions covered" (%.nat actual_definitions_covered)]
+ ["# Pending definitions to cover" (%.nat (n.- actual_definitions_covered
+ expected_definitions_to_cover))]
+ ["# Unexpected definitions covered" (%.nat unexpected_definitions_covered)]
+ ["Coverage" coverage]
+ ["Pending definitions to cover" (report missing)]
+ ["Unexpected definitions covered" (report unexpected)])))
+
+(def: failure_exit_code +1)
+(def: success_exit_code +0)
+
+(def: #export (run! test)
+ (-> Test (Promise Nothing))
+ (do promise.monad
+ [pre (promise.future instant.now)
+ #let [seed (instant.to_millis pre)
+ prng (random.pcg32 [..pcg32_magic_inc seed])]
+ [tally documentation] (|> test (random.run prng) product.right)
+ post (promise.future instant.now)
+ #let [duration (instant.span pre post)
+ _ (debug.log! (format documentation text.new_line text.new_line
+ (..description duration tally)
+ text.new_line))]]
+ (promise.future (\ program.default exit
+ (case (get@ #failures tally)
+ 0 ..success_exit_code
+ _ ..failure_exit_code)))))
+
+(def: (|cover'| coverage condition)
+ (-> (List Name) Bit Assertion)
+ (let [message (|> coverage
+ (list\map %.name)
+ (text.join_with " & "))
+ coverage (set.from_list name.hash coverage)]
+ (|> (..assert message condition)
+ (promise\map (function (_ [tally documentation])
+ [(update@ #actual_coverage (set.union coverage) tally)
+ documentation])))))
+
+(def: (|cover| coverage condition)
+ (-> (List Name) Bit Test)
+ (|> (..|cover'| coverage condition)
+ random\wrap))
+
+(def: (|for| coverage test)
+ (-> (List Name) Test Test)
+ (let [context (|> coverage
+ (list\map %.name)
+ (text.join_with " & "))
+ coverage (set.from_list name.hash coverage)]
+ (random\map (promise\map (function (_ [tally documentation])
+ [(update@ #actual_coverage (set.union coverage) tally)
+ documentation]))
+ (..context context test))))
+
+(def: (name_code name)
+ (-> Name Code)
+ (code.tuple (list (code.text (name.module name))
+ (code.text (name.short name)))))
+
+(syntax: (reference {name <code>.identifier})
+ (do meta.monad
+ [_ (meta.find_export name)]
+ (wrap (list (name_code name)))))
+
+(def: coverage_separator
+ Text
+ (text.from_code 31))
+
+(def: encode_coverage
+ (-> (List Text) Text)
+ (list\fold (function (_ short aggregate)
+ (case aggregate
+ "" short
+ _ (format aggregate ..coverage_separator short)))
+ ""))
+
+(def: (decode_coverage module encoding)
+ (-> Text Text (Set Name))
+ (loop [remaining encoding
+ output (set.from_list name.hash (list))]
+ (case (text.split_with ..coverage_separator remaining)
+ (#.Some [head tail])
+ (recur tail (set.add [module head] output))
+
+ #.None
+ (set.add [module remaining] output))))
+
+(template [<macro> <function>]
+ [(syntax: #export (<macro> {coverage (<code>.tuple (<>.many <code>.any))}
+ condition)
+ (let [coverage (list\map (function (_ definition)
+ (` ((~! ..reference) (~ definition))))
+ coverage)]
+ (wrap (list (` ((~! <function>)
+ (: (.List .Name)
+ (.list (~+ coverage)))
+ (~ condition)))))))]
+
+ [cover' ..|cover'|]
+ [cover ..|cover|]
+ )
+
+(syntax: #export (for {coverage (<code>.tuple (<>.many <code>.any))}
+ test)
+ (let [coverage (list\map (function (_ definition)
+ (` ((~! ..reference) (~ definition))))
+ coverage)]
+ (wrap (list (` ((~! ..|for|)
+ (: (.List .Name)
+ (.list (~+ coverage)))
+ (~ test)))))))
+
+(def: (covering' module coverage test)
+ (-> Text Text Test Test)
+ (let [coverage (..decode_coverage module coverage)]
+ (|> (..context module test)
+ (random\map (promise\map (function (_ [tally documentation])
+ [(update@ #expected_coverage (set.union coverage) tally)
+ documentation]))))))
+
+(syntax: #export (covering {module <code>.identifier}
+ test)
+ (do meta.monad
+ [#let [module (name.module module)]
+ definitions (meta.definitions module)
+ #let [coverage (|> definitions
+ (list\fold (function (_ [short [exported? _]] aggregate)
+ (if exported?
+ (#.Cons short aggregate)
+ aggregate))
+ #.Nil)
+ ..encode_coverage)]]
+ (wrap (list (` ((~! ..covering')
+ (~ (code.text module))
+ (~ (code.text coverage))
+ (~ test)))))))
+
+(exception: #export (error_during_execution {error Text})
+ (exception.report
+ ["Error" (%.text error)]))
+
+(def: #export (in_parallel tests)
+ (-> (List Test) Test)
+ (case (list.size tests)
+ 0
+ (random\wrap (promise\wrap [..start ""]))
+
+ expected_tests
+ (do random.monad
+ [seed random.nat
+ #let [prng (random.pcg32 [..pcg32_magic_inc seed])
+ run! (: (-> Test Assertion)
+ (|>> (random.run prng)
+ product.right
+ (function (_ _))
+ "lux try"
+ (case> (#try.Success output)
+ output
+
+ (#try.Failure error)
+ (..assert (exception.construct ..error_during_execution [error]) false))
+ io.io
+ promise.future
+ promise\join))
+ state (: (Atom (Dictionary Nat [Tally Text]))
+ (atom.atom (dictionary.new n.order)))
+ [read! write!] (: [Assertion
+ (promise.Resolver [Tally Text])]
+ (promise.promise []))
+ _ (io.run (monad.map io.monad
+ (function (_ [index test])
+ (promise.await (function (_ assertion)
+ (do io.monad
+ [[_ results] (atom.update (dictionary.put index assertion) state)]
+ (if (n.= expected_tests (dictionary.size results))
+ (let [assertions (|> results
+ dictionary.entries
+ (list\map product.right))]
+ (write! [(|> assertions
+ (list\map product.left)
+ (list\fold ..add_tally ..start))
+ (|> assertions
+ (list\map product.right)
+ (text.join_with ..separator))]))
+ (wrap []))))
+ (run! test)))
+ (list.enumeration tests)))]]
+ (wrap read!))))
diff --git a/stdlib/source/library/lux/time.lux b/stdlib/source/library/lux/time.lux
new file mode 100644
index 000000000..5c043f696
--- /dev/null
+++ b/stdlib/source/library/lux/time.lux
@@ -0,0 +1,217 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]
+ [enum (#+ Enum)]
+ [codec (#+ Codec)]
+ [monad (#+ Monad do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<.>" text (#+ Parser)]]]
+ [data
+ ["." text ("#\." monoid)]]
+ [math
+ [number
+ ["n" nat ("#\." decimal)]]]
+ [type
+ abstract]]]
+ [/
+ ["." duration (#+ Duration)]])
+
+(template [<name> <singular> <plural>]
+ [(def: #export <name>
+ Nat
+ (.nat (duration.query <singular> <plural>)))]
+
+ [milli_seconds duration.milli_second duration.second]
+ [seconds duration.second duration.minute]
+ [minutes duration.minute duration.hour]
+ [hours duration.hour duration.day]
+ )
+
+(def: limit
+ Nat
+ (.nat (duration.to_millis duration.day)))
+
+(exception: #export (time_exceeds_a_day {time Nat})
+ (exception.report
+ ["Time (in milli-seconds)" (n\encode time)]
+ ["Maximum (in milli-seconds)" (n\encode (dec limit))]))
+
+(def: separator ":")
+
+(def: parse_section
+ (Parser Nat)
+ (<>.codec n.decimal (<text>.exactly 2 <text>.decimal)))
+
+(def: parse_millis
+ (Parser Nat)
+ (<>.either (|> (<text>.at_most 3 <text>.decimal)
+ (<>.codec n.decimal)
+ (<>.after (<text>.this ".")))
+ (\ <>.monad wrap 0)))
+
+(template [<maximum> <parser> <exception> <sub_parser>]
+ [(exception: #export (<exception> {value Nat})
+ (exception.report
+ ["Value" (n\encode value)]
+ ["Minimum" (n\encode 0)]
+ ["Maximum" (n\encode (dec <maximum>))]))
+
+ (def: <parser>
+ (Parser Nat)
+ (do <>.monad
+ [value <sub_parser>]
+ (if (n.< <maximum> value)
+ (wrap value)
+ (<>.lift (exception.throw <exception> [value])))))]
+
+ [..hours parse_hour invalid_hour ..parse_section]
+ [..minutes parse_minute invalid_minute ..parse_section]
+ [..seconds parse_second invalid_second ..parse_section]
+ )
+
+(abstract: #export Time
+ Nat
+
+ {#.doc "Time is defined as milliseconds since the start of the day (00:00:00.000)."}
+
+ (def: #export midnight
+ {#.doc "The instant corresponding to the start of the day: 00:00:00.000"}
+ Time
+ (:abstraction 0))
+
+ (def: #export (from_millis milli_seconds)
+ (-> Nat (Try Time))
+ (if (n.< ..limit milli_seconds)
+ (#try.Success (:abstraction milli_seconds))
+ (exception.throw ..time_exceeds_a_day [milli_seconds])))
+
+ (def: #export to_millis
+ (-> Time Nat)
+ (|>> :representation))
+
+ (implementation: #export equivalence
+ (Equivalence Time)
+
+ (def: (= param subject)
+ (n.= (:representation param) (:representation subject))))
+
+ (implementation: #export order
+ (Order Time)
+
+ (def: &equivalence ..equivalence)
+
+ (def: (< param subject)
+ (n.< (:representation param) (:representation subject))))
+
+ (`` (implementation: #export enum
+ (Enum Time)
+
+ (def: &order ..order)
+
+ (def: succ
+ (|>> :representation inc (n.% ..limit) :abstraction))
+
+ (def: pred
+ (|>> :representation
+ (case> 0 ..limit
+ millis millis)
+ dec
+ :abstraction))))
+
+ (def: #export parser
+ (Parser Time)
+ (let [to_millis (: (-> Duration Nat)
+ (|>> duration.to_millis .nat))
+ hour (to_millis duration.hour)
+ minute (to_millis duration.minute)
+ second (to_millis duration.second)
+ millis (to_millis duration.milli_second)]
+ (do {! <>.monad}
+ [utc_hour ..parse_hour
+ _ (<text>.this ..separator)
+ utc_minute ..parse_minute
+ _ (<text>.this ..separator)
+ utc_second ..parse_second
+ utc_millis ..parse_millis]
+ (wrap (:abstraction
+ ($_ n.+
+ (n.* utc_hour hour)
+ (n.* utc_minute minute)
+ (n.* utc_second second)
+ (n.* utc_millis millis)))))))
+ )
+
+(def: (pad value)
+ (-> Nat Text)
+ (if (n.< 10 value)
+ (text\compose "0" (n\encode value))
+ (n\encode value)))
+
+(def: (adjust_negative space duration)
+ (-> Duration Duration Duration)
+ (if (duration.negative? duration)
+ (duration.merge space duration)
+ duration))
+
+(def: (encode_millis millis)
+ (-> Nat Text)
+ (cond (n.= 0 millis) ""
+ (n.< 10 millis) ($_ text\compose ".00" (n\encode millis))
+ (n.< 100 millis) ($_ text\compose ".0" (n\encode millis))
+ ## (n.< 1,000 millis)
+ ($_ text\compose "." (n\encode millis))))
+
+(type: #export Clock
+ {#hour Nat
+ #minute Nat
+ #second Nat
+ #milli_second Nat})
+
+(def: #export (clock time)
+ (-> Time Clock)
+ (let [time (|> time ..to_millis .int duration.from_millis)
+ [hours time] [(duration.query duration.hour time) (duration.frame duration.hour time)]
+ [minutes time] [(duration.query duration.minute time) (duration.frame duration.minute time)]
+ [seconds millis] [(duration.query duration.second time) (duration.frame duration.second time)]]
+ {#hour (.nat hours)
+ #minute (.nat minutes)
+ #second (.nat seconds)
+ #milli_second (|> millis
+ (..adjust_negative duration.second)
+ duration.to_millis
+ .nat)}))
+
+(def: #export (time clock)
+ (-> Clock (Try Time))
+ (|> ($_ duration.merge
+ (duration.up (get@ #hour clock) duration.hour)
+ (duration.up (get@ #minute clock) duration.minute)
+ (duration.up (get@ #second clock) duration.second)
+ (duration.from_millis (.int (get@ #milli_second clock))))
+ duration.to_millis
+ .nat
+ ..from_millis))
+
+(def: (encode time)
+ (-> Time Text)
+ (let [(^slots [#hour #minute #second #milli_second]) (..clock time)]
+ ($_ text\compose
+ (..pad hour)
+ ..separator (..pad minute)
+ ..separator (..pad second)
+ (..encode_millis milli_second))))
+
+(implementation: #export codec
+ {#.doc (doc "Based on ISO 8601."
+ "For example: 21:14:51.827")}
+ (Codec Text Time)
+
+ (def: encode ..encode)
+ (def: decode (<text>.run ..parser)))
diff --git a/stdlib/source/library/lux/time/date.lux b/stdlib/source/library/lux/time/date.lux
new file mode 100644
index 000000000..e8de6d99e
--- /dev/null
+++ b/stdlib/source/library/lux/time/date.lux
@@ -0,0 +1,349 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]
+ [enum (#+ Enum)]
+ [codec (#+ Codec)]
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<text>" text (#+ Parser)]]]
+ [data
+ ["." maybe]
+ ["." text ("#\." monoid)]
+ [collection
+ ["." list ("#\." fold)]
+ ["." dictionary (#+ Dictionary)]]]
+ [math
+ [number
+ ["n" nat ("#\." decimal)]
+ ["i" int]]]
+ [type
+ abstract]]]
+ ["." // #_
+ ["#." year (#+ Year)]
+ ["#." month (#+ Month)]])
+
+(def: month_by_number
+ (Dictionary Nat Month)
+ (list\fold (function (_ month mapping)
+ (dictionary.put (//month.number month) month mapping))
+ (dictionary.new n.hash)
+ //month.year))
+
+(def: minimum_day
+ 1)
+
+(def: (month_days year month)
+ (-> Year Month Nat)
+ (if (//year.leap? year)
+ (//month.leap_year_days month)
+ (//month.days month)))
+
+(def: (day_is_within_limits? year month day)
+ (-> Year Month Nat Bit)
+ (and (n.>= ..minimum_day day)
+ (n.<= (..month_days year month) day)))
+
+(exception: #export (invalid_day {year Year} {month Month} {day Nat})
+ (exception.report
+ ["Value" (n\encode day)]
+ ["Minimum" (n\encode ..minimum_day)]
+ ["Maximum" (n\encode (..month_days year month))]
+ ["Year" (\ //year.codec encode year)]
+ ["Month" (n\encode (//month.number month))]))
+
+(def: (pad value)
+ (-> Nat Text)
+ (let [digits (n\encode value)]
+ (if (n.< 10 value)
+ (text\compose "0" digits)
+ digits)))
+
+(def: separator
+ "-")
+
+(abstract: #export Date
+ {#year Year
+ #month Month
+ #day Nat}
+
+ (def: #export (date year month day)
+ (-> Year Month Nat (Try Date))
+ (if (..day_is_within_limits? year month day)
+ (#try.Success
+ (:abstraction
+ {#year year
+ #month month
+ #day day}))
+ (exception.throw ..invalid_day [year month day])))
+
+ (def: #export epoch
+ Date
+ (try.assume (..date //year.epoch
+ #//month.January
+ ..minimum_day)))
+
+ (template [<name> <type> <field>]
+ [(def: #export <name>
+ (-> Date <type>)
+ (|>> :representation (get@ <field>)))]
+
+ [year Year #year]
+ [month Month #month]
+ [day_of_month Nat #day]
+ )
+
+ (implementation: #export equivalence
+ (Equivalence Date)
+
+ (def: (= reference sample)
+ (let [reference (:representation reference)
+ sample (:representation sample)]
+ (and (\ //year.equivalence =
+ (get@ #year reference)
+ (get@ #year sample))
+ (\ //month.equivalence =
+ (get@ #month reference)
+ (get@ #month sample))
+ (n.= (get@ #day reference)
+ (get@ #day sample))))))
+
+ (implementation: #export order
+ (Order Date)
+
+ (def: &equivalence ..equivalence)
+
+ (def: (< reference sample)
+ (let [reference (:representation reference)
+ sample (:representation sample)]
+ (or (\ //year.order <
+ (get@ #year reference)
+ (get@ #year sample))
+ (and (\ //year.equivalence =
+ (get@ #year reference)
+ (get@ #year sample))
+ (or (\ //month.order <
+ (get@ #month reference)
+ (get@ #month sample))
+ (and (\ //month.order =
+ (get@ #month reference)
+ (get@ #month sample))
+ (n.< (get@ #day reference)
+ (get@ #day sample)))))))))
+ )
+
+(def: parse_section
+ (Parser Nat)
+ (<>.codec n.decimal (<text>.exactly 2 <text>.decimal)))
+
+(def: parse_millis
+ (Parser Nat)
+ (<>.either (|> (<text>.at_most 3 <text>.decimal)
+ (<>.codec n.decimal)
+ (<>.after (<text>.this ".")))
+ (\ <>.monad wrap 0)))
+
+(template [<minimum> <maximum> <parser> <exception>]
+ [(exception: #export (<exception> {value Nat})
+ (exception.report
+ ["Value" (n\encode value)]
+ ["Minimum" (n\encode <minimum>)]
+ ["Maximum" (n\encode <maximum>)]))
+
+ (def: <parser>
+ (Parser Nat)
+ (do <>.monad
+ [value ..parse_section]
+ (if (and (n.>= <minimum> value)
+ (n.<= <maximum> value))
+ (wrap value)
+ (<>.lift (exception.throw <exception> [value])))))]
+
+ [1 12 parse_month invalid_month]
+ )
+
+(def: #export parser
+ (Parser Date)
+ (do <>.monad
+ [utc_year //year.parser
+ _ (<text>.this ..separator)
+ utc_month ..parse_month
+ _ (<text>.this ..separator)
+ #let [month (maybe.assume (dictionary.get utc_month ..month_by_number))]
+ utc_day ..parse_section]
+ (<>.lift (..date utc_year month utc_day))))
+
+(def: (encode value)
+ (-> Date Text)
+ ($_ text\compose
+ (\ //year.codec encode (..year value))
+ ..separator (..pad (|> value ..month //month.number))
+ ..separator (..pad (..day_of_month value))))
+
+(implementation: #export codec
+ {#.doc (doc "Based on ISO 8601."
+ "For example: 2017-01-15")}
+ (Codec Text Date)
+
+ (def: encode ..encode)
+ (def: decode (<text>.run ..parser)))
+
+(def: days_per_leap
+ (|> //year.days
+ (n.* 4)
+ (n.+ 1)))
+
+(def: days_per_century
+ (let [leaps_per_century (n./ //year.leap
+ //year.century)]
+ (|> //year.century
+ (n.* //year.days)
+ (n.+ leaps_per_century)
+ (n.- 1))))
+
+(def: days_per_era
+ (let [centuries_per_era (n./ //year.century
+ //year.era)]
+ (|> centuries_per_era
+ (n.* ..days_per_century)
+ (n.+ 1))))
+
+(def: days_since_epoch
+ (let [years::70 70
+ leaps::70 (n./ //year.leap
+ years::70)
+ days::70 (|> years::70
+ (n.* //year.days)
+ (n.+ leaps::70))
+ ## The epoch is being calculated from March 1st, instead of January 1st.
+ january_&_february (n.+ (//month.days #//month.January)
+ (//month.days #//month.February))]
+ (|> 0
+ ## 1600/01/01
+ (n.+ (n.* 4 days_per_era))
+ ## 1900/01/01
+ (n.+ (n.* 3 days_per_century))
+ ## 1970/01/01
+ (n.+ days::70)
+ ## 1970/03/01
+ (n.- january_&_february))))
+
+(def: first_month_of_civil_year 3)
+
+(with_expansions [<pull> +3
+ <push> +9]
+ (def: (internal_month civil_month)
+ (-> Nat Int)
+ (if (n.< ..first_month_of_civil_year civil_month)
+ (i.+ <push> (.int civil_month))
+ (i.- <pull> (.int civil_month))))
+
+ (def: (civil_month internal_month)
+ (-> Int Nat)
+ (.nat (if (i.< +10 internal_month)
+ (i.+ <pull> internal_month)
+ (i.- <push> internal_month)))))
+
+(with_expansions [<up> +153
+ <translation> +2
+ <down> +5]
+ (def: day_of_year_from_month
+ (-> Nat Int)
+ (|>> ..internal_month
+ (i.* <up>)
+ (i.+ <translation>)
+ (i./ <down>)))
+
+ (def: month_from_day_of_year
+ (-> Int Nat)
+ (|>> (i.* <down>)
+ (i.+ <translation>)
+ (i./ <up>)
+ ..civil_month)))
+
+(def: last_era_leap_day
+ (.int (dec ..days_per_leap)))
+
+(def: last_era_day
+ (.int (dec ..days_per_era)))
+
+(def: (civil_year utc_month utc_year)
+ (-> Nat Year Int)
+ (let [## Coercing, because the year is already in external form.
+ utc_year (:as Int utc_year)]
+ (if (n.< ..first_month_of_civil_year utc_month)
+ (dec utc_year)
+ utc_year)))
+
+## http://howardhinnant.github.io/date_algorithms.html
+(def: #export (to_days date)
+ (-> Date Int)
+ (let [utc_month (|> date ..month //month.number)
+ civil_year (..civil_year utc_month (..year date))
+ era (|> (if (i.< +0 civil_year)
+ (i.- (.int (dec //year.era))
+ civil_year)
+ civil_year)
+ (i./ (.int //year.era)))
+ year_of_era (i.- (i.* (.int //year.era)
+ era)
+ civil_year)
+ day_of_year (|> utc_month
+ ..day_of_year_from_month
+ (i.+ (.int (dec (..day_of_month date)))))
+ day_of_era (|> day_of_year
+ (i.+ (i.* (.int //year.days) year_of_era))
+ (i.+ (i./ (.int //year.leap) year_of_era))
+ (i.- (i./ (.int //year.century) year_of_era)))]
+ (|> (i.* (.int ..days_per_era) era)
+ (i.+ day_of_era)
+ (i.- (.int ..days_since_epoch)))))
+
+## http://howardhinnant.github.io/date_algorithms.html
+(def: #export (from_days days)
+ (-> Int Date)
+ (let [days (i.+ (.int ..days_since_epoch) days)
+ era (|> (if (i.< +0 days)
+ (i.- ..last_era_day days)
+ days)
+ (i./ (.int ..days_per_era)))
+ day_of_era (i.- (i.* (.int ..days_per_era) era) days)
+ year_of_era (|> day_of_era
+ (i.- (i./ ..last_era_leap_day day_of_era))
+ (i.+ (i./ (.int ..days_per_century) day_of_era))
+ (i.- (i./ ..last_era_day day_of_era))
+ (i./ (.int //year.days)))
+ year (i.+ (i.* (.int //year.era) era)
+ year_of_era)
+ day_of_year (|> day_of_era
+ (i.- (i.* (.int //year.days) year_of_era))
+ (i.- (i./ (.int //year.leap) year_of_era))
+ (i.+ (i./ (.int //year.century) year_of_era)))
+ month (..month_from_day_of_year day_of_year)
+ day (|> day_of_year
+ (i.- (..day_of_year_from_month month))
+ (i.+ +1)
+ .nat)
+ year (if (n.< ..first_month_of_civil_year month)
+ (inc year)
+ year)]
+ ## Coercing, because the year is already in internal form.
+ (try.assume (..date (:as Year year)
+ (maybe.assume (dictionary.get month ..month_by_number))
+ day))))
+
+(implementation: #export enum
+ (Enum Date)
+
+ (def: &order ..order)
+
+ (def: succ
+ (|>> ..to_days inc ..from_days))
+
+ (def: pred
+ (|>> ..to_days dec ..from_days)))
diff --git a/stdlib/source/library/lux/time/day.lux b/stdlib/source/library/lux/time/day.lux
new file mode 100644
index 000000000..157dd6c1f
--- /dev/null
+++ b/stdlib/source/library/lux/time/day.lux
@@ -0,0 +1,121 @@
+(.module:
+ [library
+ [lux (#- nat)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]
+ [enum (#+ Enum)]
+ [codec (#+ Codec)]]
+ [control
+ ["." try]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." text]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["n" nat]]]]])
+
+(type: #export Day
+ #Sunday
+ #Monday
+ #Tuesday
+ #Wednesday
+ #Thursday
+ #Friday
+ #Saturday)
+
+(implementation: #export equivalence
+ (Equivalence Day)
+
+ (def: (= reference sample)
+ (case [reference sample]
+ (^template [<tag>]
+ [[<tag> <tag>]
+ #1])
+ ([#Sunday]
+ [#Monday]
+ [#Tuesday]
+ [#Wednesday]
+ [#Thursday]
+ [#Friday]
+ [#Saturday])
+
+ _
+ #0)))
+
+(def: (nat day)
+ (-> Day Nat)
+ (case day
+ #Sunday 0
+ #Monday 1
+ #Tuesday 2
+ #Wednesday 3
+ #Thursday 4
+ #Friday 5
+ #Saturday 6))
+
+(implementation: #export order
+ (Order Day)
+
+ (def: &equivalence ..equivalence)
+
+ (def: (< reference sample)
+ (n.< (..nat reference) (..nat sample))))
+
+(implementation: #export enum
+ (Enum Day)
+
+ (def: &order ..order)
+
+ (def: (succ day)
+ (case day
+ #Sunday #Monday
+ #Monday #Tuesday
+ #Tuesday #Wednesday
+ #Wednesday #Thursday
+ #Thursday #Friday
+ #Friday #Saturday
+ #Saturday #Sunday))
+
+ (def: (pred day)
+ (case day
+ #Monday #Sunday
+ #Tuesday #Monday
+ #Wednesday #Tuesday
+ #Thursday #Wednesday
+ #Friday #Thursday
+ #Saturday #Friday
+ #Sunday #Saturday)))
+
+(exception: #export (not_a_day_of_the_week {value Text})
+ (exception.report
+ ["Value" (text.format value)]))
+
+(implementation: #export codec
+ (Codec Text Day)
+
+ (def: (encode value)
+ (case value
+ (^template [<tag>]
+ [<tag> (template.text [<tag>])])
+ ([#..Monday]
+ [#..Tuesday]
+ [#..Wednesday]
+ [#..Thursday]
+ [#..Friday]
+ [#..Saturday]
+ [#..Sunday])))
+ (def: (decode value)
+ (case value
+ (^template [<tag>]
+ [(^ (template.text [<tag>])) (#try.Success <tag>)])
+ ([#..Monday]
+ [#..Tuesday]
+ [#..Wednesday]
+ [#..Thursday]
+ [#..Friday]
+ [#..Saturday]
+ [#..Sunday])
+ _ (exception.throw ..not_a_day_of_the_week [value]))))
diff --git a/stdlib/source/library/lux/time/duration.lux b/stdlib/source/library/lux/time/duration.lux
new file mode 100644
index 000000000..1de5dab4f
--- /dev/null
+++ b/stdlib/source/library/lux/time/duration.lux
@@ -0,0 +1,203 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]
+ [enum (#+ Enum)]
+ [codec (#+ Codec)]
+ [monoid (#+ Monoid)]
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["<>" parser
+ ["<t>" text (#+ Parser)]]]
+ [data
+ ["." text ("#\." monoid)]]
+ [math
+ [number
+ ["i" int]
+ ["." nat ("#\." decimal)]]]
+ [type
+ abstract]]]
+ ["." // #_
+ ["#." year]])
+
+(abstract: #export Duration
+ Int
+
+ {#.doc "Durations have a resolution of milli-seconds."}
+
+ (def: #export from_millis
+ (-> Int Duration)
+ (|>> :abstraction))
+
+ (def: #export to_millis
+ (-> Duration Int)
+ (|>> :representation))
+
+ (template [<op> <name>]
+ [(def: #export (<name> param subject)
+ (-> Duration Duration Duration)
+ (:abstraction (<op> (:representation param) (:representation subject))))]
+
+ [i.+ merge]
+ [i.% frame]
+ )
+
+ (template [<op> <name>]
+ [(def: #export (<name> scalar)
+ (-> Nat Duration Duration)
+ (|>> :representation (<op> (.int scalar)) :abstraction))]
+
+ [i.* up]
+ [i./ down]
+ )
+
+ (def: #export inverse
+ (-> Duration Duration)
+ (|>> :representation (i.* -1) :abstraction))
+
+ (def: #export (query param subject)
+ (-> Duration Duration Int)
+ (i./ (:representation param) (:representation subject)))
+
+ (implementation: #export equivalence
+ (Equivalence Duration)
+
+ (def: (= param subject)
+ (i.= (:representation param) (:representation subject))))
+
+ (implementation: #export order
+ (Order Duration)
+
+ (def: &equivalence ..equivalence)
+ (def: (< param subject)
+ (i.< (:representation param) (:representation subject))))
+
+ (template [<op> <name>]
+ [(def: #export <name>
+ (-> Duration Bit)
+ (|>> :representation (<op> +0)))]
+
+ [i.> positive?]
+ [i.< negative?]
+ [i.= neutral?]
+ )
+ )
+
+(def: #export empty
+ (..from_millis +0))
+
+(def: #export milli_second
+ (..from_millis +1))
+
+(template [<name> <scale> <base>]
+ [(def: #export <name>
+ (..up <scale> <base>))]
+
+ [second 1,000 milli_second]
+ [minute 60 second]
+ [hour 60 minute]
+ [day 24 hour]
+
+ [week 7 day]
+ [normal_year //year.days day]
+ )
+
+(def: #export leap_year
+ (..merge ..day ..normal_year))
+
+(implementation: #export monoid
+ (Monoid Duration)
+
+ (def: identity ..empty)
+ (def: compose ..merge))
+
+(template [<value> <definition>]
+ [(def: <definition> <value>)]
+
+ ["D" day_suffix]
+ ["h" hour_suffix]
+ ["m" minute_suffix]
+ ["s" second_suffix]
+ ["ms" milli_second_suffix]
+
+ ["+" positive_sign]
+ ["-" negative_sign]
+ )
+
+(def: (encode duration)
+ (if (\ ..equivalence = ..empty duration)
+ ($_ text\compose
+ ..positive_sign
+ (nat\encode 0)
+ ..milli_second_suffix)
+ (let [signed? (negative? duration)
+ [days time_left] [(query day duration) (frame day duration)]
+ days (if signed?
+ (i.abs days)
+ days)
+ time_left (if signed?
+ (..inverse time_left)
+ time_left)
+ [hours time_left] [(query hour time_left) (frame hour time_left)]
+ [minutes time_left] [(query minute time_left) (frame minute time_left)]
+ [seconds time_left] [(query second time_left) (frame second time_left)]
+ millis (to_millis time_left)]
+ ($_ text\compose
+ (if signed? ..negative_sign ..positive_sign)
+ (if (i.= +0 days) "" (text\compose (nat\encode (.nat days)) ..day_suffix))
+ (if (i.= +0 hours) "" (text\compose (nat\encode (.nat hours)) ..hour_suffix))
+ (if (i.= +0 minutes) "" (text\compose (nat\encode (.nat minutes)) ..minute_suffix))
+ (if (i.= +0 seconds) "" (text\compose (nat\encode (.nat seconds)) ..second_suffix))
+ (if (i.= +0 millis) "" (text\compose (nat\encode (.nat millis)) ..milli_second_suffix))
+ ))))
+
+(def: parser
+ (Parser Duration)
+ (let [section (: (-> Text Text (Parser Nat))
+ (function (_ suffix false_suffix)
+ (|> (<t>.many <t>.decimal)
+ (<>.codec nat.decimal)
+ (<>.before (case false_suffix
+ "" (<t>.this suffix)
+ _ (<>.after (<>.not (<t>.this false_suffix))
+ (<t>.this suffix))))
+ (<>.default 0))))]
+ (do <>.monad
+ [sign (<>.or (<t>.this ..negative_sign)
+ (<t>.this ..positive_sign))
+ days (section ..day_suffix "")
+ hours (section hour_suffix "")
+ minutes (section ..minute_suffix ..milli_second_suffix)
+ seconds (section ..second_suffix "")
+ millis (section ..milli_second_suffix "")
+ #let [span (|> ..empty
+ (..merge (..up days ..day))
+ (..merge (..up hours ..hour))
+ (..merge (..up minutes ..minute))
+ (..merge (..up seconds ..second))
+ (..merge (..up millis ..milli_second)))]]
+ (wrap (case sign
+ (#.Left _) (..inverse span)
+ (#.Right _) span)))))
+
+(implementation: #export codec
+ (Codec Text Duration)
+
+ (def: encode ..encode)
+ (def: decode (<t>.run ..parser)))
+
+(def: #export (difference from to)
+ (-> Duration Duration Duration)
+ (|> from ..inverse (..merge to)))
+
+(implementation: #export enum
+ (Enum Duration)
+
+ (def: &order ..order)
+ (def: succ
+ (..merge ..milli_second))
+ (def: pred
+ (..merge (..inverse ..milli_second))))
diff --git a/stdlib/source/library/lux/time/instant.lux b/stdlib/source/library/lux/time/instant.lux
new file mode 100644
index 000000000..ecefe3491
--- /dev/null
+++ b/stdlib/source/library/lux/time/instant.lux
@@ -0,0 +1,235 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]
+ [enum (#+ Enum)]
+ [codec (#+ Codec)]
+ [monad (#+ Monad do)]]
+ [control
+ [io (#+ IO io)]
+ ["." try]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<.>" text (#+ Parser)]]]
+ [data
+ ["." maybe]
+ ["." text ("#\." monoid)]
+ [collection
+ ["." row]]]
+ [math
+ [number
+ ["i" int]
+ ["f" frac]]]
+ [type
+ abstract]]]
+ ["." // (#+ Time)
+ ["." duration (#+ Duration)]
+ ["." year (#+ Year)]
+ ["." month (#+ Month)]
+ ["." day (#+ Day)]
+ ["." date (#+ Date)]])
+
+(abstract: #export Instant
+ Int
+
+ {#.doc "Instant is defined as milliseconds since the epoch."}
+
+ (def: #export from_millis
+ (-> Int Instant)
+ (|>> :abstraction))
+
+ (def: #export to_millis
+ (-> Instant Int)
+ (|>> :representation))
+
+ (def: #export (span from to)
+ (-> Instant Instant Duration)
+ (duration.from_millis (i.- (:representation from) (:representation to))))
+
+ (def: #export (shift duration instant)
+ (-> Duration Instant Instant)
+ (:abstraction (i.+ (duration.to_millis duration) (:representation instant))))
+
+ (def: #export (relative instant)
+ (-> Instant Duration)
+ (|> instant :representation duration.from_millis))
+
+ (def: #export (absolute offset)
+ (-> Duration Instant)
+ (|> offset duration.to_millis :abstraction))
+
+ (implementation: #export equivalence
+ (Equivalence Instant)
+
+ (def: (= param subject)
+ (\ i.equivalence = (:representation param) (:representation subject))))
+
+ (implementation: #export order
+ (Order Instant)
+
+ (def: &equivalence ..equivalence)
+ (def: (< param subject)
+ (\ i.order < (:representation param) (:representation subject))))
+
+ (`` (implementation: #export enum
+ (Enum Instant)
+
+ (def: &order ..order)
+ (~~ (template [<name>]
+ [(def: <name>
+ (|>> :representation (\ i.enum <name>) :abstraction))]
+
+ [succ] [pred]
+ ))))
+ )
+
+(def: #export epoch
+ {#.doc "The instant corresponding to 1970-01-01T00:00:00Z"}
+ Instant
+ (..from_millis +0))
+
+(def: millis_per_day
+ (duration.query duration.milli_second duration.day))
+
+(def: (split_date_time instant)
+ (-> Instant [Date Duration])
+ (let [offset (..to_millis instant)
+ bce? (i.< +0 offset)
+ [days day_time] (if bce?
+ (let [[days millis] (i./% ..millis_per_day offset)]
+ (case millis
+ +0 [days millis]
+ _ [(dec days) (i.+ ..millis_per_day millis)]))
+ (i./% ..millis_per_day offset))]
+ [(date.from_days days)
+ (duration.from_millis day_time)]))
+
+(template [<value> <definition>]
+ [(def: <definition> Text <value>)]
+
+ ["T" date_suffix]
+ ["Z" time_suffix]
+ )
+
+(def: (clock_time duration)
+ (-> Duration Time)
+ (let [time (if (\ duration.order < duration.empty duration)
+ (duration.merge duration.day duration)
+ duration)]
+ (|> time duration.to_millis .nat //.from_millis try.assume)))
+
+(def: (encode instant)
+ (-> Instant Text)
+ (let [[date time] (..split_date_time instant)
+ time (..clock_time time)]
+ ($_ text\compose
+ (\ date.codec encode date) ..date_suffix
+ (\ //.codec encode time) ..time_suffix)))
+
+(def: parser
+ (Parser Instant)
+ (do {! <>.monad}
+ [days (\ ! map date.to_days date.parser)
+ _ (<text>.this ..date_suffix)
+ time (\ ! map //.to_millis //.parser)
+ _ (<text>.this ..time_suffix)]
+ (wrap (|> (if (i.< +0 days)
+ (|> duration.day
+ (duration.up (.nat (i.* -1 days)))
+ duration.inverse)
+ (duration.up (.nat days) duration.day))
+ (duration.merge (duration.up time duration.milli_second))
+ ..absolute))))
+
+(implementation: #export codec
+ {#.doc (doc "Based on ISO 8601."
+ "For example: 2017-01-15T21:14:51.827Z")}
+ (Codec Text Instant)
+
+ (def: encode ..encode)
+ (def: decode (<text>.run ..parser)))
+
+(def: #export now
+ (IO Instant)
+ (io (..from_millis (for {@.old ("jvm invokestatic:java.lang.System:currentTimeMillis:")
+ @.jvm (|> ("jvm member invoke static" [] "java.lang.System" "currentTimeMillis" [])
+ ("jvm object cast")
+ (: (primitive "java.lang.Long"))
+ (:as Int))
+ @.js (let [date ("js object new" ("js constant" "Date") [])]
+ (|> ("js object do" "getTime" date [])
+ (:as Frac)
+ "lux f64 i64"))
+ @.python (let [time ("python import" "time")]
+ (|> ("python object do" "time" time)
+ (:as Frac)
+ (f.* +1,000.0)
+ "lux f64 i64"))
+ @.lua (|> ("lua constant" "os.time")
+ "lua apply"
+ (:as Int)
+ (i.* +1,000))
+ @.ruby (let [% ("ruby constant" "Time")
+ % ("ruby object do" "now" %)]
+ (|> ("ruby object do" "to_f" %)
+ (:as Frac)
+ (f.* +1,000.0)
+ "lux f64 i64"))
+ @.php (|> ("php constant" "time")
+ "php apply"
+ (:as Int)
+ (i.* +1,000))
+ @.scheme (|> ("scheme constant" "current-second")
+ (:as Int)
+ (i.* +1,000)
+ ("scheme apply" ("scheme constant" "exact"))
+ ("scheme apply" ("scheme constant" "truncate")))
+ @.common_lisp (|> ("common_lisp constant" "get-universal-time")
+ "common_lisp apply"
+ (:as Int)
+ (i.* +1,000))
+ }))))
+
+(template [<field> <type> <post_processing>]
+ [(def: #export (<field> instant)
+ (-> Instant <type>)
+ (let [[date time] (..split_date_time instant)]
+ (|> <field> <post_processing>)))]
+
+ [date Date (|>)]
+ [time Time ..clock_time]
+ )
+
+(def: #export (day_of_week instant)
+ (-> Instant Day)
+ (let [offset (..relative instant)
+ days (duration.query duration.day offset)
+ day_time (duration.frame duration.day offset)
+ days (if (and (duration.negative? offset)
+ (not (duration.neutral? day_time)))
+ (dec days)
+ days)
+ ## 1970/01/01 was a Thursday
+ y1970m0d0 +4]
+ (case (|> y1970m0d0
+ (i.+ days) (i.% +7)
+ ## This is done to turn negative days into positive days.
+ (i.+ +7) (i.% +7))
+ +0 #day.Sunday
+ +1 #day.Monday
+ +2 #day.Tuesday
+ +3 #day.Wednesday
+ +4 #day.Thursday
+ +5 #day.Friday
+ +6 #day.Saturday
+ _ (undefined))))
+
+(def: #export (from_date_time date time)
+ (-> Date Time Instant)
+ (|> (date.to_days date)
+ (i.* (duration.to_millis duration.day))
+ (i.+ (.int (//.to_millis time)))
+ ..from_millis))
diff --git a/stdlib/source/library/lux/time/month.lux b/stdlib/source/library/lux/time/month.lux
new file mode 100644
index 000000000..381094933
--- /dev/null
+++ b/stdlib/source/library/lux/time/month.lux
@@ -0,0 +1,225 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]
+ [order (#+ Order)]
+ [enum (#+ Enum)]
+ [codec (#+ Codec)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." text]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["n" nat]]]]])
+
+(type: #export Month
+ #January
+ #February
+ #March
+ #April
+ #May
+ #June
+ #July
+ #August
+ #September
+ #October
+ #November
+ #December)
+
+(implementation: #export equivalence
+ (Equivalence Month)
+
+ (def: (= reference sample)
+ (case [reference sample]
+ (^template [<tag>]
+ [[<tag> <tag>]
+ true])
+ ([#January]
+ [#February]
+ [#March]
+ [#April]
+ [#May]
+ [#June]
+ [#July]
+ [#August]
+ [#September]
+ [#October]
+ [#November]
+ [#December])
+
+ _
+ false)))
+
+(with_expansions [<pairs> (as_is [01 #January]
+ [02 #February]
+ [03 #March]
+ [04 #April]
+ [05 #May]
+ [06 #June]
+ [07 #July]
+ [08 #August]
+ [09 #September]
+ [10 #October]
+ [11 #November]
+ [12 #December])]
+ (def: #export (number month)
+ (-> Month Nat)
+ (case month
+ (^template [<number> <month>]
+ [<month> <number>])
+ (<pairs>)))
+
+ (exception: #export (invalid_month {number Nat})
+ (exception.report
+ ["Number" (\ n.decimal encode number)]
+ ["Valid range" ($_ "lux text concat"
+ (\ n.decimal encode (..number #January))
+ " ~ "
+ (\ n.decimal encode (..number #December)))]))
+
+ (def: #export (by_number number)
+ (-> Nat (Try Month))
+ (case number
+ (^template [<number> <month>]
+ [<number> (#try.Success <month>)])
+ (<pairs>)
+ _ (exception.throw ..invalid_month [number])))
+ )
+
+(implementation: #export hash
+ (Hash Month)
+
+ (def: &equivalence ..equivalence)
+ (def: hash ..number))
+
+(implementation: #export order
+ (Order Month)
+
+ (def: &equivalence ..equivalence)
+
+ (def: (< reference sample)
+ (n.< (..number reference) (..number sample))))
+
+(implementation: #export enum
+ (Enum Month)
+
+ (def: &order ..order)
+
+ (def: (succ month)
+ (case month
+ #January #February
+ #February #March
+ #March #April
+ #April #May
+ #May #June
+ #June #July
+ #July #August
+ #August #September
+ #September #October
+ #October #November
+ #November #December
+ #December #January))
+
+ (def: (pred month)
+ (case month
+ #February #January
+ #March #February
+ #April #March
+ #May #April
+ #June #May
+ #July #June
+ #August #July
+ #September #August
+ #October #September
+ #November #October
+ #December #November
+ #January #December)))
+
+(def: #export (days month)
+ (-> Month Nat)
+ (case month
+ (^template [<days> <month>]
+ [<month> <days>])
+ ([31 #January]
+ [28 #February]
+ [31 #March]
+
+ [30 #April]
+ [31 #May]
+ [30 #June]
+
+ [31 #July]
+ [31 #August]
+ [30 #September]
+
+ [31 #October]
+ [30 #November]
+ [31 #December])))
+
+(def: #export (leap_year_days month)
+ (-> Month Nat)
+ (case month
+ #February (inc (..days month))
+ _ (..days month)))
+
+(def: #export year
+ (List Month)
+ (list #January
+ #February
+ #March
+ #April
+ #May
+ #June
+ #July
+ #August
+ #September
+ #October
+ #November
+ #December))
+
+(exception: #export (not_a_month_of_the_year {value Text})
+ (exception.report
+ ["Value" (text.format value)]))
+
+(implementation: #export codec
+ (Codec Text Month)
+
+ (def: (encode value)
+ (case value
+ (^template [<tag>]
+ [<tag> (template.text [<tag>])])
+ ([#..January]
+ [#..February]
+ [#..March]
+ [#..April]
+ [#..May]
+ [#..June]
+ [#..July]
+ [#..August]
+ [#..September]
+ [#..October]
+ [#..November]
+ [#..December])))
+ (def: (decode value)
+ (case value
+ (^template [<tag>]
+ [(^ (template.text [<tag>])) (#try.Success <tag>)])
+ ([#..January]
+ [#..February]
+ [#..March]
+ [#..April]
+ [#..May]
+ [#..June]
+ [#..July]
+ [#..August]
+ [#..September]
+ [#..October]
+ [#..November]
+ [#..December])
+ _ (exception.throw ..not_a_month_of_the_year [value]))))
diff --git a/stdlib/source/library/lux/time/year.lux b/stdlib/source/library/lux/time/year.lux
new file mode 100644
index 000000000..95280df9c
--- /dev/null
+++ b/stdlib/source/library/lux/time/year.lux
@@ -0,0 +1,142 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]
+ [codec (#+ Codec)]
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<t>" text (#+ Parser)]]]
+ [data
+ ["." text ("#\." monoid)]]
+ [math
+ [number
+ ["n" nat ("#\." decimal)]
+ ["i" int ("#\." decimal)]]]
+ [type
+ abstract]]])
+
+(def: (internal year)
+ (-> Int Int)
+ (if (i.< +0 year)
+ (inc year)
+ year))
+
+(def: (external year)
+ (-> Int Int)
+ (if (i.> +0 year)
+ year
+ (dec year)))
+
+(exception: #export there-is-no-year-0)
+
+(abstract: #export Year
+ Int
+
+ (def: #export (year value)
+ (-> Int (Try Year))
+ (case value
+ +0 (exception.throw ..there-is-no-year-0 [])
+ _ (#try.Success (:abstraction (..internal value)))))
+
+ (def: #export value
+ (-> Year Int)
+ (|>> :representation ..external))
+
+ (def: #export epoch
+ Year
+ (:abstraction +1970))
+ )
+
+(def: #export days
+ 365)
+
+(type: #export Period
+ Nat)
+
+(template [<period> <name>]
+ [(def: #export <name>
+ Period
+ <period>)]
+
+ [004 leap]
+ [100 century]
+ [400 era]
+ )
+
+(def: (divisible? factor input)
+ (-> Int Int Bit)
+ (|> input (i.% factor) (i.= +0)))
+
+## https://en.wikipedia.org/wiki/Leap_year#Algorithm
+(def: #export (leap? year)
+ (-> Year Bit)
+ (let [year (|> year ..value ..internal)]
+ (and (..divisible? (.int ..leap) year)
+ (or (not (..divisible? (.int ..century) year))
+ (..divisible? (.int ..era) year)))))
+
+(def: (with-year-0-leap year days)
+ (let [after-year-0? (i.> +0 year)]
+ (if after-year-0?
+ (i.+ +1 days)
+ days)))
+
+(def: #export (leaps year)
+ (-> Year Int)
+ (let [year (|> year ..value ..internal)
+ limit (if (i.> +0 year)
+ (dec year)
+ (inc year))]
+ (`` (|> +0
+ (~~ (template [<polarity> <years>]
+ [(<polarity> (i./ (.int <years>) limit))]
+
+ [i.+ ..leap]
+ [i.- ..century]
+ [i.+ ..era]
+ ))
+ (..with-year-0-leap year)))))
+
+(def: (encode year)
+ (-> Year Text)
+ (let [year (..value year)]
+ (if (i.< +0 year)
+ (i\encode year)
+ (n\encode (.nat year)))))
+
+(def: #export parser
+ (Parser Year)
+ (do {! <>.monad}
+ [sign (<>.or (<t>.this "-") (wrap []))
+ digits (<t>.many <t>.decimal)
+ raw-year (<>.codec i.decimal (wrap (text\compose "+" digits)))]
+ (<>.lift (..year (case sign
+ (#.Left _) (i.* -1 raw-year)
+ (#.Right _) raw-year)))))
+
+(implementation: #export codec
+ {#.doc (doc "Based on ISO 8601."
+ "For example: 2017")}
+ (Codec Text Year)
+
+ (def: encode ..encode)
+ (def: decode (<t>.run ..parser)))
+
+(implementation: #export equivalence
+ (Equivalence Year)
+
+ (def: (= reference subject)
+ (i.= (..value reference) (..value subject))))
+
+(implementation: #export order
+ (Order Year)
+
+ (def: &equivalence ..equivalence)
+
+ (def: (< reference subject)
+ (i.< (..value reference) (..value subject))))
diff --git a/stdlib/source/library/lux/tool/compiler.lux b/stdlib/source/library/lux/tool/compiler.lux
new file mode 100644
index 000000000..1acd9aeea
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler.lux
@@ -0,0 +1,47 @@
+(.module:
+ [library
+ [lux (#- Module Code)
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ [binary (#+ Binary)]
+ ["." text]
+ [collection
+ ["." row (#+ Row)]]]
+ [world
+ ["." file (#+ Path)]]]]
+ [/
+ [meta
+ ["." archive (#+ Output Archive)
+ [key (#+ Key)]
+ [descriptor (#+ Descriptor Module)]
+ [document (#+ Document)]]]])
+
+(type: #export Code
+ Text)
+
+(type: #export Parameter
+ Text)
+
+(type: #export Input
+ {#module Module
+ #file Path
+ #hash Nat
+ #code Code})
+
+(type: #export (Compilation s d o)
+ {#dependencies (List Module)
+ #process (-> s Archive
+ (Try [s (Either (Compilation s d o)
+ [Descriptor (Document d) Output])]))})
+
+(type: #export (Compiler s d o)
+ (-> Input (Compilation s d o)))
+
+(type: #export (Instancer s d o)
+ (-> (Key d) (List Parameter) (Compiler s d o)))
+
+(exception: #export (cannot_compile {module Module})
+ (exception.report
+ ["Module" module]))
diff --git a/stdlib/source/library/lux/tool/compiler/arity.lux b/stdlib/source/library/lux/tool/compiler/arity.lux
new file mode 100644
index 000000000..61e0ea625
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/arity.lux
@@ -0,0 +1,16 @@
+(.module:
+ [library
+ [lux #*
+ [math
+ [number
+ ["n" nat]]]]])
+
+(type: #export Arity Nat)
+
+(template [<comparison> <name>]
+ [(def: #export <name> (-> Arity Bit) (<comparison> 1))]
+
+ [n.< nullary?]
+ [n.= unary?]
+ [n.> multiary?]
+ )
diff --git a/stdlib/source/library/lux/tool/compiler/default/init.lux b/stdlib/source/library/lux/tool/compiler/default/init.lux
new file mode 100644
index 000000000..172de25e7
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/default/init.lux
@@ -0,0 +1,287 @@
+(.module:
+ [library
+ [lux (#- Module)
+ ["@" target (#+ Target)]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ [binary (#+ Binary)]
+ ["." product]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." dictionary]
+ ["." set]
+ ["." row ("#\." functor)]]]
+ ["." meta]
+ [world
+ ["." file]]]]
+ ["." // #_
+ ["/#" // (#+ Instancer)
+ ["#." phase]
+ [language
+ [lux
+ [program (#+ Program)]
+ ["#." version]
+ ["#." syntax (#+ Aliases)]
+ ["#." synthesis]
+ ["#." directive (#+ Requirements)]
+ ["#." generation]
+ ["#." analysis
+ [macro (#+ Expander)]
+ ["#/." evaluation]]
+ [phase
+ [".P" synthesis]
+ [".P" directive]
+ [".P" analysis
+ ["." module]]
+ ["." extension (#+ Extender)
+ [".E" analysis]
+ [".E" synthesis]
+ [directive
+ [".D" lux]]]]]]
+ [meta
+ ["." archive (#+ Archive)
+ ["." descriptor (#+ Module)]
+ ["." artifact]
+ ["." document]]]]])
+
+(def: #export (state target module expander host_analysis host generate generation_bundle)
+ (All [anchor expression directive]
+ (-> Target
+ Module
+ Expander
+ ///analysis.Bundle
+ (///generation.Host expression directive)
+ (///generation.Phase anchor expression directive)
+ (///generation.Bundle anchor expression directive)
+ (///directive.State+ anchor expression directive)))
+ (let [synthesis_state [synthesisE.bundle ///synthesis.init]
+ generation_state [generation_bundle (///generation.state host module)]
+ eval (///analysis/evaluation.evaluator expander synthesis_state generation_state generate)
+ analysis_state [(analysisE.bundle eval host_analysis)
+ (///analysis.state (///analysis.info ///version.version target))]]
+ [extension.empty
+ {#///directive.analysis {#///directive.state analysis_state
+ #///directive.phase (analysisP.phase expander)}
+ #///directive.synthesis {#///directive.state synthesis_state
+ #///directive.phase synthesisP.phase}
+ #///directive.generation {#///directive.state generation_state
+ #///directive.phase generate}}]))
+
+(def: #export (with_default_directives expander host_analysis program anchorT,expressionT,directiveT extender)
+ (All [anchor expression directive]
+ (-> Expander
+ ///analysis.Bundle
+ (Program expression directive)
+ [Type Type Type]
+ Extender
+ (-> (///directive.State+ anchor expression directive)
+ (///directive.State+ anchor expression directive))))
+ (function (_ [directive_extensions sub_state])
+ [(dictionary.merge directive_extensions
+ (luxD.bundle expander host_analysis program anchorT,expressionT,directiveT extender))
+ sub_state]))
+
+(type: Reader
+ (-> Source (Either [Source Text] [Source Code])))
+
+(def: (reader current_module aliases [location offset source_code])
+ (-> Module Aliases Source (///analysis.Operation Reader))
+ (function (_ [bundle state])
+ (#try.Success [[bundle state]
+ (///syntax.parse current_module aliases ("lux text size" source_code))])))
+
+(def: (read source reader)
+ (-> Source Reader (///analysis.Operation [Source Code]))
+ (function (_ [bundle compiler])
+ (case (reader source)
+ (#.Left [source' error])
+ (#try.Failure error)
+
+ (#.Right [source' output])
+ (let [[location _] output]
+ (#try.Success [[bundle (|> compiler
+ (set@ #.source source')
+ (set@ #.location location))]
+ [source' output]])))))
+
+(type: (Operation a)
+ (All [anchor expression directive]
+ (///directive.Operation anchor expression directive a)))
+
+(type: (Payload directive)
+ [(///generation.Buffer directive)
+ artifact.Registry])
+
+(def: (begin dependencies hash input)
+ (-> (List Module) Nat ///.Input
+ (All [anchor expression directive]
+ (///directive.Operation anchor expression directive
+ [Source (Payload directive)])))
+ (do ///phase.monad
+ [#let [module (get@ #///.module input)]
+ _ (///directive.set_current_module module)]
+ (///directive.lift_analysis
+ (do {! ///phase.monad}
+ [_ (module.create hash module)
+ _ (monad.map ! module.import dependencies)
+ #let [source (///analysis.source (get@ #///.module input) (get@ #///.code input))]
+ _ (///analysis.set_source_code source)]
+ (wrap [source [///generation.empty_buffer
+ artifact.empty]])))))
+
+(def: (end module)
+ (-> Module
+ (All [anchor expression directive]
+ (///directive.Operation anchor expression directive [.Module (Payload directive)])))
+ (do ///phase.monad
+ [_ (///directive.lift_analysis
+ (module.set_compiled module))
+ analysis_module (<| (: (Operation .Module))
+ ///directive.lift_analysis
+ extension.lift
+ meta.current_module)
+ final_buffer (///directive.lift_generation
+ ///generation.buffer)
+ final_registry (///directive.lift_generation
+ ///generation.get_registry)]
+ (wrap [analysis_module [final_buffer
+ final_registry]])))
+
+## TODO: Inline ASAP
+(def: (get_current_payload _)
+ (All [directive]
+ (-> (Payload directive)
+ (All [anchor expression]
+ (///directive.Operation anchor expression directive
+ (Payload directive)))))
+ (do ///phase.monad
+ [buffer (///directive.lift_generation
+ ///generation.buffer)
+ registry (///directive.lift_generation
+ ///generation.get_registry)]
+ (wrap [buffer registry])))
+
+## TODO: Inline ASAP
+(def: (process_directive archive expander pre_payoad code)
+ (All [directive]
+ (-> Archive Expander (Payload directive) Code
+ (All [anchor expression]
+ (///directive.Operation anchor expression directive
+ [Requirements (Payload directive)]))))
+ (do ///phase.monad
+ [#let [[pre_buffer pre_registry] pre_payoad]
+ _ (///directive.lift_generation
+ (///generation.set_buffer pre_buffer))
+ _ (///directive.lift_generation
+ (///generation.set_registry pre_registry))
+ requirements (let [execute! (directiveP.phase expander)]
+ (execute! archive code))
+ post_payload (..get_current_payload pre_payoad)]
+ (wrap [requirements post_payload])))
+
+(def: (iteration archive expander reader source pre_payload)
+ (All [directive]
+ (-> Archive Expander Reader Source (Payload directive)
+ (All [anchor expression]
+ (///directive.Operation anchor expression directive
+ [Source Requirements (Payload directive)]))))
+ (do ///phase.monad
+ [[source code] (///directive.lift_analysis
+ (..read source reader))
+ [requirements post_payload] (process_directive archive expander pre_payload code)]
+ (wrap [source requirements post_payload])))
+
+(def: (iterate archive expander module source pre_payload aliases)
+ (All [directive]
+ (-> Archive Expander Module Source (Payload directive) Aliases
+ (All [anchor expression]
+ (///directive.Operation anchor expression directive
+ (Maybe [Source Requirements (Payload directive)])))))
+ (do ///phase.monad
+ [reader (///directive.lift_analysis
+ (..reader module aliases source))]
+ (function (_ state)
+ (case (///phase.run' state (..iteration archive expander reader source pre_payload))
+ (#try.Success [state source&requirements&buffer])
+ (#try.Success [state (#.Some source&requirements&buffer)])
+
+ (#try.Failure error)
+ (if (exception.match? ///syntax.end_of_file error)
+ (#try.Success [state #.None])
+ (exception.with ///.cannot_compile module (#try.Failure error)))))))
+
+(def: (default_dependencies prelude input)
+ (-> Module ///.Input (List Module))
+ (list& archive.runtime_module
+ (if (text\= prelude (get@ #///.module input))
+ (list)
+ (list prelude))))
+
+(def: module_aliases
+ (-> .Module Aliases)
+ (|>> (get@ #.module_aliases) (dictionary.from_list text.hash)))
+
+(def: #export (compiler expander prelude write_directive)
+ (All [anchor expression directive]
+ (-> Expander Module (-> directive Binary)
+ (Instancer (///directive.State+ anchor expression directive) .Module)))
+ (let [execute! (directiveP.phase expander)]
+ (function (_ key parameters input)
+ (let [dependencies (default_dependencies prelude input)]
+ {#///.dependencies dependencies
+ #///.process (function (_ state archive)
+ (do {! try.monad}
+ [#let [hash (text\hash (get@ #///.code input))]
+ [state [source buffer]] (<| (///phase.run' state)
+ (..begin dependencies hash input))
+ #let [module (get@ #///.module input)]]
+ (loop [iteration (<| (///phase.run' state)
+ (..iterate archive expander module source buffer ///syntax.no_aliases))]
+ (do !
+ [[state ?source&requirements&temporary_payload] iteration]
+ (case ?source&requirements&temporary_payload
+ #.None
+ (do !
+ [[state [analysis_module [final_buffer final_registry]]] (///phase.run' state (..end module))
+ #let [descriptor {#descriptor.hash hash
+ #descriptor.name module
+ #descriptor.file (get@ #///.file input)
+ #descriptor.references (set.from_list text.hash dependencies)
+ #descriptor.state #.Compiled
+ #descriptor.registry final_registry}]]
+ (wrap [state
+ (#.Right [descriptor
+ (document.write key analysis_module)
+ (row\map (function (_ [artifact_id directive])
+ [artifact_id (write_directive directive)])
+ final_buffer)])]))
+
+ (#.Some [source requirements temporary_payload])
+ (let [[temporary_buffer temporary_registry] temporary_payload]
+ (wrap [state
+ (#.Left {#///.dependencies (|> requirements
+ (get@ #///directive.imports)
+ (list\map product.left))
+ #///.process (function (_ state archive)
+ (recur (<| (///phase.run' state)
+ (do {! ///phase.monad}
+ [analysis_module (<| (: (Operation .Module))
+ ///directive.lift_analysis
+ extension.lift
+ meta.current_module)
+ _ (///directive.lift_generation
+ (///generation.set_buffer temporary_buffer))
+ _ (///directive.lift_generation
+ (///generation.set_registry temporary_registry))
+ _ (|> requirements
+ (get@ #///directive.referrals)
+ (monad.map ! (execute! archive)))
+ temporary_payload (..get_current_payload temporary_payload)]
+ (..iterate archive expander module source temporary_payload (..module_aliases analysis_module))))))})]))
+ )))))}))))
diff --git a/stdlib/source/library/lux/tool/compiler/default/platform.lux b/stdlib/source/library/lux/tool/compiler/default/platform.lux
new file mode 100644
index 000000000..9ebf79b7b
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/default/platform.lux
@@ -0,0 +1,602 @@
+(.module:
+ [library
+ [lux (#- Module)
+ [type (#+ :share)]
+ ["." debug]
+ ["@" target]
+ [abstract
+ ["." monad (#+ Monad do)]]
+ [control
+ ["." function]
+ ["." try (#+ Try) ("#\." functor)]
+ ["." exception (#+ exception:)]
+ [concurrency
+ ["." promise (#+ Promise Resolver) ("#\." monad)]
+ ["." stm (#+ Var STM)]]]
+ [data
+ ["." binary (#+ Binary)]
+ ["." bit]
+ ["." product]
+ ["." maybe]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary (#+ Dictionary)]
+ ["." row (#+ Row) ("#\." fold)]
+ ["." set (#+ Set)]
+ ["." list ("#\." monoid functor fold)]]
+ [format
+ ["_" binary (#+ Writer)]]]
+ [world
+ ["." file (#+ Path)]]]]
+ ["." // #_
+ ["#." init]
+ ["/#" //
+ ["#." phase (#+ Phase)]
+ [language
+ [lux
+ [program (#+ Program)]
+ ["$" /]
+ ["#." version]
+ ["." syntax]
+ ["#." analysis
+ [macro (#+ Expander)]]
+ ["#." synthesis]
+ ["#." generation (#+ Buffer)]
+ ["#." directive]
+ [phase
+ ["." extension (#+ Extender)]
+ [analysis
+ ["." module]]]]]
+ [meta
+ ["." archive (#+ Output Archive)
+ ["." artifact (#+ Registry)]
+ ["." descriptor (#+ Descriptor Module)]
+ ["." document (#+ Document)]]
+ [io (#+ Context)
+ ["." context]
+ ["ioW" archive]]]]]
+ [program
+ [compositor
+ ["." cli (#+ Compilation Library)]
+ ["." static (#+ Static)]
+ ["." import (#+ Import)]]])
+
+(with_expansions [<type_vars> (as_is anchor expression directive)
+ <Operation> (as_is ///generation.Operation <type_vars>)]
+ (type: #export Phase_Wrapper
+ (All [s i o] (-> (Phase s i o) Any)))
+
+ (type: #export (Platform <type_vars>)
+ {#&file_system (file.System Promise)
+ #host (///generation.Host expression directive)
+ #phase (///generation.Phase <type_vars>)
+ #runtime (<Operation> [Registry Output])
+ #phase_wrapper (-> Archive (<Operation> Phase_Wrapper))
+ #write (-> directive Binary)})
+
+ ## TODO: Get rid of this
+ (type: (Action a)
+ (Promise (Try a)))
+
+ ## TODO: Get rid of this
+ (def: monad
+ (:as (Monad Action)
+ (try.with promise.monad)))
+
+ (with_expansions [<Platform> (as_is (Platform <type_vars>))
+ <State+> (as_is (///directive.State+ <type_vars>))
+ <Bundle> (as_is (///generation.Bundle <type_vars>))]
+
+ (def: writer
+ (Writer [Descriptor (Document .Module)])
+ (_.and descriptor.writer
+ (document.writer $.writer)))
+
+ (def: (cache_module static platform module_id [descriptor document output])
+ (All [<type_vars>]
+ (-> Static <Platform> archive.ID [Descriptor (Document Any) Output]
+ (Promise (Try Any))))
+ (let [system (get@ #&file_system platform)
+ write_artifact! (: (-> [artifact.ID Binary] (Action Any))
+ (function (_ [artifact_id content])
+ (ioW.write system static module_id artifact_id content)))]
+ (do {! ..monad}
+ [_ (ioW.prepare system static module_id)
+ _ (for {@.python (|> output
+ row.to_list
+ (list.chunk 128)
+ (monad.map ! (monad.map ! write_artifact!))
+ (: (Action (List (List Any)))))}
+ (|> output
+ row.to_list
+ (monad.map ..monad write_artifact!)
+ (: (Action (List Any)))))
+ document (\ promise.monad wrap
+ (document.check $.key document))]
+ (ioW.cache system static module_id
+ (_.run ..writer [descriptor document])))))
+
+ ## TODO: Inline ASAP
+ (def: initialize_buffer!
+ (All [<type_vars>]
+ (///generation.Operation <type_vars> Any))
+ (///generation.set_buffer ///generation.empty_buffer))
+
+ ## TODO: Inline ASAP
+ (def: (compile_runtime! platform)
+ (All [<type_vars>]
+ (-> <Platform> (///generation.Operation <type_vars> [Registry Output])))
+ (do ///phase.monad
+ [_ ..initialize_buffer!]
+ (get@ #runtime platform)))
+
+ (def: (runtime_descriptor registry)
+ (-> Registry Descriptor)
+ {#descriptor.hash 0
+ #descriptor.name archive.runtime_module
+ #descriptor.file ""
+ #descriptor.references (set.new text.hash)
+ #descriptor.state #.Compiled
+ #descriptor.registry registry})
+
+ (def: runtime_document
+ (Document .Module)
+ (document.write $.key (module.new 0)))
+
+ (def: (process_runtime archive platform)
+ (All [<type_vars>]
+ (-> Archive <Platform>
+ (///directive.Operation <type_vars>
+ [Archive [Descriptor (Document .Module) Output]])))
+ (do ///phase.monad
+ [[registry payload] (///directive.lift_generation
+ (..compile_runtime! platform))
+ #let [[descriptor document] [(..runtime_descriptor registry) ..runtime_document]]
+ archive (///phase.lift (if (archive.reserved? archive archive.runtime_module)
+ (archive.add archive.runtime_module [descriptor document payload] archive)
+ (do try.monad
+ [[_ archive] (archive.reserve archive.runtime_module archive)]
+ (archive.add archive.runtime_module [descriptor document payload] archive))))]
+ (wrap [archive [descriptor document payload]])))
+
+ (def: (initialize_state extender
+ [analysers
+ synthesizers
+ generators
+ directives]
+ analysis_state
+ state)
+ (All [<type_vars>]
+ (-> Extender
+ [(Dictionary Text ///analysis.Handler)
+ (Dictionary Text ///synthesis.Handler)
+ (Dictionary Text (///generation.Handler <type_vars>))
+ (Dictionary Text (///directive.Handler <type_vars>))]
+ .Lux
+ <State+>
+ (Try <State+>)))
+ (|> (:share [<type_vars>]
+ <State+>
+ state
+
+ (///directive.Operation <type_vars> Any)
+ (do ///phase.monad
+ [_ (///directive.lift_analysis
+ (///analysis.install analysis_state))
+ _ (///directive.lift_analysis
+ (extension.with extender analysers))
+ _ (///directive.lift_synthesis
+ (extension.with extender synthesizers))
+ _ (///directive.lift_generation
+ (extension.with extender (:assume generators)))
+ _ (extension.with extender (:assume directives))]
+ (wrap [])))
+ (///phase.run' state)
+ (\ try.monad map product.left)))
+
+ (def: (phase_wrapper archive platform state)
+ (All [<type_vars>]
+ (-> Archive <Platform> <State+> (Try [<State+> Phase_Wrapper])))
+ (let [phase_wrapper (get@ #phase_wrapper platform)]
+ (|> archive
+ phase_wrapper
+ ///directive.lift_generation
+ (///phase.run' state))))
+
+ (def: (complete_extensions host_directive_bundle phase_wrapper [analysers synthesizers generators directives])
+ (All [<type_vars>]
+ (-> (-> Phase_Wrapper (///directive.Bundle <type_vars>))
+ Phase_Wrapper
+ [(Dictionary Text ///analysis.Handler)
+ (Dictionary Text ///synthesis.Handler)
+ (Dictionary Text (///generation.Handler <type_vars>))
+ (Dictionary Text (///directive.Handler <type_vars>))]
+ [(Dictionary Text ///analysis.Handler)
+ (Dictionary Text ///synthesis.Handler)
+ (Dictionary Text (///generation.Handler <type_vars>))
+ (Dictionary Text (///directive.Handler <type_vars>))]))
+ [analysers
+ synthesizers
+ generators
+ (dictionary.merge directives (host_directive_bundle phase_wrapper))])
+
+ (def: #export (initialize static module expander host_analysis platform generation_bundle host_directive_bundle program anchorT,expressionT,directiveT extender
+ import compilation_sources)
+ (All [<type_vars>]
+ (-> Static
+ Module
+ Expander
+ ///analysis.Bundle
+ <Platform>
+ <Bundle>
+ (-> Phase_Wrapper (///directive.Bundle <type_vars>))
+ (Program expression directive)
+ [Type Type Type] (-> Phase_Wrapper Extender)
+ Import (List Context)
+ (Promise (Try [<State+> Archive]))))
+ (do {! (try.with promise.monad)}
+ [#let [state (//init.state (get@ #static.host static)
+ module
+ expander
+ host_analysis
+ (get@ #host platform)
+ (get@ #phase platform)
+ generation_bundle)]
+ _ (ioW.enable (get@ #&file_system platform) static)
+ [archive analysis_state bundles] (ioW.thaw (get@ #host platform) (get@ #&file_system platform) static import compilation_sources)
+ #let [with_missing_extensions
+ (: (All [<type_vars>]
+ (-> <Platform> (Program expression directive) <State+> (Promise (Try <State+>))))
+ (function (_ platform program state)
+ (promise\wrap
+ (do try.monad
+ [[state phase_wrapper] (..phase_wrapper archive platform state)]
+ (|> state
+ (initialize_state (extender phase_wrapper)
+ (:assume (..complete_extensions host_directive_bundle phase_wrapper (:assume bundles)))
+ analysis_state)
+ (try\map (//init.with_default_directives expander host_analysis program anchorT,expressionT,directiveT (extender phase_wrapper))))))))]]
+ (if (archive.archived? archive archive.runtime_module)
+ (do !
+ [state (with_missing_extensions platform program state)]
+ (wrap [state archive]))
+ (do !
+ [[state [archive payload]] (|> (..process_runtime archive platform)
+ (///phase.run' state)
+ promise\wrap)
+ _ (..cache_module static platform 0 payload)
+
+ state (with_missing_extensions platform program state)]
+ (wrap [state archive])))))
+
+ (def: compilation_log_separator
+ (format text.new_line text.tab))
+
+ (def: (module_compilation_log module)
+ (All [<type_vars>]
+ (-> Module <State+> Text))
+ (|>> (get@ [#extension.state
+ #///directive.generation
+ #///directive.state
+ #extension.state
+ #///generation.log])
+ (row\fold (function (_ right left)
+ (format left ..compilation_log_separator right))
+ module)))
+
+ (def: with_reset_log
+ (All [<type_vars>]
+ (-> <State+> <State+>))
+ (set@ [#extension.state
+ #///directive.generation
+ #///directive.state
+ #extension.state
+ #///generation.log]
+ row.empty))
+
+ (def: empty
+ (Set Module)
+ (set.new text.hash))
+
+ (type: Mapping
+ (Dictionary Module (Set Module)))
+
+ (type: Dependence
+ {#depends_on Mapping
+ #depended_by Mapping})
+
+ (def: independence
+ Dependence
+ (let [empty (dictionary.new text.hash)]
+ {#depends_on empty
+ #depended_by empty}))
+
+ (def: (depend module import dependence)
+ (-> Module Module Dependence Dependence)
+ (let [transitive_dependency (: (-> (-> Dependence Mapping) Module (Set Module))
+ (function (_ lens module)
+ (|> dependence
+ lens
+ (dictionary.get module)
+ (maybe.default ..empty))))
+ transitive_depends_on (transitive_dependency (get@ #depends_on) import)
+ transitive_depended_by (transitive_dependency (get@ #depended_by) module)
+ update_dependence (: (-> [Module (Set Module)] [Module (Set Module)]
+ (-> Mapping Mapping))
+ (function (_ [source forward] [target backward])
+ (function (_ mapping)
+ (let [with_dependence+transitives
+ (|> mapping
+ (dictionary.upsert source ..empty (set.add target))
+ (dictionary.update source (set.union forward)))]
+ (list\fold (function (_ previous)
+ (dictionary.upsert previous ..empty (set.add target)))
+ with_dependence+transitives
+ (set.to_list backward))))))]
+ (|> dependence
+ (update@ #depends_on
+ (update_dependence
+ [module transitive_depends_on]
+ [import transitive_depended_by]))
+ (update@ #depended_by
+ ((function.flip update_dependence)
+ [module transitive_depends_on]
+ [import transitive_depended_by])))))
+
+ (def: (circular_dependency? module import dependence)
+ (-> Module Module Dependence Bit)
+ (let [dependence? (: (-> Module (-> Dependence Mapping) Module Bit)
+ (function (_ from relationship to)
+ (let [targets (|> dependence
+ relationship
+ (dictionary.get from)
+ (maybe.default ..empty))]
+ (set.member? targets to))))]
+ (or (dependence? import (get@ #depends_on) module)
+ (dependence? module (get@ #depended_by) import))))
+
+ (exception: #export (module_cannot_import_itself {module Module})
+ (exception.report
+ ["Module" (%.text module)]))
+
+ (exception: #export (cannot_import_circular_dependency {importer Module}
+ {importee Module})
+ (exception.report
+ ["Importer" (%.text importer)]
+ ["importee" (%.text importee)]))
+
+ (def: (verify_dependencies importer importee dependence)
+ (-> Module Module Dependence (Try Any))
+ (cond (text\= importer importee)
+ (exception.throw ..module_cannot_import_itself [importer])
+
+ (..circular_dependency? importer importee dependence)
+ (exception.throw ..cannot_import_circular_dependency [importer importee])
+
+ ## else
+ (#try.Success [])))
+
+ (with_expansions [<Context> (as_is [Archive <State+>])
+ <Result> (as_is (Try <Context>))
+ <Return> (as_is (Promise <Result>))
+ <Signal> (as_is (Resolver <Result>))
+ <Pending> (as_is [<Return> <Signal>])
+ <Importer> (as_is (-> Module Module <Return>))
+ <Compiler> (as_is (-> Module <Importer> archive.ID <Context> Module <Return>))]
+ (def: (parallel initial)
+ (All [<type_vars>]
+ (-> <Context>
+ (-> <Compiler> <Importer>)))
+ (let [current (stm.var initial)
+ pending (:share [<type_vars>]
+ <Context>
+ initial
+
+ (Var (Dictionary Module <Pending>))
+ (:assume (stm.var (dictionary.new text.hash))))
+ dependence (: (Var Dependence)
+ (stm.var ..independence))]
+ (function (_ compile)
+ (function (import! importer module)
+ (do {! promise.monad}
+ [[return signal] (:share [<type_vars>]
+ <Context>
+ initial
+
+ (Promise [<Return> (Maybe [<Context>
+ archive.ID
+ <Signal>])])
+ (:assume
+ (stm.commit
+ (do {! stm.monad}
+ [dependence (if (text\= archive.runtime_module importer)
+ (stm.read dependence)
+ (do !
+ [[_ dependence] (stm.update (..depend importer module) dependence)]
+ (wrap dependence)))]
+ (case (..verify_dependencies importer module dependence)
+ (#try.Failure error)
+ (wrap [(promise.resolved (#try.Failure error))
+ #.None])
+
+ (#try.Success _)
+ (do !
+ [[archive state] (stm.read current)]
+ (if (archive.archived? archive module)
+ (wrap [(promise\wrap (#try.Success [archive state]))
+ #.None])
+ (do !
+ [@pending (stm.read pending)]
+ (case (dictionary.get module @pending)
+ (#.Some [return signal])
+ (wrap [return
+ #.None])
+
+ #.None
+ (case (if (archive.reserved? archive module)
+ (do try.monad
+ [module_id (archive.id module archive)]
+ (wrap [module_id archive]))
+ (archive.reserve module archive))
+ (#try.Success [module_id archive])
+ (do !
+ [_ (stm.write [archive state] current)
+ #let [[return signal] (:share [<type_vars>]
+ <Context>
+ initial
+
+ <Pending>
+ (promise.promise []))]
+ _ (stm.update (dictionary.put module [return signal]) pending)]
+ (wrap [return
+ (#.Some [[archive state]
+ module_id
+ signal])]))
+
+ (#try.Failure error)
+ (wrap [(promise\wrap (#try.Failure error))
+ #.None])))))))))))
+ _ (case signal
+ #.None
+ (wrap [])
+
+ (#.Some [context module_id resolver])
+ (do !
+ [result (compile importer import! module_id context module)
+ result (case result
+ (#try.Failure error)
+ (wrap result)
+
+ (#try.Success [resulting_archive resulting_state])
+ (stm.commit (do stm.monad
+ [[_ [merged_archive _]] (stm.update (function (_ [archive state])
+ [(archive.merge resulting_archive archive)
+ state])
+ current)]
+ (wrap (#try.Success [merged_archive resulting_state])))))
+ _ (promise.future (resolver result))]
+ (wrap [])))]
+ return)))))
+
+ ## TODO: Find a better way, as this only works for the Lux compiler.
+ (def: (updated_state archive state)
+ (All [<type_vars>]
+ (-> Archive <State+> (Try <State+>)))
+ (do {! try.monad}
+ [modules (monad.map ! (function (_ module)
+ (do !
+ [[descriptor document output] (archive.find module archive)
+ lux_module (document.read $.key document)]
+ (wrap [module lux_module])))
+ (archive.archived archive))
+ #let [additions (|> modules
+ (list\map product.left)
+ (set.from_list text.hash))]]
+ (wrap (update@ [#extension.state
+ #///directive.analysis
+ #///directive.state
+ #extension.state]
+ (function (_ analysis_state)
+ (|> analysis_state
+ (:as .Lux)
+ (update@ #.modules (function (_ current)
+ (list\compose (list.filter (|>> product.left
+ (set.member? additions)
+ not)
+ current)
+ modules)))
+ :assume))
+ state))))
+
+ (def: (set_current_module module state)
+ (All [<type_vars>]
+ (-> Module <State+> <State+>))
+ (|> (///directive.set_current_module module)
+ (///phase.run' state)
+ try.assume
+ product.left))
+
+ (def: #export (compile import static expander platform compilation context)
+ (All [<type_vars>]
+ (-> Import Static Expander <Platform> Compilation <Context> <Return>))
+ (let [[compilation_sources compilation_libraries compilation_target compilation_module] compilation
+ base_compiler (:share [<type_vars>]
+ <Context>
+ context
+
+ (///.Compiler <State+> .Module Any)
+ (:assume
+ ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list))))
+ compiler (..parallel
+ context
+ (function (_ importer import! module_id [archive state] module)
+ (do {! (try.with promise.monad)}
+ [#let [state (..set_current_module module state)]
+ input (context.read (get@ #&file_system platform)
+ importer
+ import
+ compilation_sources
+ (get@ #static.host_module_extension static)
+ module)]
+ (loop [[archive state] [archive state]
+ compilation (base_compiler (:as ///.Input input))
+ all_dependencies (: (List Module)
+ (list))]
+ (let [new_dependencies (get@ #///.dependencies compilation)
+ all_dependencies (list\compose new_dependencies all_dependencies)
+ continue! (:share [<type_vars>]
+ <Platform>
+ platform
+
+ (-> <Context> (///.Compilation <State+> .Module Any) (List Module)
+ (Action [Archive <State+>]))
+ (:assume
+ recur))]
+ (do !
+ [[archive state] (case new_dependencies
+ #.Nil
+ (wrap [archive state])
+
+ (#.Cons _)
+ (do !
+ [archive,document+ (|> new_dependencies
+ (list\map (import! module))
+ (monad.seq ..monad))
+ #let [archive (|> archive,document+
+ (list\map product.left)
+ (list\fold archive.merge archive))]]
+ (wrap [archive (try.assume
+ (..updated_state archive state))])))]
+ (case ((get@ #///.process compilation)
+ ## TODO: The "///directive.set_current_module" below shouldn't be necessary. Remove it ASAP.
+ ## TODO: The context shouldn't need to be re-set either.
+ (|> (///directive.set_current_module module)
+ (///phase.run' state)
+ try.assume
+ product.left)
+ archive)
+ (#try.Success [state more|done])
+ (case more|done
+ (#.Left more)
+ (continue! [archive state] more all_dependencies)
+
+ (#.Right [descriptor document output])
+ (do !
+ [#let [_ (debug.log! (..module_compilation_log module state))
+ descriptor (set@ #descriptor.references (set.from_list text.hash all_dependencies) descriptor)]
+ _ (..cache_module static platform module_id [descriptor document output])]
+ (case (archive.add module [descriptor document output] archive)
+ (#try.Success archive)
+ (wrap [archive
+ (..with_reset_log state)])
+
+ (#try.Failure error)
+ (promise\wrap (#try.Failure error)))))
+
+ (#try.Failure error)
+ (do !
+ [_ (ioW.freeze (get@ #&file_system platform) static archive)]
+ (promise\wrap (#try.Failure error))))))))))]
+ (compiler archive.runtime_module compilation_module)))
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux.lux
new file mode 100644
index 000000000..e6d5816a4
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux.lux
@@ -0,0 +1,107 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ ["<>" parser
+ ["<b>" binary (#+ Parser)]]]
+ [data
+ [format
+ ["_" binary (#+ Writer)]]]]]
+ ["." / #_
+ ["#." version]
+ [phase
+ [analysis
+ ["." module]]]
+ [///
+ [meta
+ [archive
+ ["." signature]
+ ["." key (#+ Key)]]]]])
+
+## TODO: Remove #module_hash, #imports & #module_state ASAP.
+## TODO: Not just from this parser, but from the lux.Module type.
+(def: #export writer
+ (Writer .Module)
+ (let [definition (: (Writer Definition)
+ ($_ _.and _.bit _.type _.code _.any))
+ name (: (Writer Name)
+ (_.and _.text _.text))
+ alias (: (Writer Alias)
+ (_.and _.text _.text))
+ global (: (Writer Global)
+ (_.or alias
+ definition))
+ tag (: (Writer [Nat (List Name) Bit Type])
+ ($_ _.and
+ _.nat
+ (_.list name)
+ _.bit
+ _.type))
+ type (: (Writer [(List Name) Bit Type])
+ ($_ _.and
+ (_.list name)
+ _.bit
+ _.type))]
+ ($_ _.and
+ ## #module_hash
+ _.nat
+ ## #module_aliases
+ (_.list alias)
+ ## #definitions
+ (_.list (_.and _.text global))
+ ## #imports
+ (_.list _.text)
+ ## #tags
+ (_.list (_.and _.text tag))
+ ## #types
+ (_.list (_.and _.text type))
+ ## #module_annotations
+ (_.maybe _.code)
+ ## #module_state
+ _.any)))
+
+(def: #export parser
+ (Parser .Module)
+ (let [definition (: (Parser Definition)
+ ($_ <>.and <b>.bit <b>.type <b>.code <b>.any))
+ name (: (Parser Name)
+ (<>.and <b>.text <b>.text))
+ alias (: (Parser Alias)
+ (<>.and <b>.text <b>.text))
+ global (: (Parser Global)
+ (<b>.or alias
+ definition))
+ tag (: (Parser [Nat (List Name) Bit Type])
+ ($_ <>.and
+ <b>.nat
+ (<b>.list name)
+ <b>.bit
+ <b>.type))
+ type (: (Parser [(List Name) Bit Type])
+ ($_ <>.and
+ (<b>.list name)
+ <b>.bit
+ <b>.type))]
+ ($_ <>.and
+ ## #module_hash
+ <b>.nat
+ ## #module_aliases
+ (<b>.list alias)
+ ## #definitions
+ (<b>.list (<>.and <b>.text global))
+ ## #imports
+ (<b>.list <b>.text)
+ ## #tags
+ (<b>.list (<>.and <b>.text tag))
+ ## #types
+ (<b>.list (<>.and <b>.text type))
+ ## #module_annotations
+ (<b>.maybe <b>.code)
+ ## #module_state
+ (\ <>.monad wrap #.Cached))))
+
+(def: #export key
+ (Key .Module)
+ (key.key {#signature.name (name_of ..compiler)
+ #signature.version /version.version}
+ (module.new 0)))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis.lux
new file mode 100644
index 000000000..c29eaaf54
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis.lux
@@ -0,0 +1,556 @@
+(.module:
+ [library
+ [lux (#- nat int rev)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]
+ [monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try]
+ ["." exception (#+ Exception)]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." bit ("#\." equivalence)]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ Format format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]
+ ["r" rev]
+ ["f" frac]]]
+ [meta
+ ["." location]]]]
+ [//
+ [phase
+ ["." extension (#+ Extension)]]
+ [///
+ [arity (#+ Arity)]
+ [version (#+ Version)]
+ ["." phase]
+ ["." reference (#+ Reference)
+ ["." variable (#+ Register Variable)]]]])
+
+(type: #export #rec Primitive
+ #Unit
+ (#Bit Bit)
+ (#Nat Nat)
+ (#Int Int)
+ (#Rev Rev)
+ (#Frac Frac)
+ (#Text Text))
+
+(type: #export Tag
+ Nat)
+
+(type: #export (Variant a)
+ {#lefts Nat
+ #right? Bit
+ #value a})
+
+(def: #export (tag lefts right?)
+ (-> Nat Bit Nat)
+ (if right?
+ (inc lefts)
+ lefts))
+
+(def: (lefts tag right?)
+ (-> Nat Bit Nat)
+ (if right?
+ (dec tag)
+ tag))
+
+(def: #export (choice options pick)
+ (-> Nat Nat [Nat Bit])
+ (let [right? (n.= (dec options) pick)]
+ [(..lefts pick right?)
+ right?]))
+
+(type: #export (Tuple a)
+ (List a))
+
+(type: #export (Composite a)
+ (#Variant (Variant a))
+ (#Tuple (Tuple a)))
+
+(type: #export #rec Pattern
+ (#Simple Primitive)
+ (#Complex (Composite Pattern))
+ (#Bind Register))
+
+(type: #export (Branch' e)
+ {#when Pattern
+ #then e})
+
+(type: #export (Match' e)
+ [(Branch' e) (List (Branch' e))])
+
+(type: #export (Environment a)
+ (List a))
+
+(type: #export #rec Analysis
+ (#Primitive Primitive)
+ (#Structure (Composite Analysis))
+ (#Reference Reference)
+ (#Case Analysis (Match' Analysis))
+ (#Function (Environment Analysis) Analysis)
+ (#Apply Analysis Analysis)
+ (#Extension (Extension Analysis)))
+
+(type: #export Branch
+ (Branch' Analysis))
+
+(type: #export Match
+ (Match' Analysis))
+
+(implementation: primitive_equivalence
+ (Equivalence Primitive)
+
+ (def: (= reference sample)
+ (case [reference sample]
+ [#Unit #Unit]
+ true
+
+ (^template [<tag> <=>]
+ [[(<tag> reference) (<tag> sample)]
+ (<=> reference sample)])
+ ([#Bit bit\=]
+ [#Nat n.=]
+ [#Int i.=]
+ [#Rev r.=]
+ [#Frac f.=]
+ [#Text text\=])
+
+ _
+ false)))
+
+(implementation: #export (composite_equivalence (^open "/\."))
+ (All [a] (-> (Equivalence a) (Equivalence (Composite a))))
+
+ (def: (= reference sample)
+ (case [reference sample]
+ [(#Variant [reference_lefts reference_right? reference_value])
+ (#Variant [sample_lefts sample_right? sample_value])]
+ (and (n.= reference_lefts sample_lefts)
+ (bit\= reference_right? sample_right?)
+ (/\= reference_value sample_value))
+
+ [(#Tuple reference) (#Tuple sample)]
+ (\ (list.equivalence /\=) = reference sample)
+
+ _
+ false)))
+
+(implementation: #export (composite_hash super)
+ (All [a] (-> (Hash a) (Hash (Composite a))))
+
+ (def: &equivalence
+ (..composite_equivalence (\ super &equivalence)))
+
+ (def: (hash value)
+ (case value
+ (#Variant [lefts right? value])
+ ($_ n.* 2
+ (\ n.hash hash lefts)
+ (\ bit.hash hash right?)
+ (\ super hash value))
+
+ (#Tuple members)
+ ($_ n.* 3
+ (\ (list.hash super) hash members))
+ )))
+
+(implementation: pattern_equivalence
+ (Equivalence Pattern)
+
+ (def: (= reference sample)
+ (case [reference sample]
+ [(#Simple reference) (#Simple sample)]
+ (\ primitive_equivalence = reference sample)
+
+ [(#Complex reference) (#Complex sample)]
+ (\ (composite_equivalence =) = reference sample)
+
+ [(#Bind reference) (#Bind sample)]
+ (n.= reference sample)
+
+ _
+ false)))
+
+(implementation: (branch_equivalence equivalence)
+ (-> (Equivalence Analysis) (Equivalence Branch))
+
+ (def: (= [reference_pattern reference_body] [sample_pattern sample_body])
+ (and (\ pattern_equivalence = reference_pattern sample_pattern)
+ (\ equivalence = reference_body sample_body))))
+
+(implementation: #export equivalence
+ (Equivalence Analysis)
+
+ (def: (= reference sample)
+ (case [reference sample]
+ [(#Primitive reference) (#Primitive sample)]
+ (\ primitive_equivalence = reference sample)
+
+ [(#Structure reference) (#Structure sample)]
+ (\ (composite_equivalence =) = reference sample)
+
+ [(#Reference reference) (#Reference sample)]
+ (\ reference.equivalence = reference sample)
+
+ [(#Case [reference_analysis reference_match])
+ (#Case [sample_analysis sample_match])]
+ (and (= reference_analysis sample_analysis)
+ (\ (list.equivalence (branch_equivalence =)) = (#.Cons reference_match) (#.Cons sample_match)))
+
+ [(#Function [reference_environment reference_analysis])
+ (#Function [sample_environment sample_analysis])]
+ (and (= reference_analysis sample_analysis)
+ (\ (list.equivalence =) = reference_environment sample_environment))
+
+ [(#Apply [reference_input reference_abstraction])
+ (#Apply [sample_input sample_abstraction])]
+ (and (= reference_input sample_input)
+ (= reference_abstraction sample_abstraction))
+
+ [(#Extension reference) (#Extension sample)]
+ (\ (extension.equivalence =) = reference sample)
+
+ _
+ false)))
+
+(template [<name> <tag>]
+ [(template: #export (<name> content)
+ (<tag> content))]
+
+ [control/case #..Case]
+ )
+
+(template: #export (unit)
+ (#..Primitive #..Unit))
+
+(template [<name> <tag>]
+ [(template: #export (<name> value)
+ (#..Primitive (<tag> value)))]
+
+ [bit #..Bit]
+ [nat #..Nat]
+ [int #..Int]
+ [rev #..Rev]
+ [frac #..Frac]
+ [text #..Text]
+ )
+
+(type: #export (Abstraction c)
+ [(Environment c) Arity c])
+
+(type: #export (Application c)
+ [c (List c)])
+
+(def: (last? size tag)
+ (-> Nat Tag Bit)
+ (n.= (dec size) tag))
+
+(template: #export (no_op value)
+ (|> 1 #variable.Local #reference.Variable #..Reference
+ (#..Function (list))
+ (#..Apply value)))
+
+(def: #export (apply [abstraction inputs])
+ (-> (Application Analysis) Analysis)
+ (list\fold (function (_ input abstraction')
+ (#Apply input abstraction'))
+ abstraction
+ inputs))
+
+(def: #export (application analysis)
+ (-> Analysis (Application Analysis))
+ (loop [abstraction analysis
+ inputs (list)]
+ (case abstraction
+ (#Apply input next)
+ (recur next (#.Cons input inputs))
+
+ _
+ [abstraction inputs])))
+
+(template [<name> <tag>]
+ [(template: #export (<name> content)
+ (.<| #..Reference
+ <tag>
+ content))]
+
+ [variable #reference.Variable]
+ [constant #reference.Constant]
+
+ [variable/local reference.local]
+ [variable/foreign reference.foreign]
+ )
+
+(template [<name> <tag>]
+ [(template: #export (<name> content)
+ (.<| #..Complex
+ <tag>
+ content))]
+
+ [pattern/variant #..Variant]
+ [pattern/tuple #..Tuple]
+ )
+
+(template [<name> <tag>]
+ [(template: #export (<name> content)
+ (.<| #..Structure
+ <tag>
+ content))]
+
+ [variant #..Variant]
+ [tuple #..Tuple]
+ )
+
+(template: #export (pattern/unit)
+ (#..Simple #..Unit))
+
+(template [<name> <tag>]
+ [(template: #export (<name> content)
+ (#..Simple (<tag> content)))]
+
+ [pattern/bit #..Bit]
+ [pattern/nat #..Nat]
+ [pattern/int #..Int]
+ [pattern/rev #..Rev]
+ [pattern/frac #..Frac]
+ [pattern/text #..Text]
+ )
+
+(template: #export (pattern/bind register)
+ (#..Bind register))
+
+(def: #export (%analysis analysis)
+ (Format Analysis)
+ (case analysis
+ (#Primitive primitive)
+ (case primitive
+ #Unit
+ "[]"
+
+ (^template [<tag> <format>]
+ [(<tag> value)
+ (<format> value)])
+ ([#Bit %.bit]
+ [#Nat %.nat]
+ [#Int %.int]
+ [#Rev %.rev]
+ [#Frac %.frac]
+ [#Text %.text]))
+
+ (#Structure structure)
+ (case structure
+ (#Variant [lefts right? value])
+ (format "(" (%.nat lefts) " " (%.bit right?) " " (%analysis value) ")")
+
+ (#Tuple members)
+ (|> members
+ (list\map %analysis)
+ (text.join_with " ")
+ (text.enclose ["[" "]"])))
+
+ (#Reference reference)
+ (reference.format reference)
+
+ (#Case analysis match)
+ "{?}"
+
+ (#Function environment body)
+ (|> (%analysis body)
+ (format " ")
+ (format (|> environment
+ (list\map %analysis)
+ (text.join_with " ")
+ (text.enclose ["[" "]"])))
+ (text.enclose ["(" ")"]))
+
+ (#Apply _)
+ (|> analysis
+ ..application
+ #.Cons
+ (list\map %analysis)
+ (text.join_with " ")
+ (text.enclose ["(" ")"]))
+
+ (#Extension name parameters)
+ (|> parameters
+ (list\map %analysis)
+ (text.join_with " ")
+ (format (%.text name) " ")
+ (text.enclose ["(" ")"]))))
+
+(template [<special> <general>]
+ [(type: #export <special>
+ (<general> .Lux Code Analysis))]
+
+ [State+ extension.State]
+ [Operation extension.Operation]
+ [Phase extension.Phase]
+ [Handler extension.Handler]
+ [Bundle extension.Bundle]
+ )
+
+(def: #export (with_source_code source action)
+ (All [a] (-> Source (Operation a) (Operation a)))
+ (function (_ [bundle state])
+ (let [old_source (get@ #.source state)]
+ (case (action [bundle (set@ #.source source state)])
+ (#try.Success [[bundle' state'] output])
+ (#try.Success [[bundle' (set@ #.source old_source state')]
+ output])
+
+ (#try.Failure error)
+ (#try.Failure error)))))
+
+(def: fresh_bindings
+ (All [k v] (Bindings k v))
+ {#.counter 0
+ #.mappings (list)})
+
+(def: fresh_scope
+ Scope
+ {#.name (list)
+ #.inner 0
+ #.locals fresh_bindings
+ #.captured fresh_bindings})
+
+(def: #export (with_scope action)
+ (All [a] (-> (Operation a) (Operation [Scope a])))
+ (function (_ [bundle state])
+ (case (action [bundle (update@ #.scopes (|>> (#.Cons fresh_scope)) state)])
+ (#try.Success [[bundle' state'] output])
+ (case (get@ #.scopes state')
+ (#.Cons head tail)
+ (#try.Success [[bundle' (set@ #.scopes tail state')]
+ [head output]])
+
+ #.Nil
+ (#try.Failure "Impossible error: Drained scopes!"))
+
+ (#try.Failure error)
+ (#try.Failure error))))
+
+(def: #export (with_current_module name)
+ (All [a] (-> Text (Operation a) (Operation a)))
+ (extension.localized (get@ #.current_module)
+ (set@ #.current_module)
+ (function.constant (#.Some name))))
+
+(def: #export (with_location location action)
+ (All [a] (-> Location (Operation a) (Operation a)))
+ (if (text\= "" (product.left location))
+ action
+ (function (_ [bundle state])
+ (let [old_location (get@ #.location state)]
+ (case (action [bundle (set@ #.location location state)])
+ (#try.Success [[bundle' state'] output])
+ (#try.Success [[bundle' (set@ #.location old_location state')]
+ output])
+
+ (#try.Failure error)
+ (#try.Failure error))))))
+
+(def: (locate_error location error)
+ (-> Location Text Text)
+ (format (%.location location) text.new_line
+ error))
+
+(def: #export (fail error)
+ (-> Text Operation)
+ (function (_ [bundle state])
+ (#try.Failure (locate_error (get@ #.location state) error))))
+
+(def: #export (throw exception parameters)
+ (All [e] (-> (Exception e) e Operation))
+ (..fail (exception.construct exception parameters)))
+
+(def: #export (assert exception parameters condition)
+ (All [e] (-> (Exception e) e Bit (Operation Any)))
+ (if condition
+ (\ phase.monad wrap [])
+ (..throw exception parameters)))
+
+(def: #export (fail' error)
+ (-> Text (phase.Operation Lux))
+ (function (_ state)
+ (#try.Failure (locate_error (get@ #.location state) error))))
+
+(def: #export (throw' exception parameters)
+ (All [e] (-> (Exception e) e (phase.Operation Lux)))
+ (..fail' (exception.construct exception parameters)))
+
+(def: #export (with_stack exception message action)
+ (All [e o] (-> (Exception e) e (Operation o) (Operation o)))
+ (function (_ bundle,state)
+ (case (exception.with exception message
+ (action bundle,state))
+ (#try.Success output)
+ (#try.Success output)
+
+ (#try.Failure error)
+ (let [[bundle state] bundle,state]
+ (#try.Failure (locate_error (get@ #.location state) error))))))
+
+(def: #export (install state)
+ (-> .Lux (Operation Any))
+ (function (_ [bundle _])
+ (#try.Success [[bundle state]
+ []])))
+
+(template [<name> <type> <field> <value>]
+ [(def: #export (<name> value)
+ (-> <type> (Operation Any))
+ (extension.update (set@ <field> <value>)))]
+
+ [set_source_code Source #.source value]
+ [set_current_module Text #.current_module (#.Some value)]
+ [set_location Location #.location value]
+ )
+
+(def: #export (location file)
+ (-> Text Location)
+ [file 1 0])
+
+(def: #export (source file code)
+ (-> Text Text Source)
+ [(location file) 0 code])
+
+(def: dummy_source
+ Source
+ [location.dummy 0 ""])
+
+(def: type_context
+ Type_Context
+ {#.ex_counter 0
+ #.var_counter 0
+ #.var_bindings (list)})
+
+(def: #export (info version host)
+ (-> Version Text Info)
+ {#.target host
+ #.version (%.nat version)
+ #.mode #.Build})
+
+(def: #export (state info)
+ (-> Info Lux)
+ {#.info info
+ #.source ..dummy_source
+ #.location location.dummy
+ #.current_module #.None
+ #.modules (list)
+ #.scopes (list)
+ #.type_context ..type_context
+ #.expected #.None
+ #.seed 0
+ #.scope_type_vars (list)
+ #.extensions []
+ #.host []})
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/analysis/evaluation.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/evaluation.lux
new file mode 100644
index 000000000..0895955dc
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/evaluation.lux
@@ -0,0 +1,57 @@
+(.module:
+ [library
+ [lux (#- Module)
+ ["." meta]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]]
+ [math
+ [number
+ ["n" nat]]]]]
+ [// (#+ Operation)
+ [macro (#+ Expander)]
+ [//
+ [phase
+ [".P" extension]
+ [".P" synthesis]
+ [".P" analysis
+ ["." type]]
+ [//
+ ["." synthesis]
+ ["." generation (#+ Context)]
+ [///
+ ["." phase]
+ [meta
+ [archive (#+ Archive)
+ [descriptor (#+ Module)]]]]]]]])
+
+(type: #export Eval
+ (-> Archive Nat Type Code (Operation Any)))
+
+(def: (context [module_id artifact_id])
+ (-> Context Context)
+ ## TODO: Find a better way that doesn't rely on clever tricks.
+ [(n.- module_id 0) artifact_id])
+
+(def: #export (evaluator expander synthesis_state generation_state generate)
+ (All [anchor expression artifact]
+ (-> Expander
+ synthesis.State+
+ (generation.State+ anchor expression artifact)
+ (generation.Phase anchor expression artifact)
+ Eval))
+ (let [analyze (analysisP.phase expander)]
+ (function (eval archive count type exprC)
+ (do phase.monad
+ [exprA (type.with_type type
+ (analyze archive exprC))
+ module (extensionP.lift
+ meta.current_module_name)]
+ (phase.lift (do try.monad
+ [exprS (|> exprA (synthesisP.phase archive) (phase.run synthesis_state))]
+ (phase.run generation_state
+ (do phase.monad
+ [exprO (generate archive exprS)
+ module_id (generation.module_id module archive)]
+ (generation.evaluate! (..context [module_id count]) exprO)))))))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/analysis/macro.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/macro.lux
new file mode 100644
index 000000000..d0957820c
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/macro.lux
@@ -0,0 +1,52 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]]
+ ["." meta]]]
+ [/////
+ ["." phase]])
+
+(exception: #export (expansion_failed {macro Name} {inputs (List Code)} {error Text})
+ (exception.report
+ ["Macro" (%.name macro)]
+ ["Inputs" (exception.enumerate %.code inputs)]
+ ["Error" error]))
+
+(exception: #export (must_have_single_expansion {macro Name} {inputs (List Code)} {outputs (List Code)})
+ (exception.report
+ ["Macro" (%.name macro)]
+ ["Inputs" (exception.enumerate %.code inputs)]
+ ["Outputs" (exception.enumerate %.code outputs)]))
+
+(type: #export Expander
+ (-> Macro (List Code) Lux (Try (Try [Lux (List Code)]))))
+
+(def: #export (expand expander name macro inputs)
+ (-> Expander Name Macro (List Code) (Meta (List Code)))
+ (function (_ state)
+ (do try.monad
+ [output (expander macro inputs state)]
+ (case output
+ (#try.Success output)
+ (#try.Success output)
+
+ (#try.Failure error)
+ ((meta.fail (exception.construct ..expansion_failed [name inputs error])) state)))))
+
+(def: #export (expand_one expander name macro inputs)
+ (-> Expander Name Macro (List Code) (Meta Code))
+ (do meta.monad
+ [expansion (expand expander name macro inputs)]
+ (case expansion
+ (^ (list single))
+ (wrap single)
+
+ _
+ (meta.fail (exception.construct ..must_have_single_expansion [name inputs expansion])))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux
new file mode 100644
index 000000000..49ab15299
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux
@@ -0,0 +1,83 @@
+(.module:
+ [library
+ [lux (#- Module)
+ [abstract
+ [monad (#+ do)]]
+ [data
+ [collection
+ ["." list ("#\." monoid)]]]]]
+ [//
+ ["." analysis]
+ ["." synthesis]
+ ["." generation]
+ [phase
+ ["." extension]]
+ [///
+ ["." phase]
+ [meta
+ [archive
+ [descriptor (#+ Module)]]]]])
+
+(type: #export (Component state phase)
+ {#state state
+ #phase phase})
+
+(type: #export (State anchor expression directive)
+ {#analysis (Component analysis.State+
+ analysis.Phase)
+ #synthesis (Component synthesis.State+
+ synthesis.Phase)
+ #generation (Component (generation.State+ anchor expression directive)
+ (generation.Phase anchor expression directive))})
+
+(type: #export Import
+ {#module Module
+ #alias Text})
+
+(type: #export Requirements
+ {#imports (List Import)
+ #referrals (List Code)})
+
+(def: #export no_requirements
+ Requirements
+ {#imports (list)
+ #referrals (list)})
+
+(def: #export (merge_requirements left right)
+ (-> Requirements Requirements Requirements)
+ {#imports (list\compose (get@ #imports left) (get@ #imports right))
+ #referrals (list\compose (get@ #referrals left) (get@ #referrals right))})
+
+(template [<special> <general>]
+ [(type: #export (<special> anchor expression directive)
+ (<general> (..State anchor expression directive) Code Requirements))]
+
+ [State+ extension.State]
+ [Operation extension.Operation]
+ [Phase extension.Phase]
+ [Handler extension.Handler]
+ [Bundle extension.Bundle]
+ )
+
+(template [<name> <component> <operation>]
+ [(def: #export <name>
+ (All [anchor expression directive output]
+ (-> (<operation> output)
+ (Operation anchor expression directive output)))
+ (|>> (phase.sub [(get@ [<component> #..state])
+ (set@ [<component> #..state])])
+ extension.lift))]
+
+ [lift_analysis #..analysis analysis.Operation]
+ [lift_synthesis #..synthesis synthesis.Operation]
+ [lift_generation #..generation (generation.Operation anchor expression directive)]
+ )
+
+(def: #export (set_current_module module)
+ (All [anchor expression directive]
+ (-> Module (Operation anchor expression directive Any)))
+ (do phase.monad
+ [_ (..lift_analysis
+ (analysis.set_current_module module))]
+ (..lift_generation
+ (generation.enter_module module))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/library/lux/tool/compiler/language/lux/generation.lux
new file mode 100644
index 000000000..13d36021f
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/generation.lux
@@ -0,0 +1,336 @@
+(.module:
+ [library
+ [lux (#- Module)
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." function]]
+ [data
+ [binary (#+ Binary)]
+ ["." product]
+ ["." name]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." row (#+ Row)]
+ ["." list ("#\." functor)]]]
+ [math
+ [number
+ ["n" nat]]]]]
+ [//
+ [synthesis (#+ Synthesis)]
+ [phase
+ ["." extension]]
+ [///
+ ["." phase]
+ [meta
+ ["." archive (#+ Archive)
+ ["." descriptor (#+ Module)]
+ ["." artifact]]]]])
+
+(type: #export Context
+ [archive.ID artifact.ID])
+
+(type: #export (Buffer directive)
+ (Row [artifact.ID directive]))
+
+(exception: #export (cannot_interpret {error Text})
+ (exception.report
+ ["Error" error]))
+
+(template [<name>]
+ [(exception: #export (<name> {artifact_id artifact.ID})
+ (exception.report
+ ["Artifact ID" (%.nat artifact_id)]))]
+
+ [cannot_overwrite_output]
+ [no_buffer_for_saving_code]
+ )
+
+(interface: #export (Host expression directive)
+ (: (-> Context expression (Try Any))
+ evaluate!)
+ (: (-> directive (Try Any))
+ execute!)
+ (: (-> Context expression (Try [Text Any directive]))
+ define!)
+
+ (: (-> Context Binary directive)
+ ingest)
+ (: (-> Context directive (Try Any))
+ re_learn)
+ (: (-> Context directive (Try Any))
+ re_load))
+
+(type: #export (State anchor expression directive)
+ {#module Module
+ #anchor (Maybe anchor)
+ #host (Host expression directive)
+ #buffer (Maybe (Buffer directive))
+ #registry artifact.Registry
+ #counter Nat
+ #context (Maybe artifact.ID)
+ #log (Row Text)})
+
+(template [<special> <general>]
+ [(type: #export (<special> anchor expression directive)
+ (<general> (State anchor expression directive) Synthesis expression))]
+
+ [State+ extension.State]
+ [Operation extension.Operation]
+ [Phase extension.Phase]
+ [Handler extension.Handler]
+ [Bundle extension.Bundle]
+ [Extender extension.Extender]
+ )
+
+(def: #export (state host module)
+ (All [anchor expression directive]
+ (-> (Host expression directive)
+ Module
+ (..State anchor expression directive)))
+ {#module module
+ #anchor #.None
+ #host host
+ #buffer #.None
+ #registry artifact.empty
+ #counter 0
+ #context #.None
+ #log row.empty})
+
+(def: #export empty_buffer Buffer row.empty)
+
+(template [<tag>
+ <with_declaration> <with_type> <with_value>
+ <set> <get> <get_type> <exception>]
+ [(exception: #export <exception>)
+
+ (def: #export <with_declaration>
+ (All [anchor expression directive output] <with_type>)
+ (function (_ body)
+ (function (_ [bundle state])
+ (case (body [bundle (set@ <tag> (#.Some <with_value>) state)])
+ (#try.Success [[bundle' state'] output])
+ (#try.Success [[bundle' (set@ <tag> (get@ <tag> state) state')]
+ output])
+
+ (#try.Failure error)
+ (#try.Failure error)))))
+
+ (def: #export <get>
+ (All [anchor expression directive]
+ (Operation anchor expression directive <get_type>))
+ (function (_ (^@ stateE [bundle state]))
+ (case (get@ <tag> state)
+ (#.Some output)
+ (#try.Success [stateE output])
+
+ #.None
+ (exception.throw <exception> []))))
+
+ (def: #export (<set> value)
+ (All [anchor expression directive]
+ (-> <get_type> (Operation anchor expression directive Any)))
+ (function (_ [bundle state])
+ (#try.Success [[bundle (set@ <tag> (#.Some value) state)]
+ []])))]
+
+ [#anchor
+ (with_anchor anchor)
+ (-> anchor (Operation anchor expression directive output)
+ (Operation anchor expression directive output))
+ anchor
+ set_anchor anchor anchor no_anchor]
+
+ [#buffer
+ with_buffer
+ (-> (Operation anchor expression directive output)
+ (Operation anchor expression directive output))
+ ..empty_buffer
+ set_buffer buffer (Buffer directive) no_active_buffer]
+ )
+
+(def: #export get_registry
+ (All [anchor expression directive]
+ (Operation anchor expression directive artifact.Registry))
+ (function (_ (^@ stateE [bundle state]))
+ (#try.Success [stateE (get@ #registry state)])))
+
+(def: #export (set_registry value)
+ (All [anchor expression directive]
+ (-> artifact.Registry (Operation anchor expression directive Any)))
+ (function (_ [bundle state])
+ (#try.Success [[bundle (set@ #registry value state)]
+ []])))
+
+(def: #export next
+ (All [anchor expression directive]
+ (Operation anchor expression directive Nat))
+ (do phase.monad
+ [count (extension.read (get@ #counter))
+ _ (extension.update (update@ #counter inc))]
+ (wrap count)))
+
+(def: #export (gensym prefix)
+ (All [anchor expression directive]
+ (-> Text (Operation anchor expression directive Text)))
+ (\ phase.monad map (|>> %.nat (format prefix)) ..next))
+
+(def: #export (enter_module module)
+ (All [anchor expression directive]
+ (-> Module (Operation anchor expression directive Any)))
+ (extension.update (set@ #module module)))
+
+(def: #export module
+ (All [anchor expression directive]
+ (Operation anchor expression directive Module))
+ (extension.read (get@ #module)))
+
+(def: #export (evaluate! label code)
+ (All [anchor expression directive]
+ (-> Context expression (Operation anchor expression directive Any)))
+ (function (_ (^@ state+ [bundle state]))
+ (case (\ (get@ #host state) evaluate! label code)
+ (#try.Success output)
+ (#try.Success [state+ output])
+
+ (#try.Failure error)
+ (exception.throw ..cannot_interpret error))))
+
+(def: #export (execute! code)
+ (All [anchor expression directive]
+ (-> directive (Operation anchor expression directive Any)))
+ (function (_ (^@ state+ [bundle state]))
+ (case (\ (get@ #host state) execute! code)
+ (#try.Success output)
+ (#try.Success [state+ output])
+
+ (#try.Failure error)
+ (exception.throw ..cannot_interpret error))))
+
+(def: #export (define! context code)
+ (All [anchor expression directive]
+ (-> Context expression (Operation anchor expression directive [Text Any directive])))
+ (function (_ (^@ stateE [bundle state]))
+ (case (\ (get@ #host state) define! context code)
+ (#try.Success output)
+ (#try.Success [stateE output])
+
+ (#try.Failure error)
+ (exception.throw ..cannot_interpret error))))
+
+(def: #export (save! artifact_id code)
+ (All [anchor expression directive]
+ (-> artifact.ID directive (Operation anchor expression directive Any)))
+ (do {! phase.monad}
+ [?buffer (extension.read (get@ #buffer))]
+ (case ?buffer
+ (#.Some buffer)
+ ## TODO: Optimize by no longer checking for overwrites...
+ (if (row.any? (|>> product.left (n.= artifact_id)) buffer)
+ (phase.throw ..cannot_overwrite_output [artifact_id])
+ (extension.update (set@ #buffer (#.Some (row.add [artifact_id code] buffer)))))
+
+ #.None
+ (phase.throw ..no_buffer_for_saving_code [artifact_id]))))
+
+(template [<name> <artifact>]
+ [(def: #export (<name> name)
+ (All [anchor expression directive]
+ (-> Text (Operation anchor expression directive artifact.ID)))
+ (function (_ (^@ stateE [bundle state]))
+ (let [[id registry'] (<artifact> name (get@ #registry state))]
+ (#try.Success [[bundle (set@ #registry registry' state)]
+ id]))))]
+
+ [learn artifact.definition]
+ [learn_analyser artifact.analyser]
+ [learn_synthesizer artifact.synthesizer]
+ [learn_generator artifact.generator]
+ [learn_directive artifact.directive]
+ )
+
+(exception: #export (unknown_definition {name Name}
+ {known_definitions (List Text)})
+ (exception.report
+ ["Definition" (name.short name)]
+ ["Module" (name.module name)]
+ ["Known Definitions" (exception.enumerate function.identity known_definitions)]))
+
+(def: #export (remember archive name)
+ (All [anchor expression directive]
+ (-> Archive Name (Operation anchor expression directive Context)))
+ (function (_ (^@ stateE [bundle state]))
+ (let [[_module _name] name]
+ (do try.monad
+ [module_id (archive.id _module archive)
+ registry (if (text\= (get@ #module state) _module)
+ (#try.Success (get@ #registry state))
+ (do try.monad
+ [[descriptor document] (archive.find _module archive)]
+ (#try.Success (get@ #descriptor.registry descriptor))))]
+ (case (artifact.remember _name registry)
+ #.None
+ (exception.throw ..unknown_definition [name (artifact.definitions registry)])
+
+ (#.Some id)
+ (#try.Success [stateE [module_id id]]))))))
+
+(exception: #export no_context)
+
+(def: #export (module_id module archive)
+ (All [anchor expression directive]
+ (-> Module Archive (Operation anchor expression directive archive.ID)))
+ (function (_ (^@ stateE [bundle state]))
+ (do try.monad
+ [module_id (archive.id module archive)]
+ (wrap [stateE module_id]))))
+
+(def: #export (context archive)
+ (All [anchor expression directive]
+ (-> Archive (Operation anchor expression directive Context)))
+ (function (_ (^@ stateE [bundle state]))
+ (case (get@ #context state)
+ #.None
+ (exception.throw ..no_context [])
+
+ (#.Some id)
+ (do try.monad
+ [module_id (archive.id (get@ #module state) archive)]
+ (wrap [stateE [module_id id]])))))
+
+(def: #export (with_context id body)
+ (All [anchor expression directive a]
+ (-> artifact.ID
+ (Operation anchor expression directive a)
+ (Operation anchor expression directive a)))
+ (function (_ [bundle state])
+ (do try.monad
+ [[[bundle' state'] output] (body [bundle (set@ #context (#.Some id) state)])]
+ (wrap [[bundle' (set@ #context (get@ #context state) state')]
+ output]))))
+
+(def: #export (with_new_context archive body)
+ (All [anchor expression directive a]
+ (-> Archive (Operation anchor expression directive a)
+ (Operation anchor expression directive [Context a])))
+ (function (_ (^@ stateE [bundle state]))
+ (let [[id registry'] (artifact.resource (get@ #registry state))]
+ (do try.monad
+ [[[bundle' state'] output] (body [bundle (|> state
+ (set@ #registry registry')
+ (set@ #context (#.Some id)))])
+ module_id (archive.id (get@ #module state) archive)]
+ (wrap [[bundle' (set@ #context (get@ #context state) state')]
+ [[module_id id]
+ output]])))))
+
+(def: #export (log! message)
+ (All [anchor expression directive a]
+ (-> Text (Operation anchor expression directive Any)))
+ (function (_ [bundle state])
+ (#try.Success [[bundle
+ (update@ #log (row.add message) state)]
+ []])))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux
new file mode 100644
index 000000000..c35404a68
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux
@@ -0,0 +1,144 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]]
+ [data
+ [text
+ ["%" format (#+ format)]]]
+ ["." meta
+ ["." location]]]]
+ ["." / #_
+ ["#." type]
+ ["#." primitive]
+ ["#." structure]
+ ["#." reference]
+ ["#." case]
+ ["#." function]
+ ["/#" // #_
+ ["#." extension]
+ ["/#" // #_
+ ["/" analysis (#+ Analysis Operation Phase)
+ ["#." macro (#+ Expander)]]
+ [///
+ ["//" phase]
+ ["." reference]
+ [meta
+ [archive (#+ Archive)]]]]]])
+
+(exception: #export (unrecognized_syntax {code Code})
+ (exception.report ["Code" (%.code code)]))
+
+## TODO: Had to split the 'compile' function due to compilation issues
+## with old-luxc. Must re-combine all the code ASAP
+
+(type: (Fix a)
+ (-> a a))
+
+(def: (compile|primitive else code')
+ (Fix (-> (Code' (Ann Location)) (Operation Analysis)))
+ (case code'
+ (^template [<tag> <analyser>]
+ [(<tag> value)
+ (<analyser> value)])
+ ([#.Bit /primitive.bit]
+ [#.Nat /primitive.nat]
+ [#.Int /primitive.int]
+ [#.Rev /primitive.rev]
+ [#.Frac /primitive.frac]
+ [#.Text /primitive.text])
+
+ _
+ (else code')))
+
+(def: (compile|structure archive compile else code')
+ (-> Archive Phase (Fix (-> (Code' (Ann Location)) (Operation Analysis))))
+ (case code'
+ (^ (#.Form (list& [_ (#.Tag tag)]
+ values)))
+ (case values
+ (#.Cons value #.Nil)
+ (/structure.tagged_sum compile tag archive value)
+
+ _
+ (/structure.tagged_sum compile tag archive (` [(~+ values)])))
+
+ (^ (#.Form (list& [_ (#.Nat lefts)] [_ (#.Bit right?)]
+ values)))
+ (case values
+ (#.Cons value #.Nil)
+ (/structure.sum compile lefts right? archive value)
+
+ _
+ (/structure.sum compile lefts right? archive (` [(~+ values)])))
+
+ (#.Tag tag)
+ (/structure.tagged_sum compile tag archive (' []))
+
+ (^ (#.Tuple (list)))
+ /primitive.unit
+
+ (^ (#.Tuple (list singleton)))
+ (compile archive singleton)
+
+ (^ (#.Tuple elems))
+ (/structure.product archive compile elems)
+
+ (^ (#.Record pairs))
+ (/structure.record archive compile pairs)
+
+ _
+ (else code')))
+
+(def: (compile|others expander archive compile code')
+ (-> Expander Archive Phase (-> (Code' (Ann Location)) (Operation Analysis)))
+ (case code'
+ (#.Identifier reference)
+ (/reference.reference reference)
+
+ (^ (#.Form (list [_ (#.Record branches)] input)))
+ (/case.case compile branches archive input)
+
+ (^ (#.Form (list& [_ (#.Text extension_name)] extension_args)))
+ (//extension.apply archive compile [extension_name extension_args])
+
+ (^ (#.Form (list [_ (#.Tuple (list [_ (#.Identifier ["" function_name])]
+ [_ (#.Identifier ["" arg_name])]))]
+ body)))
+ (/function.function compile function_name arg_name archive body)
+
+ (^ (#.Form (list& functionC argsC+)))
+ (do {! //.monad}
+ [[functionT functionA] (/type.with_inference
+ (compile archive functionC))]
+ (case functionA
+ (#/.Reference (#reference.Constant def_name))
+ (do !
+ [?macro (//extension.lift (meta.find_macro def_name))]
+ (case ?macro
+ (#.Some macro)
+ (do !
+ [expansion (//extension.lift (/macro.expand_one expander def_name macro argsC+))]
+ (compile archive expansion))
+
+ _
+ (/function.apply compile argsC+ functionT functionA archive functionC)))
+
+ _
+ (/function.apply compile argsC+ functionT functionA archive functionC)))
+
+ _
+ (//.throw ..unrecognized_syntax [location.dummy code'])))
+
+(def: #export (phase expander)
+ (-> Expander Phase)
+ (function (compile archive code)
+ (let [[location code'] code]
+ ## The location must be set in the state for the sake
+ ## of having useful error messages.
+ (/.with_location location
+ (compile|primitive (compile|structure archive compile
+ (compile|others expander archive compile))
+ code')))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux
new file mode 100644
index 000000000..d447b8d1d
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux
@@ -0,0 +1,325 @@
+(.module:
+ [library
+ [lux (#- case)
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." product]
+ ["." maybe]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." fold monoid functor)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [macro
+ ["." code]]
+ ["." type
+ ["." check]]]]
+ ["." / #_
+ ["#." coverage (#+ Coverage)]
+ ["/#" // #_
+ ["#." scope]
+ ["#." type]
+ ["#." structure]
+ ["/#" // #_
+ ["#." extension]
+ [//
+ ["/" analysis (#+ Pattern Analysis Operation Phase)]
+ [///
+ ["#" phase]]]]]])
+
+(exception: #export (cannot_match_with_pattern {type Type} {pattern Code})
+ (exception.report
+ ["Type" (%.type type)]
+ ["Pattern" (%.code pattern)]))
+
+(exception: #export (sum_has_no_case {case Nat} {type Type})
+ (exception.report
+ ["Case" (%.nat case)]
+ ["Type" (%.type type)]))
+
+(exception: #export (not_a_pattern {code Code})
+ (exception.report ["Code" (%.code code)]))
+
+(exception: #export (cannot_simplify_for_pattern_matching {type Type})
+ (exception.report ["Type" (%.type type)]))
+
+(exception: #export (non_exhaustive_pattern_matching {input Code} {branches (List [Code Code])} {coverage Coverage})
+ (exception.report
+ ["Input" (%.code input)]
+ ["Branches" (%.code (code.record branches))]
+ ["Coverage" (/coverage.%coverage coverage)]))
+
+(exception: #export (cannot_have_empty_branches {message Text})
+ message)
+
+(def: (re_quantify envs baseT)
+ (-> (List (List Type)) Type Type)
+ (.case envs
+ #.Nil
+ baseT
+
+ (#.Cons head tail)
+ (re_quantify tail (#.UnivQ head baseT))))
+
+## Type-checking on the input value is done during the analysis of a
+## "case" expression, to ensure that the patterns being used make
+## sense for the type of the input value.
+## Sometimes, that input value is complex, by depending on
+## type-variables or quantifications.
+## This function makes it easier for "case" analysis to properly
+## type-check the input with respect to the patterns.
+(def: (simplify_case caseT)
+ (-> Type (Operation Type))
+ (loop [envs (: (List (List Type))
+ (list))
+ caseT caseT]
+ (.case caseT
+ (#.Var id)
+ (do ///.monad
+ [?caseT' (//type.with_env
+ (check.read id))]
+ (.case ?caseT'
+ (#.Some caseT')
+ (recur envs caseT')
+
+ _
+ (/.throw ..cannot_simplify_for_pattern_matching caseT)))
+
+ (#.Named name unnamedT)
+ (recur envs unnamedT)
+
+ (#.UnivQ env unquantifiedT)
+ (recur (#.Cons env envs) unquantifiedT)
+
+ (#.ExQ _)
+ (do ///.monad
+ [[var_id varT] (//type.with_env
+ check.var)]
+ (recur envs (maybe.assume (type.apply (list varT) caseT))))
+
+ (#.Apply inputT funcT)
+ (.case funcT
+ (#.Var funcT_id)
+ (do ///.monad
+ [funcT' (//type.with_env
+ (do check.monad
+ [?funct' (check.read funcT_id)]
+ (.case ?funct'
+ (#.Some funct')
+ (wrap funct')
+
+ _
+ (check.throw ..cannot_simplify_for_pattern_matching caseT))))]
+ (recur envs (#.Apply inputT funcT')))
+
+ _
+ (.case (type.apply (list inputT) funcT)
+ (#.Some outputT)
+ (recur envs outputT)
+
+ #.None
+ (/.throw ..cannot_simplify_for_pattern_matching caseT)))
+
+ (#.Product _)
+ (|> caseT
+ type.flatten_tuple
+ (list\map (re_quantify envs))
+ type.tuple
+ (\ ///.monad wrap))
+
+ _
+ (\ ///.monad wrap (re_quantify envs caseT)))))
+
+(def: (analyse_primitive type inputT location output next)
+ (All [a] (-> Type Type Location Pattern (Operation a) (Operation [Pattern a])))
+ (/.with_location location
+ (do ///.monad
+ [_ (//type.with_env
+ (check.check inputT type))
+ outputA next]
+ (wrap [output outputA]))))
+
+## This function handles several concerns at once, but it must be that
+## way because those concerns are interleaved when doing
+## pattern-matching and they cannot be separated.
+## The pattern is analysed in order to get a general feel for what is
+## expected of the input value. This, in turn, informs the
+## type-checking of the input.
+## A kind of "continuation" value is passed around which signifies
+## what needs to be done _after_ analysing a pattern.
+## In general, this is done to analyse the "body" expression
+## associated to a particular pattern _in the context of_ said
+## pattern.
+## The reason why *context* is important is because patterns may bind
+## values to local variables, which may in turn be referenced in the
+## body expressions.
+## That is why the body must be analysed in the context of the
+## pattern, and not separately.
+(def: (analyse_pattern num_tags inputT pattern next)
+ (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a])))
+ (.case pattern
+ [location (#.Identifier ["" name])]
+ (/.with_location location
+ (do ///.monad
+ [outputA (//scope.with_local [name inputT]
+ next)
+ idx //scope.next_local]
+ (wrap [(#/.Bind idx) outputA])))
+
+ (^template [<type> <input> <output>]
+ [[location <input>]
+ (analyse_primitive <type> inputT location (#/.Simple <output>) next)])
+ ([Bit (#.Bit pattern_value) (#/.Bit pattern_value)]
+ [Nat (#.Nat pattern_value) (#/.Nat pattern_value)]
+ [Int (#.Int pattern_value) (#/.Int pattern_value)]
+ [Rev (#.Rev pattern_value) (#/.Rev pattern_value)]
+ [Frac (#.Frac pattern_value) (#/.Frac pattern_value)]
+ [Text (#.Text pattern_value) (#/.Text pattern_value)]
+ [Any (#.Tuple #.Nil) #/.Unit])
+
+ (^ [location (#.Tuple (list singleton))])
+ (analyse_pattern #.None inputT singleton next)
+
+ [location (#.Tuple sub_patterns)]
+ (/.with_location location
+ (do {! ///.monad}
+ [inputT' (simplify_case inputT)]
+ (.case inputT'
+ (#.Product _)
+ (let [subs (type.flatten_tuple inputT')
+ num_subs (maybe.default (list.size subs)
+ num_tags)
+ num_sub_patterns (list.size sub_patterns)
+ matches (cond (n.< num_subs num_sub_patterns)
+ (let [[prefix suffix] (list.split (dec num_sub_patterns) subs)]
+ (list.zip/2 (list\compose prefix (list (type.tuple suffix))) sub_patterns))
+
+ (n.> num_subs num_sub_patterns)
+ (let [[prefix suffix] (list.split (dec num_subs) sub_patterns)]
+ (list.zip/2 subs (list\compose prefix (list (code.tuple suffix)))))
+
+ ## (n.= num_subs num_sub_patterns)
+ (list.zip/2 subs sub_patterns))]
+ (do !
+ [[memberP+ thenA] (list\fold (: (All [a]
+ (-> [Type Code] (Operation [(List Pattern) a])
+ (Operation [(List Pattern) a])))
+ (function (_ [memberT memberC] then)
+ (do !
+ [[memberP [memberP+ thenA]] ((:as (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a])))
+ analyse_pattern)
+ #.None memberT memberC then)]
+ (wrap [(list& memberP memberP+) thenA]))))
+ (do !
+ [nextA next]
+ (wrap [(list) nextA]))
+ (list.reverse matches))]
+ (wrap [(/.pattern/tuple memberP+)
+ thenA])))
+
+ _
+ (/.throw ..cannot_match_with_pattern [inputT' pattern])
+ )))
+
+ [location (#.Record record)]
+ (do ///.monad
+ [record (//structure.normalize record)
+ [members recordT] (//structure.order record)
+ _ (.case inputT
+ (#.Var _id)
+ (//type.with_env
+ (check.check inputT recordT))
+
+ _
+ (wrap []))]
+ (analyse_pattern (#.Some (list.size members)) inputT [location (#.Tuple members)] next))
+
+ [location (#.Tag tag)]
+ (/.with_location location
+ (analyse_pattern #.None inputT (` ((~ pattern))) next))
+
+ (^ [location (#.Form (list& [_ (#.Nat lefts)] [_ (#.Bit right?)] values))])
+ (/.with_location location
+ (do ///.monad
+ [inputT' (simplify_case inputT)]
+ (.case inputT'
+ (#.Sum _)
+ (let [flat_sum (type.flatten_variant inputT')
+ size_sum (list.size flat_sum)
+ num_cases (maybe.default size_sum num_tags)
+ idx (/.tag lefts right?)]
+ (.case (list.nth idx flat_sum)
+ (^multi (#.Some caseT)
+ (n.< num_cases idx))
+ (do ///.monad
+ [[testP nextA] (if (and (n.> num_cases size_sum)
+ (n.= (dec num_cases) idx))
+ (analyse_pattern #.None
+ (type.variant (list.drop (dec num_cases) flat_sum))
+ (` [(~+ values)])
+ next)
+ (analyse_pattern #.None caseT (` [(~+ values)]) next))]
+ (wrap [(/.pattern/variant [lefts right? testP])
+ nextA]))
+
+ _
+ (/.throw ..sum_has_no_case [idx inputT])))
+
+ (#.UnivQ _)
+ (do ///.monad
+ [[ex_id exT] (//type.with_env
+ check.existential)]
+ (analyse_pattern num_tags
+ (maybe.assume (type.apply (list exT) inputT'))
+ pattern
+ next))
+
+ _
+ (/.throw ..cannot_match_with_pattern [inputT' pattern]))))
+
+ (^ [location (#.Form (list& [_ (#.Tag tag)] values))])
+ (/.with_location location
+ (do ///.monad
+ [tag (///extension.lift (meta.normalize tag))
+ [idx group variantT] (///extension.lift (meta.resolve_tag tag))
+ _ (//type.with_env
+ (check.check inputT variantT))
+ #let [[lefts right?] (/.choice (list.size group) idx)]]
+ (analyse_pattern (#.Some (list.size group)) inputT (` ((~ (code.nat lefts)) (~ (code.bit right?)) (~+ values))) next)))
+
+ _
+ (/.throw ..not_a_pattern pattern)
+ ))
+
+(def: #export (case analyse branches archive inputC)
+ (-> Phase (List [Code Code]) Phase)
+ (.case branches
+ (#.Cons [patternH bodyH] branchesT)
+ (do {! ///.monad}
+ [[inputT inputA] (//type.with_inference
+ (analyse archive inputC))
+ outputH (analyse_pattern #.None inputT patternH (analyse archive bodyH))
+ outputT (monad.map !
+ (function (_ [patternT bodyT])
+ (analyse_pattern #.None inputT patternT (analyse archive bodyT)))
+ branchesT)
+ outputHC (|> outputH product.left /coverage.determine)
+ outputTC (monad.map ! (|>> product.left /coverage.determine) outputT)
+ _ (.case (monad.fold try.monad /coverage.merge outputHC outputTC)
+ (#try.Success coverage)
+ (///.assert non_exhaustive_pattern_matching [inputC branches coverage]
+ (/coverage.exhaustive? coverage))
+
+ (#try.Failure error)
+ (/.fail error))]
+ (wrap (#/.Case inputA [outputH outputT])))
+
+ #.Nil
+ (/.throw ..cannot_have_empty_branches "")))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux
new file mode 100644
index 000000000..df92858ec
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux
@@ -0,0 +1,373 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ equivalence
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try) ("#\." monad)]
+ ["ex" exception (#+ exception:)]]
+ [data
+ ["." bit ("#\." equivalence)]
+ ["." maybe]
+ ["." text
+ ["%" format (#+ Format format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." dictionary (#+ Dictionary)]]]
+ [math
+ [number
+ ["n" nat]]]]]
+ ["." //// #_
+ [//
+ ["/" analysis (#+ Pattern Variant Operation)]
+ [///
+ ["#" phase ("#\." monad)]]]])
+
+(exception: #export (invalid_tuple_pattern)
+ "Tuple size must be >= 2")
+
+(def: cases
+ (-> (Maybe Nat) Nat)
+ (|>> (maybe.default 0)))
+
+(def: known_cases?
+ (-> Nat Bit)
+ (n.> 0))
+
+## The coverage of a pattern-matching expression summarizes how well
+## all the possible values of an input are being covered by the
+## different patterns involved.
+## Ideally, the pattern-matching has "exhaustive" coverage, which just
+## means that every possible value can be matched by at least 1
+## pattern.
+## Every other coverage is considered partial, and it would be valued
+## as insuficient (since it could lead to runtime errors due to values
+## not being handled by any pattern).
+## The #Partial tag covers arbitrary partial coverages in a general
+## way, while the other tags cover more specific cases for bits
+## and variants.
+(type: #export #rec Coverage
+ #Partial
+ (#Bit Bit)
+ (#Variant (Maybe Nat) (Dictionary Nat Coverage))
+ (#Seq Coverage Coverage)
+ (#Alt Coverage Coverage)
+ #Exhaustive)
+
+(def: #export (exhaustive? coverage)
+ (-> Coverage Bit)
+ (case coverage
+ (#Exhaustive _)
+ #1
+
+ _
+ #0))
+
+(def: #export (%coverage value)
+ (Format Coverage)
+ (case value
+ #Partial
+ "#Partial"
+
+ (#Bit value')
+ (|> value'
+ %.bit
+ (text.enclose ["(#Bit " ")"]))
+
+ (#Variant ?max_cases cases)
+ (|> cases
+ dictionary.entries
+ (list\map (function (_ [idx coverage])
+ (format (%.nat idx) " " (%coverage coverage))))
+ (text.join_with " ")
+ (text.enclose ["{" "}"])
+ (format (%.nat (..cases ?max_cases)) " ")
+ (text.enclose ["(#Variant " ")"]))
+
+ (#Seq left right)
+ (format "(#Seq " (%coverage left) " " (%coverage right) ")")
+
+ (#Alt left right)
+ (format "(#Alt " (%coverage left) " " (%coverage right) ")")
+
+ #Exhaustive
+ "#Exhaustive"))
+
+(def: #export (determine pattern)
+ (-> Pattern (Operation Coverage))
+ (case pattern
+ (^or (#/.Simple #/.Unit)
+ (#/.Bind _))
+ (////\wrap #Exhaustive)
+
+ ## Primitive patterns always have partial coverage because there
+ ## are too many possibilities as far as values go.
+ (^template [<tag>]
+ [(#/.Simple (<tag> _))
+ (////\wrap #Partial)])
+ ([#/.Nat]
+ [#/.Int]
+ [#/.Rev]
+ [#/.Frac]
+ [#/.Text])
+
+ ## Bits are the exception, since there is only "#1" and
+ ## "#0", which means it is possible for bit
+ ## pattern-matching to become exhaustive if complementary parts meet.
+ (#/.Simple (#/.Bit value))
+ (////\wrap (#Bit value))
+
+ ## Tuple patterns can be exhaustive if there is exhaustiveness for all of
+ ## their sub-patterns.
+ (#/.Complex (#/.Tuple membersP+))
+ (case (list.reverse membersP+)
+ (^or #.Nil (#.Cons _ #.Nil))
+ (/.throw ..invalid_tuple_pattern [])
+
+ (#.Cons lastP prevsP+)
+ (do ////.monad
+ [lastC (determine lastP)]
+ (monad.fold ////.monad
+ (function (_ leftP rightC)
+ (do ////.monad
+ [leftC (determine leftP)]
+ (case rightC
+ #Exhaustive
+ (wrap leftC)
+
+ _
+ (wrap (#Seq leftC rightC)))))
+ lastC prevsP+)))
+
+ ## Variant patterns can be shown to be exhaustive if all the possible
+ ## cases are handled exhaustively.
+ (#/.Complex (#/.Variant [lefts right? value]))
+ (do ////.monad
+ [value_coverage (determine value)
+ #let [idx (if right?
+ (inc lefts)
+ lefts)]]
+ (wrap (#Variant (if right?
+ (#.Some idx)
+ #.None)
+ (|> (dictionary.new n.hash)
+ (dictionary.put idx value_coverage)))))))
+
+(def: (xor left right)
+ (-> Bit Bit Bit)
+ (or (and left (not right))
+ (and (not left) right)))
+
+## The coverage checker not only verifies that pattern-matching is
+## exhaustive, but also that there are no redundant patterns.
+## Redundant patterns will never be executed, since there will
+## always be a pattern prior to them that would match the input.
+## Because of that, the presence of redundant patterns is assumed to
+## be a bug, likely due to programmer carelessness.
+(exception: #export (redundant_pattern {so_far Coverage} {addition Coverage})
+ (ex.report ["Coverage so-far" (%coverage so_far)]
+ ["Coverage addition" (%coverage addition)]))
+
+(def: (flatten_alt coverage)
+ (-> Coverage (List Coverage))
+ (case coverage
+ (#Alt left right)
+ (list& left (flatten_alt right))
+
+ _
+ (list coverage)))
+
+(implementation: equivalence (Equivalence Coverage)
+ (def: (= reference sample)
+ (case [reference sample]
+ [#Exhaustive #Exhaustive]
+ #1
+
+ [(#Bit sideR) (#Bit sideS)]
+ (bit\= sideR sideS)
+
+ [(#Variant allR casesR) (#Variant allS casesS)]
+ (and (n.= (cases allR)
+ (cases allS))
+ (\ (dictionary.equivalence =) = casesR casesS))
+
+ [(#Seq leftR rightR) (#Seq leftS rightS)]
+ (and (= leftR leftS)
+ (= rightR rightS))
+
+ [(#Alt _) (#Alt _)]
+ (let [flatR (flatten_alt reference)
+ flatS (flatten_alt sample)]
+ (and (n.= (list.size flatR) (list.size flatS))
+ (list.every? (function (_ [coverageR coverageS])
+ (= coverageR coverageS))
+ (list.zip/2 flatR flatS))))
+
+ _
+ #0)))
+
+(open: "coverage/." ..equivalence)
+
+(exception: #export (variants_do_not_match {addition_cases Nat} {so_far_cases Nat})
+ (ex.report ["So-far Cases" (%.nat so_far_cases)]
+ ["Addition Cases" (%.nat addition_cases)]))
+
+## After determining the coverage of each individual pattern, it is
+## necessary to merge them all to figure out if the entire
+## pattern-matching expression is exhaustive and whether it contains
+## redundant patterns.
+(def: #export (merge addition so_far)
+ (-> Coverage Coverage (Try Coverage))
+ (case [addition so_far]
+ [#Partial #Partial]
+ (try\wrap #Partial)
+
+ ## 2 bit coverages are exhaustive if they complement one another.
+ (^multi [(#Bit sideA) (#Bit sideSF)]
+ (xor sideA sideSF))
+ (try\wrap #Exhaustive)
+
+ [(#Variant allA casesA) (#Variant allSF casesSF)]
+ (let [addition_cases (cases allSF)
+ so_far_cases (cases allA)]
+ (cond (and (known_cases? addition_cases)
+ (known_cases? so_far_cases)
+ (not (n.= addition_cases so_far_cases)))
+ (ex.throw ..variants_do_not_match [addition_cases so_far_cases])
+
+ (\ (dictionary.equivalence ..equivalence) = casesSF casesA)
+ (ex.throw ..redundant_pattern [so_far addition])
+
+ ## else
+ (do {! try.monad}
+ [casesM (monad.fold !
+ (function (_ [tagA coverageA] casesSF')
+ (case (dictionary.get tagA casesSF')
+ (#.Some coverageSF)
+ (do !
+ [coverageM (merge coverageA coverageSF)]
+ (wrap (dictionary.put tagA coverageM casesSF')))
+
+ #.None
+ (wrap (dictionary.put tagA coverageA casesSF'))))
+ casesSF (dictionary.entries casesA))]
+ (wrap (if (and (or (known_cases? addition_cases)
+ (known_cases? so_far_cases))
+ (n.= (inc (n.max addition_cases so_far_cases))
+ (dictionary.size casesM))
+ (list.every? exhaustive? (dictionary.values casesM)))
+ #Exhaustive
+ (#Variant (case allSF
+ (#.Some _)
+ allSF
+
+ _
+ allA)
+ casesM))))))
+
+ [(#Seq leftA rightA) (#Seq leftSF rightSF)]
+ (case [(coverage/= leftSF leftA) (coverage/= rightSF rightA)]
+ ## Same prefix
+ [#1 #0]
+ (do try.monad
+ [rightM (merge rightA rightSF)]
+ (if (exhaustive? rightM)
+ ## If all that follows is exhaustive, then it can be safely dropped
+ ## (since only the "left" part would influence whether the
+ ## merged coverage is exhaustive or not).
+ (wrap leftSF)
+ (wrap (#Seq leftSF rightM))))
+
+ ## Same suffix
+ [#0 #1]
+ (do try.monad
+ [leftM (merge leftA leftSF)]
+ (wrap (#Seq leftM rightA)))
+
+ ## The 2 sequences cannot possibly be merged.
+ [#0 #0]
+ (try\wrap (#Alt so_far addition))
+
+ ## There is nothing the addition adds to the coverage.
+ [#1 #1]
+ (ex.throw ..redundant_pattern [so_far addition]))
+
+ ## The addition cannot possibly improve the coverage.
+ [_ #Exhaustive]
+ (ex.throw ..redundant_pattern [so_far addition])
+
+ ## The addition completes the coverage.
+ [#Exhaustive _]
+ (try\wrap #Exhaustive)
+
+ ## The left part will always match, so the addition is redundant.
+ (^multi [(#Seq left right) single]
+ (coverage/= left single))
+ (ex.throw ..redundant_pattern [so_far addition])
+
+ ## The right part is not necessary, since it can always match the left.
+ (^multi [single (#Seq left right)]
+ (coverage/= left single))
+ (try\wrap single)
+
+ ## When merging a new coverage against one based on Alt, it may be
+ ## that one of the many coverages in the Alt is complementary to
+ ## the new one, so effort must be made to fuse carefully, to match
+ ## the right coverages together.
+ ## If one of the Alt sub-coverages matches the new one, the cycle
+ ## must be repeated, in case the resulting coverage can now match
+ ## other ones in the original Alt.
+ ## This process must be repeated until no further productive
+ ## merges can be done.
+ [_ (#Alt leftS rightS)]
+ (do {! try.monad}
+ [#let [fuse_once (: (-> Coverage (List Coverage)
+ (Try [(Maybe Coverage)
+ (List Coverage)]))
+ (function (_ coverageA possibilitiesSF)
+ (loop [altsSF possibilitiesSF]
+ (case altsSF
+ #.Nil
+ (wrap [#.None (list coverageA)])
+
+ (#.Cons altSF altsSF')
+ (case (merge coverageA altSF)
+ (#try.Success altMSF)
+ (case altMSF
+ (#Alt _)
+ (do !
+ [[success altsSF+] (recur altsSF')]
+ (wrap [success (#.Cons altSF altsSF+)]))
+
+ _
+ (wrap [(#.Some altMSF) altsSF']))
+
+ (#try.Failure error)
+ (try.fail error))
+ ))))]
+ [successA possibilitiesSF] (fuse_once addition (flatten_alt so_far))]
+ (loop [successA successA
+ possibilitiesSF possibilitiesSF]
+ (case successA
+ (#.Some coverageA')
+ (do !
+ [[successA' possibilitiesSF'] (fuse_once coverageA' possibilitiesSF)]
+ (recur successA' possibilitiesSF'))
+
+ #.None
+ (case (list.reverse possibilitiesSF)
+ (#.Cons last prevs)
+ (wrap (list\fold (function (_ left right) (#Alt left right))
+ last
+ prevs))
+
+ #.Nil
+ (undefined)))))
+
+ _
+ (if (coverage/= so_far addition)
+ ## The addition cannot possibly improve the coverage.
+ (ex.throw ..redundant_pattern [so_far addition])
+ ## There are now 2 alternative paths.
+ (try\wrap (#Alt so_far addition)))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/function.lux
new file mode 100644
index 000000000..5e41e907e
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/function.lux
@@ -0,0 +1,113 @@
+(.module:
+ [library
+ [lux (#- function)
+ [abstract
+ monad]
+ [control
+ ["ex" exception (#+ exception:)]]
+ [data
+ ["." maybe]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." fold monoid monad)]]]
+ ["." type
+ ["." check]]
+ ["." meta]]]
+ ["." // #_
+ ["#." scope]
+ ["#." type]
+ ["#." inference]
+ ["/#" // #_
+ ["#." extension]
+ [//
+ ["/" analysis (#+ Analysis Operation Phase)]
+ [///
+ ["#" phase]
+ [reference (#+)
+ [variable (#+)]]]]]])
+
+(exception: #export (cannot_analyse {expected Type} {function Text} {argument Text} {body Code})
+ (ex.report ["Type" (%.type expected)]
+ ["Function" function]
+ ["Argument" argument]
+ ["Body" (%.code body)]))
+
+(exception: #export (cannot_apply {functionT Type} {functionC Code} {arguments (List Code)})
+ (ex.report ["Function type" (%.type functionT)]
+ ["Function" (%.code functionC)]
+ ["Arguments" (|> arguments
+ list.enumeration
+ (list\map (.function (_ [idx argC])
+ (format (%.nat idx) " " (%.code argC))))
+ (text.join_with text.new_line))]))
+
+(def: #export (function analyse function_name arg_name archive body)
+ (-> Phase Text Text Phase)
+ (do {! ///.monad}
+ [functionT (///extension.lift meta.expected_type)]
+ (loop [expectedT functionT]
+ (/.with_stack ..cannot_analyse [expectedT function_name arg_name body]
+ (case expectedT
+ (#.Named name unnamedT)
+ (recur unnamedT)
+
+ (#.Apply argT funT)
+ (case (type.apply (list argT) funT)
+ (#.Some value)
+ (recur value)
+
+ #.None
+ (/.fail (ex.construct cannot_analyse [expectedT function_name arg_name body])))
+
+ (^template [<tag> <instancer>]
+ [(<tag> _)
+ (do !
+ [[_ instanceT] (//type.with_env <instancer>)]
+ (recur (maybe.assume (type.apply (list instanceT) expectedT))))])
+ ([#.UnivQ check.existential]
+ [#.ExQ check.var])
+
+ (#.Var id)
+ (do !
+ [?expectedT' (//type.with_env
+ (check.read id))]
+ (case ?expectedT'
+ (#.Some expectedT')
+ (recur expectedT')
+
+ ## Inference
+ _
+ (do !
+ [[input_id inputT] (//type.with_env check.var)
+ [output_id outputT] (//type.with_env check.var)
+ #let [functionT (#.Function inputT outputT)]
+ functionA (recur functionT)
+ _ (//type.with_env
+ (check.check expectedT functionT))]
+ (wrap functionA))
+ ))
+
+ (#.Function inputT outputT)
+ (<| (\ ! map (.function (_ [scope bodyA])
+ (#/.Function (list\map (|>> /.variable)
+ (//scope.environment scope))
+ bodyA)))
+ /.with_scope
+ ## Functions have access not only to their argument, but
+ ## also to themselves, through a local variable.
+ (//scope.with_local [function_name expectedT])
+ (//scope.with_local [arg_name inputT])
+ (//type.with_type outputT)
+ (analyse archive body))
+
+ _
+ (/.fail "")
+ )))))
+
+(def: #export (apply analyse argsC+ functionT functionA archive functionC)
+ (-> Phase (List Code) Type Analysis Phase)
+ (<| (/.with_stack ..cannot_apply [functionT functionC argsC+])
+ (do ///.monad
+ [[applyT argsA+] (//inference.general archive analyse functionT argsC+)])
+ (wrap (/.apply [functionA argsA+]))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/inference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/inference.lux
new file mode 100644
index 000000000..9ad503709
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/inference.lux
@@ -0,0 +1,301 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]]
+ [data
+ ["." maybe]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ [number
+ ["n" nat]]]
+ ["." type
+ ["." check]]
+ ["." meta]]]
+ ["." // #_
+ ["#." type]
+ ["/#" // #_
+ ["#." extension]
+ [//
+ ["/" analysis (#+ Tag Analysis Operation Phase)]
+ [///
+ ["#" phase ("#\." monad)]
+ [meta
+ [archive (#+ Archive)]]]]]])
+
+(exception: #export (variant_tag_out_of_bounds {size Nat} {tag Tag} {type Type})
+ (exception.report
+ ["Tag" (%.nat tag)]
+ ["Variant size" (%.int (.int size))]
+ ["Variant type" (%.type type)]))
+
+(exception: #export (cannot_infer {type Type} {args (List Code)})
+ (exception.report
+ ["Type" (%.type type)]
+ ["Arguments" (exception.enumerate %.code args)]))
+
+(exception: #export (cannot_infer_argument {inferred Type} {argument Code})
+ (exception.report
+ ["Inferred Type" (%.type inferred)]
+ ["Argument" (%.code argument)]))
+
+(exception: #export (smaller_variant_than_expected {expected Nat} {actual Nat})
+ (exception.report
+ ["Expected" (%.int (.int expected))]
+ ["Actual" (%.int (.int actual))]))
+
+(template [<name>]
+ [(exception: #export (<name> {type Type})
+ (%.type type))]
+
+ [not_a_variant_type]
+ [not_a_record_type]
+ [invalid_type_application]
+ )
+
+(def: (replace parameter_idx replacement type)
+ (-> Nat Type Type Type)
+ (case type
+ (#.Primitive name params)
+ (#.Primitive name (list\map (replace parameter_idx replacement) params))
+
+ (^template [<tag>]
+ [(<tag> left right)
+ (<tag> (replace parameter_idx replacement left)
+ (replace parameter_idx replacement right))])
+ ([#.Sum]
+ [#.Product]
+ [#.Function]
+ [#.Apply])
+
+ (#.Parameter idx)
+ (if (n.= parameter_idx idx)
+ replacement
+ type)
+
+ (^template [<tag>]
+ [(<tag> env quantified)
+ (<tag> (list\map (replace parameter_idx replacement) env)
+ (replace (n.+ 2 parameter_idx) replacement quantified))])
+ ([#.UnivQ]
+ [#.ExQ])
+
+ _
+ type))
+
+(def: (named_type location id)
+ (-> Location Nat Type)
+ (let [name (format "{New Type " (%.location location) " " (%.nat id) "}")]
+ (#.Primitive name (list))))
+
+(def: new_named_type
+ (Operation Type)
+ (do ///.monad
+ [location (///extension.lift meta.location)
+ [ex_id _] (//type.with_env check.existential)]
+ (wrap (named_type location ex_id))))
+
+## Type-inference works by applying some (potentially quantified) type
+## to a sequence of values.
+## Function types are used for this, although inference is not always
+## done for function application (alternative uses may be records and
+## tagged variants).
+## But, so long as the type being used for the inference can be treated
+## as a function type, this method of inference should work.
+(def: #export (general archive analyse inferT args)
+ (-> Archive Phase Type (List Code) (Operation [Type (List Analysis)]))
+ (case args
+ #.Nil
+ (do ///.monad
+ [_ (//type.infer inferT)]
+ (wrap [inferT (list)]))
+
+ (#.Cons argC args')
+ (case inferT
+ (#.Named name unnamedT)
+ (general archive analyse unnamedT args)
+
+ (#.UnivQ _)
+ (do ///.monad
+ [[var_id varT] (//type.with_env check.var)]
+ (general archive analyse (maybe.assume (type.apply (list varT) inferT)) args))
+
+ (#.ExQ _)
+ (do {! ///.monad}
+ [[var_id varT] (//type.with_env check.var)
+ output (general archive analyse
+ (maybe.assume (type.apply (list varT) inferT))
+ args)
+ bound? (//type.with_env
+ (check.bound? var_id))
+ _ (if bound?
+ (wrap [])
+ (do !
+ [newT new_named_type]
+ (//type.with_env
+ (check.check varT newT))))]
+ (wrap output))
+
+ (#.Apply inputT transT)
+ (case (type.apply (list inputT) transT)
+ (#.Some outputT)
+ (general archive analyse outputT args)
+
+ #.None
+ (/.throw ..invalid_type_application inferT))
+
+ ## Arguments are inferred back-to-front because, by convention,
+ ## Lux functions take the most important arguments *last*, which
+ ## means that the most information for doing proper inference is
+ ## located in the last arguments to a function call.
+ ## By inferring back-to-front, a lot of type-annotations can be
+ ## avoided in Lux code, since the inference algorithm can piece
+ ## things together more easily.
+ (#.Function inputT outputT)
+ (do ///.monad
+ [[outputT' args'A] (general archive analyse outputT args')
+ argA (<| (/.with_stack ..cannot_infer_argument [inputT argC])
+ (//type.with_type inputT)
+ (analyse archive argC))]
+ (wrap [outputT' (list& argA args'A)]))
+
+ (#.Var infer_id)
+ (do ///.monad
+ [?inferT' (//type.with_env (check.read infer_id))]
+ (case ?inferT'
+ (#.Some inferT')
+ (general archive analyse inferT' args)
+
+ _
+ (/.throw ..cannot_infer [inferT args])))
+
+ _
+ (/.throw ..cannot_infer [inferT args]))
+ ))
+
+(def: (substitute_bound target sub)
+ (-> Nat Type Type Type)
+ (function (recur base)
+ (case base
+ (#.Primitive name parameters)
+ (#.Primitive name (list\map recur parameters))
+
+ (^template [<tag>]
+ [(<tag> left right)
+ (<tag> (recur left) (recur right))])
+ ([#.Sum] [#.Product] [#.Function] [#.Apply])
+
+ (#.Parameter index)
+ (if (n.= target index)
+ sub
+ base)
+
+ (^template [<tag>]
+ [(<tag> environment quantified)
+ (<tag> (list\map recur environment) quantified)])
+ ([#.UnivQ] [#.ExQ])
+
+ _
+ base)))
+
+## Turns a record type into the kind of function type suitable for inference.
+(def: (record' target originalT inferT)
+ (-> Nat Type Type (Operation Type))
+ (case inferT
+ (#.Named name unnamedT)
+ (record' target originalT unnamedT)
+
+ (^template [<tag>]
+ [(<tag> env bodyT)
+ (do ///.monad
+ [bodyT+ (record' (n.+ 2 target) originalT bodyT)]
+ (wrap (<tag> env bodyT+)))])
+ ([#.UnivQ]
+ [#.ExQ])
+
+ (#.Apply inputT funcT)
+ (case (type.apply (list inputT) funcT)
+ (#.Some outputT)
+ (record' target originalT outputT)
+
+ #.None
+ (/.throw ..invalid_type_application inferT))
+
+ (#.Product _)
+ (///\wrap (|> inferT
+ (type.function (type.flatten_tuple inferT))
+ (substitute_bound target originalT)))
+
+ _
+ (/.throw ..not_a_record_type inferT)))
+
+(def: #export (record inferT)
+ (-> Type (Operation Type))
+ (record' (n.- 2 0) inferT inferT))
+
+## Turns a variant type into the kind of function type suitable for inference.
+(def: #export (variant tag expected_size inferT)
+ (-> Nat Nat Type (Operation Type))
+ (loop [depth 0
+ currentT inferT]
+ (case currentT
+ (#.Named name unnamedT)
+ (do ///.monad
+ [unnamedT+ (recur depth unnamedT)]
+ (wrap unnamedT+))
+
+ (^template [<tag>]
+ [(<tag> env bodyT)
+ (do ///.monad
+ [bodyT+ (recur (inc depth) bodyT)]
+ (wrap (<tag> env bodyT+)))])
+ ([#.UnivQ]
+ [#.ExQ])
+
+ (#.Sum _)
+ (let [cases (type.flatten_variant currentT)
+ actual_size (list.size cases)
+ boundary (dec expected_size)]
+ (cond (or (n.= expected_size actual_size)
+ (and (n.> expected_size actual_size)
+ (n.< boundary tag)))
+ (case (list.nth tag cases)
+ (#.Some caseT)
+ (///\wrap (if (n.= 0 depth)
+ (type.function (list caseT) currentT)
+ (let [replace' (replace (|> depth dec (n.* 2)) inferT)]
+ (type.function (list (replace' caseT))
+ (replace' currentT)))))
+
+ #.None
+ (/.throw ..variant_tag_out_of_bounds [expected_size tag inferT]))
+
+ (n.< expected_size actual_size)
+ (/.throw ..smaller_variant_than_expected [expected_size actual_size])
+
+ (n.= boundary tag)
+ (let [caseT (type.variant (list.drop boundary cases))]
+ (///\wrap (if (n.= 0 depth)
+ (type.function (list caseT) currentT)
+ (let [replace' (replace (|> depth dec (n.* 2)) inferT)]
+ (type.function (list (replace' caseT))
+ (replace' currentT))))))
+
+ ## else
+ (/.throw ..variant_tag_out_of_bounds [expected_size tag inferT])))
+
+ (#.Apply inputT funcT)
+ (case (type.apply (list inputT) funcT)
+ (#.Some outputT)
+ (variant tag expected_size outputT)
+
+ #.None
+ (/.throw ..invalid_type_application inferT))
+
+ _
+ (/.throw ..not_a_variant_type inferT))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux
new file mode 100644
index 000000000..94b289a08
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux
@@ -0,0 +1,275 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ pipe
+ ["." try]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." fold functor)]
+ [dictionary
+ ["." plist]]]]
+ ["." meta]]]
+ ["." /// #_
+ ["#." extension]
+ [//
+ ["/" analysis (#+ Operation)]
+ [///
+ ["#" phase]]]])
+
+(type: #export Tag Text)
+
+(exception: #export (unknown_module {module Text})
+ (exception.report
+ ["Module" module]))
+
+(exception: #export (cannot_declare_tag_twice {module Text} {tag Text})
+ (exception.report
+ ["Module" module]
+ ["Tag" tag]))
+
+(template [<name>]
+ [(exception: #export (<name> {tags (List Text)} {owner Type})
+ (exception.report
+ ["Tags" (text.join_with " " tags)]
+ ["Type" (%.type owner)]))]
+
+ [cannot_declare_tags_for_unnamed_type]
+ [cannot_declare_tags_for_foreign_type]
+ )
+
+(exception: #export (cannot_define_more_than_once {name Name} {already_existing Global})
+ (exception.report
+ ["Definition" (%.name name)]
+ ["Original" (case already_existing
+ (#.Alias alias)
+ (format "alias " (%.name alias))
+
+ (#.Definition definition)
+ (format "definition " (%.name name)))]))
+
+(exception: #export (can_only_change_state_of_active_module {module Text} {state Module_State})
+ (exception.report
+ ["Module" module]
+ ["Desired state" (case state
+ #.Active "Active"
+ #.Compiled "Compiled"
+ #.Cached "Cached")]))
+
+(exception: #export (cannot_set_module_annotations_more_than_once {module Text} {old Code} {new Code})
+ (exception.report
+ ["Module" module]
+ ["Old annotations" (%.code old)]
+ ["New annotations" (%.code new)]))
+
+(def: #export (new hash)
+ (-> Nat Module)
+ {#.module_hash hash
+ #.module_aliases (list)
+ #.definitions (list)
+ #.imports (list)
+ #.tags (list)
+ #.types (list)
+ #.module_annotations #.None
+ #.module_state #.Active})
+
+(def: #export (set_annotations annotations)
+ (-> Code (Operation Any))
+ (///extension.lift
+ (do ///.monad
+ [self_name meta.current_module_name
+ self meta.current_module]
+ (case (get@ #.module_annotations self)
+ #.None
+ (function (_ state)
+ (#try.Success [(update@ #.modules
+ (plist.put self_name (set@ #.module_annotations (#.Some annotations) self))
+ state)
+ []]))
+
+ (#.Some old)
+ (/.throw' cannot_set_module_annotations_more_than_once [self_name old annotations])))))
+
+(def: #export (import module)
+ (-> Text (Operation Any))
+ (///extension.lift
+ (do ///.monad
+ [self_name meta.current_module_name]
+ (function (_ state)
+ (#try.Success [(update@ #.modules
+ (plist.update self_name (update@ #.imports (function (_ current)
+ (if (list.any? (text\= module)
+ current)
+ current
+ (#.Cons module current)))))
+ state)
+ []])))))
+
+(def: #export (alias alias module)
+ (-> Text Text (Operation Any))
+ (///extension.lift
+ (do ///.monad
+ [self_name meta.current_module_name]
+ (function (_ state)
+ (#try.Success [(update@ #.modules
+ (plist.update self_name (update@ #.module_aliases (: (-> (List [Text Text]) (List [Text Text]))
+ (|>> (#.Cons [alias module])))))
+ state)
+ []])))))
+
+(def: #export (exists? module)
+ (-> Text (Operation Bit))
+ (///extension.lift
+ (function (_ state)
+ (|> state
+ (get@ #.modules)
+ (plist.get module)
+ (case> (#.Some _) #1 #.None #0)
+ [state] #try.Success))))
+
+(def: #export (define name definition)
+ (-> Text Global (Operation Any))
+ (///extension.lift
+ (do ///.monad
+ [self_name meta.current_module_name
+ self meta.current_module]
+ (function (_ state)
+ (case (plist.get name (get@ #.definitions self))
+ #.None
+ (#try.Success [(update@ #.modules
+ (plist.put self_name
+ (update@ #.definitions
+ (: (-> (List [Text Global]) (List [Text Global]))
+ (|>> (#.Cons [name definition])))
+ self))
+ state)
+ []])
+
+ (#.Some already_existing)
+ ((/.throw' ..cannot_define_more_than_once [[self_name name] already_existing]) state))))))
+
+(def: #export (create hash name)
+ (-> Nat Text (Operation Any))
+ (///extension.lift
+ (function (_ state)
+ (#try.Success [(update@ #.modules
+ (plist.put name (new hash))
+ state)
+ []]))))
+
+(def: #export (with_module hash name action)
+ (All [a] (-> Nat Text (Operation a) (Operation [Module a])))
+ (do ///.monad
+ [_ (create hash name)
+ output (/.with_current_module name
+ action)
+ module (///extension.lift (meta.find_module name))]
+ (wrap [module output])))
+
+(template [<setter> <asker> <tag>]
+ [(def: #export (<setter> module_name)
+ (-> Text (Operation Any))
+ (///extension.lift
+ (function (_ state)
+ (case (|> state (get@ #.modules) (plist.get module_name))
+ (#.Some module)
+ (let [active? (case (get@ #.module_state module)
+ #.Active #1
+ _ #0)]
+ (if active?
+ (#try.Success [(update@ #.modules
+ (plist.put module_name (set@ #.module_state <tag> module))
+ state)
+ []])
+ ((/.throw' can_only_change_state_of_active_module [module_name <tag>])
+ state)))
+
+ #.None
+ ((/.throw' unknown_module module_name) state)))))
+
+ (def: #export (<asker> module_name)
+ (-> Text (Operation Bit))
+ (///extension.lift
+ (function (_ state)
+ (case (|> state (get@ #.modules) (plist.get module_name))
+ (#.Some module)
+ (#try.Success [state
+ (case (get@ #.module_state module)
+ <tag> #1
+ _ #0)])
+
+ #.None
+ ((/.throw' unknown_module module_name) state)))))]
+
+ [set_active active? #.Active]
+ [set_compiled compiled? #.Compiled]
+ [set_cached cached? #.Cached]
+ )
+
+(template [<name> <tag> <type>]
+ [(def: (<name> module_name)
+ (-> Text (Operation <type>))
+ (///extension.lift
+ (function (_ state)
+ (case (|> state (get@ #.modules) (plist.get module_name))
+ (#.Some module)
+ (#try.Success [state (get@ <tag> module)])
+
+ #.None
+ ((/.throw' unknown_module module_name) state)))))]
+
+ [tags #.tags (List [Text [Nat (List Name) Bit Type]])]
+ [types #.types (List [Text [(List Name) Bit Type]])]
+ [hash #.module_hash Nat]
+ )
+
+(def: (ensure_undeclared_tags module_name tags)
+ (-> Text (List Tag) (Operation Any))
+ (do {! ///.monad}
+ [bindings (..tags module_name)
+ _ (monad.map !
+ (function (_ tag)
+ (case (plist.get tag bindings)
+ #.None
+ (wrap [])
+
+ (#.Some _)
+ (/.throw ..cannot_declare_tag_twice [module_name tag])))
+ tags)]
+ (wrap [])))
+
+(def: #export (declare_tags tags exported? type)
+ (-> (List Tag) Bit Type (Operation Any))
+ (do ///.monad
+ [self_name (///extension.lift meta.current_module_name)
+ [type_module type_name] (case type
+ (#.Named type_name _)
+ (wrap type_name)
+
+ _
+ (/.throw ..cannot_declare_tags_for_unnamed_type [tags type]))
+ _ (ensure_undeclared_tags self_name tags)
+ _ (///.assert cannot_declare_tags_for_foreign_type [tags type]
+ (text\= self_name type_module))]
+ (///extension.lift
+ (function (_ state)
+ (case (|> state (get@ #.modules) (plist.get self_name))
+ (#.Some module)
+ (let [namespaced_tags (list\map (|>> [self_name]) tags)]
+ (#try.Success [(update@ #.modules
+ (plist.update self_name
+ (|>> (update@ #.tags (function (_ tag_bindings)
+ (list\fold (function (_ [idx tag] table)
+ (plist.put tag [idx namespaced_tags exported? type] table))
+ tag_bindings
+ (list.enumeration tags))))
+ (update@ #.types (plist.put type_name [namespaced_tags exported? type]))))
+ state)
+ []]))
+ #.None
+ ((/.throw' unknown_module self_name) state))))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/primitive.lux
new file mode 100644
index 000000000..27c4d98f4
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/primitive.lux
@@ -0,0 +1,33 @@
+(.module:
+ [library
+ [lux (#- nat int rev)
+ [abstract
+ monad]]]
+ ["." // #_
+ ["#." type]
+ ["/#" // #_
+ [//
+ ["/" analysis (#+ Analysis Operation)]
+ [///
+ ["#" phase]]]]])
+
+(template [<name> <type> <tag>]
+ [(def: #export (<name> value)
+ (-> <type> (Operation Analysis))
+ (do ///.monad
+ [_ (//type.infer <type>)]
+ (wrap (#/.Primitive (<tag> value)))))]
+
+ [bit .Bit #/.Bit]
+ [nat .Nat #/.Nat]
+ [int .Int #/.Int]
+ [rev .Rev #/.Rev]
+ [frac .Frac #/.Frac]
+ [text .Text #/.Text]
+ )
+
+(def: #export unit
+ (Operation Analysis)
+ (do ///.monad
+ [_ (//type.infer .Any)]
+ (wrap (#/.Primitive #/.Unit))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux
new file mode 100644
index 000000000..9ce2b1faa
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux
@@ -0,0 +1,85 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ monad]
+ [control
+ ["." exception (#+ exception:)]]
+ ["." meta]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]]]
+ ["." // #_
+ ["#." scope]
+ ["#." type]
+ ["/#" // #_
+ ["#." extension]
+ [//
+ ["/" analysis (#+ Analysis Operation)]
+ [///
+ ["#." reference]
+ ["#" phase]]]]])
+
+(exception: #export (foreign_module_has_not_been_imported {current Text} {foreign Text})
+ (exception.report
+ ["Current" current]
+ ["Foreign" foreign]))
+
+(exception: #export (definition_has_not_been_exported {definition Name})
+ (exception.report
+ ["Definition" (%.name definition)]))
+
+(def: (definition def_name)
+ (-> Name (Operation Analysis))
+ (with_expansions [<return> (wrap (|> def_name ///reference.constant #/.Reference))]
+ (do {! ///.monad}
+ [constant (///extension.lift (meta.find_def def_name))]
+ (case constant
+ (#.Left real_def_name)
+ (definition real_def_name)
+
+ (#.Right [exported? actualT def_anns _])
+ (do !
+ [_ (//type.infer actualT)
+ (^@ def_name [::module ::name]) (///extension.lift (meta.normalize def_name))
+ current (///extension.lift meta.current_module_name)]
+ (if (text\= current ::module)
+ <return>
+ (if exported?
+ (do !
+ [imported! (///extension.lift (meta.imported_by? ::module current))]
+ (if imported!
+ <return>
+ (/.throw foreign_module_has_not_been_imported [current ::module])))
+ (/.throw definition_has_not_been_exported def_name))))))))
+
+(def: (variable var_name)
+ (-> Text (Operation (Maybe Analysis)))
+ (do {! ///.monad}
+ [?var (//scope.find var_name)]
+ (case ?var
+ (#.Some [actualT ref])
+ (do !
+ [_ (//type.infer actualT)]
+ (wrap (#.Some (|> ref ///reference.variable #/.Reference))))
+
+ #.None
+ (wrap #.None))))
+
+(def: #export (reference reference)
+ (-> Name (Operation Analysis))
+ (case reference
+ ["" simple_name]
+ (do {! ///.monad}
+ [?var (variable simple_name)]
+ (case ?var
+ (#.Some varA)
+ (wrap varA)
+
+ #.None
+ (do !
+ [this_module (///extension.lift meta.current_module_name)]
+ (definition [this_module simple_name]))))
+
+ _
+ (definition reference)))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/scope.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/scope.lux
new file mode 100644
index 000000000..c0e598e06
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/scope.lux
@@ -0,0 +1,206 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ monad]
+ [control
+ ["." try]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." text ("#\." equivalence)]
+ ["." maybe ("#\." monad)]
+ ["." product]
+ [collection
+ ["." list ("#\." functor fold monoid)]
+ [dictionary
+ ["." plist]]]]]]
+ ["." /// #_
+ ["#." extension]
+ [//
+ ["/" analysis (#+ Operation Phase)]
+ [///
+ [reference
+ ["." variable (#+ Register Variable)]]
+ ["#" phase]]]])
+
+(type: Local (Bindings Text [Type Register]))
+(type: Foreign (Bindings Text [Type Variable]))
+
+(def: (local? name scope)
+ (-> Text Scope Bit)
+ (|> scope
+ (get@ [#.locals #.mappings])
+ (plist.contains? name)))
+
+(def: (local name scope)
+ (-> Text Scope (Maybe [Type Variable]))
+ (|> scope
+ (get@ [#.locals #.mappings])
+ (plist.get name)
+ (maybe\map (function (_ [type value])
+ [type (#variable.Local value)]))))
+
+(def: (captured? name scope)
+ (-> Text Scope Bit)
+ (|> scope
+ (get@ [#.captured #.mappings])
+ (plist.contains? name)))
+
+(def: (captured name scope)
+ (-> Text Scope (Maybe [Type Variable]))
+ (loop [idx 0
+ mappings (get@ [#.captured #.mappings] scope)]
+ (case mappings
+ (#.Cons [_name [_source_type _source_ref]] mappings')
+ (if (text\= name _name)
+ (#.Some [_source_type (#variable.Foreign idx)])
+ (recur (inc idx) mappings'))
+
+ #.Nil
+ #.None)))
+
+(def: (reference? name scope)
+ (-> Text Scope Bit)
+ (or (local? name scope)
+ (captured? name scope)))
+
+(def: (reference name scope)
+ (-> Text Scope (Maybe [Type Variable]))
+ (case (..local name scope)
+ (#.Some type)
+ (#.Some type)
+
+ _
+ (..captured name scope)))
+
+(def: #export (find name)
+ (-> Text (Operation (Maybe [Type Variable])))
+ (///extension.lift
+ (function (_ state)
+ (let [[inner outer] (|> state
+ (get@ #.scopes)
+ (list.split_with (|>> (reference? name) not)))]
+ (case outer
+ #.Nil
+ (#.Right [state #.None])
+
+ (#.Cons top_outer _)
+ (let [[ref_type init_ref] (maybe.default (undefined)
+ (..reference name top_outer))
+ [ref inner'] (list\fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)])
+ (function (_ scope ref+inner)
+ [(#variable.Foreign (get@ [#.captured #.counter] scope))
+ (#.Cons (update@ #.captured
+ (: (-> Foreign Foreign)
+ (|>> (update@ #.counter inc)
+ (update@ #.mappings (plist.put name [ref_type (product.left ref+inner)]))))
+ scope)
+ (product.right ref+inner))]))
+ [init_ref #.Nil]
+ (list.reverse inner))
+ scopes (list\compose inner' outer)]
+ (#.Right [(set@ #.scopes scopes state)
+ (#.Some [ref_type ref])]))
+ )))))
+
+(exception: #export cannot_create_local_binding_without_a_scope)
+(exception: #export invalid_scope_alteration)
+
+(def: #export (with_local [name type] action)
+ (All [a] (-> [Text Type] (Operation a) (Operation a)))
+ (function (_ [bundle state])
+ (case (get@ #.scopes state)
+ (#.Cons head tail)
+ (let [old_mappings (get@ [#.locals #.mappings] head)
+ new_var_id (get@ [#.locals #.counter] head)
+ new_head (update@ #.locals
+ (: (-> Local Local)
+ (|>> (update@ #.counter inc)
+ (update@ #.mappings (plist.put name [type new_var_id]))))
+ head)]
+ (case (///.run' [bundle (set@ #.scopes (#.Cons new_head tail) state)]
+ action)
+ (#try.Success [[bundle' state'] output])
+ (case (get@ #.scopes state')
+ (#.Cons head' tail')
+ (let [scopes' (#.Cons (set@ #.locals (get@ #.locals head) head')
+ tail')]
+ (#try.Success [[bundle' (set@ #.scopes scopes' state')]
+ output]))
+
+ _
+ (exception.throw ..invalid_scope_alteration []))
+
+ (#try.Failure error)
+ (#try.Failure error)))
+
+ _
+ (exception.throw ..cannot_create_local_binding_without_a_scope []))
+ ))
+
+(template [<name> <val_type>]
+ [(def: <name>
+ (Bindings Text [Type <val_type>])
+ {#.counter 0
+ #.mappings (list)})]
+
+ [init_locals Nat]
+ [init_captured Variable]
+ )
+
+(def: (scope parent_name child_name)
+ (-> (List Text) Text Scope)
+ {#.name (list& child_name parent_name)
+ #.inner 0
+ #.locals init_locals
+ #.captured init_captured})
+
+(def: #export (with_scope name action)
+ (All [a] (-> Text (Operation a) (Operation a)))
+ (function (_ [bundle state])
+ (let [parent_name (case (get@ #.scopes state)
+ #.Nil
+ (list)
+
+ (#.Cons top _)
+ (get@ #.name top))]
+ (case (action [bundle (update@ #.scopes
+ (|>> (#.Cons (scope parent_name name)))
+ state)])
+ (#try.Success [[bundle' state'] output])
+ (#try.Success [[bundle' (update@ #.scopes
+ (|>> list.tail (maybe.default (list)))
+ state')]
+ output])
+
+ (#try.Failure error)
+ (#try.Failure error)))
+ ))
+
+(exception: #export cannot_get_next_reference_when_there_is_no_scope)
+
+(def: #export next_local
+ (Operation Register)
+ (///extension.lift
+ (function (_ state)
+ (case (get@ #.scopes state)
+ (#.Cons top _)
+ (#try.Success [state (get@ [#.locals #.counter] top)])
+
+ #.Nil
+ (exception.throw ..cannot_get_next_reference_when_there_is_no_scope [])))))
+
+(def: (ref_to_variable ref)
+ (-> Ref Variable)
+ (case ref
+ (#.Local register)
+ (#variable.Local register)
+
+ (#.Captured register)
+ (#variable.Foreign register)))
+
+(def: #export (environment scope)
+ (-> Scope (List Variable))
+ (|> scope
+ (get@ [#.captured #.mappings])
+ (list\map (function (_ [_ [_ ref]]) (ref_to_variable ref)))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux
new file mode 100644
index 000000000..0f8106a7d
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux
@@ -0,0 +1,361 @@
+(.module:
+ [library
+ [lux #*
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["ex" exception (#+ exception:)]
+ ["." state]]
+ [data
+ ["." name]
+ ["." product]
+ ["." maybe]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." dictionary (#+ Dictionary)]]]
+ [macro
+ ["." code]]
+ [math
+ [number
+ ["n" nat]]]
+ ["." type
+ ["." check]]]]
+ ["." // #_
+ ["#." type]
+ ["#." primitive]
+ ["#." inference]
+ ["/#" // #_
+ ["#." extension]
+ [//
+ ["/" analysis (#+ Tag Analysis Operation Phase)]
+ [///
+ ["#" phase]
+ [meta
+ [archive (#+ Archive)]]]]]])
+
+(exception: #export (invalid_variant_type {type Type} {tag Tag} {code Code})
+ (ex.report ["Type" (%.type type)]
+ ["Tag" (%.nat tag)]
+ ["Expression" (%.code code)]))
+
+(template [<name>]
+ [(exception: #export (<name> {type Type} {members (List Code)})
+ (ex.report ["Type" (%.type type)]
+ ["Expression" (%.code (` [(~+ members)]))]))]
+
+ [invalid_tuple_type]
+ [cannot_analyse_tuple]
+ )
+
+(exception: #export (not_a_quantified_type {type Type})
+ (%.type type))
+
+(template [<name>]
+ [(exception: #export (<name> {type Type} {tag Tag} {code Code})
+ (ex.report ["Type" (%.type type)]
+ ["Tag" (%.nat tag)]
+ ["Expression" (%.code code)]))]
+
+ [cannot_analyse_variant]
+ [cannot_infer_numeric_tag]
+ )
+
+(exception: #export (record_keys_must_be_tags {key Code} {record (List [Code Code])})
+ (ex.report ["Key" (%.code key)]
+ ["Record" (%.code (code.record record))]))
+
+(template [<name>]
+ [(exception: #export (<name> {key Name} {record (List [Name Code])})
+ (ex.report ["Tag" (%.code (code.tag key))]
+ ["Record" (%.code (code.record (list\map (function (_ [keyI valC])
+ [(code.tag keyI) valC])
+ record)))]))]
+
+ [cannot_repeat_tag]
+ )
+
+(exception: #export (tag_does_not_belong_to_record {key Name} {type Type})
+ (ex.report ["Tag" (%.code (code.tag key))]
+ ["Type" (%.type type)]))
+
+(exception: #export (record_size_mismatch {expected Nat} {actual Nat} {type Type} {record (List [Name Code])})
+ (ex.report ["Expected" (%.nat expected)]
+ ["Actual" (%.nat actual)]
+ ["Type" (%.type type)]
+ ["Expression" (%.code (|> record
+ (list\map (function (_ [keyI valueC])
+ [(code.tag keyI) valueC]))
+ code.record))]))
+
+(def: #export (sum analyse lefts right? archive)
+ (-> Phase Nat Bit Phase)
+ (let [tag (/.tag lefts right?)]
+ (function (recur valueC)
+ (do {! ///.monad}
+ [expectedT (///extension.lift meta.expected_type)
+ expectedT' (//type.with_env
+ (check.clean expectedT))]
+ (/.with_stack ..cannot_analyse_variant [expectedT' tag valueC]
+ (case expectedT
+ (#.Sum _)
+ (let [flat (type.flatten_variant expectedT)]
+ (case (list.nth tag flat)
+ (#.Some variant_type)
+ (do !
+ [valueA (//type.with_type variant_type
+ (analyse archive valueC))]
+ (wrap (/.variant [lefts right? valueA])))
+
+ #.None
+ (/.throw //inference.variant_tag_out_of_bounds [(list.size flat) tag expectedT])))
+
+ (#.Named name unnamedT)
+ (//type.with_type unnamedT
+ (recur valueC))
+
+ (#.Var id)
+ (do !
+ [?expectedT' (//type.with_env
+ (check.read id))]
+ (case ?expectedT'
+ (#.Some expectedT')
+ (//type.with_type expectedT'
+ (recur valueC))
+
+ ## Cannot do inference when the tag is numeric.
+ ## This is because there is no way of knowing how many
+ ## cases the inferred sum type would have.
+ _
+ (/.throw ..cannot_infer_numeric_tag [expectedT tag valueC])))
+
+ (^template [<tag> <instancer>]
+ [(<tag> _)
+ (do !
+ [[instance_id instanceT] (//type.with_env <instancer>)]
+ (//type.with_type (maybe.assume (type.apply (list instanceT) expectedT))
+ (recur valueC)))])
+ ([#.UnivQ check.existential]
+ [#.ExQ check.var])
+
+ (#.Apply inputT funT)
+ (case funT
+ (#.Var funT_id)
+ (do !
+ [?funT' (//type.with_env (check.read funT_id))]
+ (case ?funT'
+ (#.Some funT')
+ (//type.with_type (#.Apply inputT funT')
+ (recur valueC))
+
+ _
+ (/.throw ..invalid_variant_type [expectedT tag valueC])))
+
+ _
+ (case (type.apply (list inputT) funT)
+ (#.Some outputT)
+ (//type.with_type outputT
+ (recur valueC))
+
+ #.None
+ (/.throw ..not_a_quantified_type funT)))
+
+ _
+ (/.throw ..invalid_variant_type [expectedT tag valueC])))))))
+
+(def: (typed_product archive analyse members)
+ (-> Archive Phase (List Code) (Operation Analysis))
+ (do {! ///.monad}
+ [expectedT (///extension.lift meta.expected_type)
+ membersA+ (: (Operation (List Analysis))
+ (loop [membersT+ (type.flatten_tuple expectedT)
+ membersC+ members]
+ (case [membersT+ membersC+]
+ [(#.Cons memberT #.Nil) _]
+ (//type.with_type memberT
+ (\ ! map (|>> list) (analyse archive (code.tuple membersC+))))
+
+ [_ (#.Cons memberC #.Nil)]
+ (//type.with_type (type.tuple membersT+)
+ (\ ! map (|>> list) (analyse archive memberC)))
+
+ [(#.Cons memberT membersT+') (#.Cons memberC membersC+')]
+ (do !
+ [memberA (//type.with_type memberT
+ (analyse archive memberC))
+ memberA+ (recur membersT+' membersC+')]
+ (wrap (#.Cons memberA memberA+)))
+
+ _
+ (/.throw ..cannot_analyse_tuple [expectedT members]))))]
+ (wrap (/.tuple membersA+))))
+
+(def: #export (product archive analyse membersC)
+ (-> Archive Phase (List Code) (Operation Analysis))
+ (do {! ///.monad}
+ [expectedT (///extension.lift meta.expected_type)]
+ (/.with_stack ..cannot_analyse_tuple [expectedT membersC]
+ (case expectedT
+ (#.Product _)
+ (..typed_product archive analyse membersC)
+
+ (#.Named name unnamedT)
+ (//type.with_type unnamedT
+ (product archive analyse membersC))
+
+ (#.Var id)
+ (do !
+ [?expectedT' (//type.with_env
+ (check.read id))]
+ (case ?expectedT'
+ (#.Some expectedT')
+ (//type.with_type expectedT'
+ (product archive analyse membersC))
+
+ _
+ ## Must do inference...
+ (do !
+ [membersTA (monad.map ! (|>> (analyse archive) //type.with_inference)
+ membersC)
+ _ (//type.with_env
+ (check.check expectedT
+ (type.tuple (list\map product.left membersTA))))]
+ (wrap (/.tuple (list\map product.right membersTA))))))
+
+ (^template [<tag> <instancer>]
+ [(<tag> _)
+ (do !
+ [[instance_id instanceT] (//type.with_env <instancer>)]
+ (//type.with_type (maybe.assume (type.apply (list instanceT) expectedT))
+ (product archive analyse membersC)))])
+ ([#.UnivQ check.existential]
+ [#.ExQ check.var])
+
+ (#.Apply inputT funT)
+ (case funT
+ (#.Var funT_id)
+ (do !
+ [?funT' (//type.with_env (check.read funT_id))]
+ (case ?funT'
+ (#.Some funT')
+ (//type.with_type (#.Apply inputT funT')
+ (product archive analyse membersC))
+
+ _
+ (/.throw ..invalid_tuple_type [expectedT membersC])))
+
+ _
+ (case (type.apply (list inputT) funT)
+ (#.Some outputT)
+ (//type.with_type outputT
+ (product archive analyse membersC))
+
+ #.None
+ (/.throw ..not_a_quantified_type funT)))
+
+ _
+ (/.throw ..invalid_tuple_type [expectedT membersC])
+ ))))
+
+(def: #export (tagged_sum analyse tag archive valueC)
+ (-> Phase Name Phase)
+ (do {! ///.monad}
+ [tag (///extension.lift (meta.normalize tag))
+ [idx group variantT] (///extension.lift (meta.resolve_tag tag))
+ #let [case_size (list.size group)
+ [lefts right?] (/.choice case_size idx)]
+ expectedT (///extension.lift meta.expected_type)]
+ (case expectedT
+ (#.Var _)
+ (do !
+ [inferenceT (//inference.variant idx case_size variantT)
+ [inferredT valueA+] (//inference.general archive analyse inferenceT (list valueC))]
+ (wrap (/.variant [lefts right? (|> valueA+ list.head maybe.assume)])))
+
+ _
+ (..sum analyse lefts right? archive valueC))))
+
+## There cannot be any ambiguity or improper syntax when analysing
+## records, so they must be normalized for further analysis.
+## Normalization just means that all the tags get resolved to their
+## canonical form (with their corresponding module identified).
+(def: #export (normalize record)
+ (-> (List [Code Code]) (Operation (List [Name Code])))
+ (monad.map ///.monad
+ (function (_ [key val])
+ (case key
+ [_ (#.Tag key)]
+ (do ///.monad
+ [key (///extension.lift (meta.normalize key))]
+ (wrap [key val]))
+
+ _
+ (/.throw ..record_keys_must_be_tags [key record])))
+ record))
+
+## Lux already possesses the means to analyse tuples, so
+## re-implementing the same functionality for records makes no sense.
+## Records, thus, get transformed into tuples by ordering the elements.
+(def: #export (order record)
+ (-> (List [Name Code]) (Operation [(List Code) Type]))
+ (case record
+ ## empty_record = empty_tuple = unit = []
+ #.Nil
+ (\ ///.monad wrap [(list) Any])
+
+ (#.Cons [head_k head_v] _)
+ (do {! ///.monad}
+ [head_k (///extension.lift (meta.normalize head_k))
+ [_ tag_set recordT] (///extension.lift (meta.resolve_tag head_k))
+ #let [size_record (list.size record)
+ size_ts (list.size tag_set)]
+ _ (if (n.= size_ts size_record)
+ (wrap [])
+ (/.throw ..record_size_mismatch [size_ts size_record recordT record]))
+ #let [tuple_range (list.indices size_ts)
+ tag->idx (dictionary.from_list name.hash (list.zip/2 tag_set tuple_range))]
+ idx->val (monad.fold !
+ (function (_ [key val] idx->val)
+ (do !
+ [key (///extension.lift (meta.normalize key))]
+ (case (dictionary.get key tag->idx)
+ (#.Some idx)
+ (if (dictionary.key? idx->val idx)
+ (/.throw ..cannot_repeat_tag [key record])
+ (wrap (dictionary.put idx val idx->val)))
+
+ #.None
+ (/.throw ..tag_does_not_belong_to_record [key recordT]))))
+ (: (Dictionary Nat Code)
+ (dictionary.new n.hash))
+ record)
+ #let [ordered_tuple (list\map (function (_ idx) (maybe.assume (dictionary.get idx idx->val)))
+ tuple_range)]]
+ (wrap [ordered_tuple recordT]))
+ ))
+
+(def: #export (record archive analyse members)
+ (-> Archive Phase (List [Code Code]) (Operation Analysis))
+ (case members
+ (^ (list))
+ //primitive.unit
+
+ (^ (list [_ singletonC]))
+ (analyse archive singletonC)
+
+ _
+ (do {! ///.monad}
+ [members (normalize members)
+ [membersC recordT] (order members)
+ expectedT (///extension.lift meta.expected_type)]
+ (case expectedT
+ (#.Var _)
+ (do !
+ [inferenceT (//inference.record recordT)
+ [inferredT membersA] (//inference.general archive analyse inferenceT membersC)]
+ (wrap (/.tuple membersA)))
+
+ _
+ (..product archive analyse membersC)))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/type.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/type.lux
new file mode 100644
index 000000000..61948e7c2
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/type.lux
@@ -0,0 +1,56 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try]]
+ [type
+ ["." check (#+ Check)]]
+ ["." meta]]]
+ ["." /// #_
+ ["#." extension]
+ [//
+ ["/" analysis (#+ Operation)]
+ [///
+ ["#" phase]]]])
+
+(def: #export (with_type expected)
+ (All [a] (-> Type (Operation a) (Operation a)))
+ (///extension.localized (get@ #.expected) (set@ #.expected)
+ (function.constant (#.Some expected))))
+
+(def: #export (with_env action)
+ (All [a] (-> (Check a) (Operation a)))
+ (function (_ (^@ stateE [bundle state]))
+ (case (action (get@ #.type_context state))
+ (#try.Success [context' output])
+ (#try.Success [[bundle (set@ #.type_context context' state)]
+ output])
+
+ (#try.Failure error)
+ ((/.fail error) stateE))))
+
+(def: #export with_fresh_env
+ (All [a] (-> (Operation a) (Operation a)))
+ (///extension.localized (get@ #.type_context) (set@ #.type_context)
+ (function.constant check.fresh_context)))
+
+(def: #export (infer actualT)
+ (-> Type (Operation Any))
+ (do ///.monad
+ [expectedT (///extension.lift meta.expected_type)]
+ (with_env
+ (check.check expectedT actualT))))
+
+(def: #export (with_inference action)
+ (All [a] (-> (Operation a) (Operation [Type a])))
+ (do ///.monad
+ [[_ varT] (..with_env
+ check.var)
+ output (with_type varT
+ action)
+ knownT (..with_env
+ (check.clean varT))]
+ (wrap [knownT output])))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/directive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/directive.lux
new file mode 100644
index 000000000..882ac3a6e
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/directive.lux
@@ -0,0 +1,79 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]]
+ [data
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." fold monoid)]]]
+ ["." meta]]]
+ ["." // #_
+ ["#." extension]
+ ["#." analysis
+ ["#/." type]]
+ ["/#" // #_
+ ["/" directive (#+ Phase)]
+ ["#." analysis
+ ["#/." macro (#+ Expander)]]
+ [///
+ ["//" phase]
+ [reference (#+)
+ [variable (#+)]]]]])
+
+(exception: #export (not_a_directive {code Code})
+ (exception.report
+ ["Directive" (%.code code)]))
+
+(exception: #export (invalid_macro_call {code Code})
+ (exception.report
+ ["Code" (%.code code)]))
+
+(exception: #export (macro_was_not_found {name Name})
+ (exception.report
+ ["Name" (%.name name)]))
+
+(with_expansions [<lux_def_module> (as_is [|form_location| (#.Form (list& [|text_location| (#.Text "lux def module")] annotations))])]
+ (def: #export (phase expander)
+ (-> Expander Phase)
+ (let [analyze (//analysis.phase expander)]
+ (function (recur archive code)
+ (case code
+ (^ [_ (#.Form (list& [_ (#.Text name)] inputs))])
+ (//extension.apply archive recur [name inputs])
+
+ (^ [_ (#.Form (list& macro inputs))])
+ (do {! //.monad}
+ [expansion (/.lift_analysis
+ (do !
+ [macroA (//analysis/type.with_type Macro
+ (analyze archive macro))]
+ (case macroA
+ (^ (///analysis.constant macro_name))
+ (do !
+ [?macro (//extension.lift (meta.find_macro macro_name))
+ macro (case ?macro
+ (#.Some macro)
+ (wrap macro)
+
+ #.None
+ (//.throw ..macro_was_not_found macro_name))]
+ (//extension.lift (///analysis/macro.expand expander macro_name macro inputs)))
+
+ _
+ (//.throw ..invalid_macro_call code))))]
+ (case expansion
+ (^ (list& <lux_def_module> referrals))
+ (|> (recur archive <lux_def_module>)
+ (\ ! map (update@ #/.referrals (list\compose referrals))))
+
+ _
+ (|> expansion
+ (monad.map ! (recur archive))
+ (\ ! map (list\fold /.merge_requirements /.no_requirements)))))
+
+ _
+ (//.throw ..not_a_directive code))))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension.lux
new file mode 100644
index 000000000..fd30c45d2
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension.lux
@@ -0,0 +1,177 @@
+(.module:
+ [library
+ [lux (#- Name)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." product]
+ ["." text ("#\." order)
+ ["%" format (#+ Format format)]]
+ [collection
+ ["." list]
+ ["." dictionary (#+ Dictionary)]]]]]
+ [/////
+ ["//" phase]
+ [meta
+ [archive (#+ Archive)]]])
+
+(type: #export Name
+ Text)
+
+(type: #export (Extension a)
+ [Name (List a)])
+
+(def: #export equivalence
+ (All [a] (-> (Equivalence a) (Equivalence (Extension a))))
+ (|>> list.equivalence
+ (product.equivalence text.equivalence)))
+
+(def: #export hash
+ (All [a] (-> (Hash a) (Hash (Extension a))))
+ (|>> list.hash
+ (product.hash text.hash)))
+
+(with_expansions [<Bundle> (as_is (Dictionary Name (Handler s i o)))]
+ (type: #export (Handler s i o)
+ (-> Name
+ (//.Phase [<Bundle> s] i o)
+ (//.Phase [<Bundle> s] (List i) o)))
+
+ (type: #export (Bundle s i o)
+ <Bundle>))
+
+(def: #export empty
+ Bundle
+ (dictionary.new text.hash))
+
+(type: #export (State s i o)
+ {#bundle (Bundle s i o)
+ #state s})
+
+(type: #export (Operation s i o v)
+ (//.Operation (State s i o) v))
+
+(type: #export (Phase s i o)
+ (//.Phase (State s i o) i o))
+
+(exception: #export (cannot_overwrite {name Name})
+ (exception.report
+ ["Extension" (%.text name)]))
+
+(exception: #export (incorrect_arity {name Name} {arity Nat} {args Nat})
+ (exception.report
+ ["Extension" (%.text name)]
+ ["Expected" (%.nat arity)]
+ ["Actual" (%.nat args)]))
+
+(exception: #export [a] (invalid_syntax {name Name} {%format (Format a)} {inputs (List a)})
+ (exception.report
+ ["Extension" (%.text name)]
+ ["Inputs" (exception.enumerate %format inputs)]))
+
+(exception: #export [s i o] (unknown {name Name} {bundle (Bundle s i o)})
+ (exception.report
+ ["Extension" (%.text name)]
+ ["Available" (|> bundle
+ dictionary.keys
+ (list.sort text\<)
+ (exception.enumerate %.text))]))
+
+(type: #export (Extender s i o)
+ (-> Any (Handler s i o)))
+
+(def: #export (install extender name handler)
+ (All [s i o]
+ (-> (Extender s i o) Text (Handler s i o) (Operation s i o Any)))
+ (function (_ [bundle state])
+ (case (dictionary.get name bundle)
+ #.None
+ (#try.Success [[(dictionary.put name (extender handler) bundle) state]
+ []])
+
+ _
+ (exception.throw ..cannot_overwrite name))))
+
+(def: #export (with extender extensions)
+ (All [s i o]
+ (-> Extender (Bundle s i o) (Operation s i o Any)))
+ (|> extensions
+ dictionary.entries
+ (monad.fold //.monad
+ (function (_ [extension handle] output)
+ (..install extender extension handle))
+ [])))
+
+(def: #export (apply archive phase [name parameters])
+ (All [s i o]
+ (-> Archive (Phase s i o) (Extension i) (Operation s i o o)))
+ (function (_ (^@ stateE [bundle state]))
+ (case (dictionary.get name bundle)
+ (#.Some handler)
+ (((handler name phase) archive parameters)
+ stateE)
+
+ #.None
+ (exception.throw ..unknown [name bundle]))))
+
+(def: #export (localized get set transform)
+ (All [s s' i o v]
+ (-> (-> s s') (-> s' s s) (-> s' s')
+ (-> (Operation s i o v) (Operation s i o v))))
+ (function (_ operation)
+ (function (_ [bundle state])
+ (let [old (get state)]
+ (case (operation [bundle (set (transform old) state)])
+ (#try.Success [[bundle' state'] output])
+ (#try.Success [[bundle' (set old state')] output])
+
+ (#try.Failure error)
+ (#try.Failure error))))))
+
+(def: #export (temporary transform)
+ (All [s i o v]
+ (-> (-> s s)
+ (-> (Operation s i o v) (Operation s i o v))))
+ (function (_ operation)
+ (function (_ [bundle state])
+ (case (operation [bundle (transform state)])
+ (#try.Success [[bundle' state'] output])
+ (#try.Success [[bundle' state] output])
+
+ (#try.Failure error)
+ (#try.Failure error)))))
+
+(def: #export (with_state state)
+ (All [s i o v]
+ (-> s (-> (Operation s i o v) (Operation s i o v))))
+ (..temporary (function.constant state)))
+
+(def: #export (read get)
+ (All [s i o v]
+ (-> (-> s v) (Operation s i o v)))
+ (function (_ [bundle state])
+ (#try.Success [[bundle state] (get state)])))
+
+(def: #export (update transform)
+ (All [s i o]
+ (-> (-> s s) (Operation s i o Any)))
+ (function (_ [bundle state])
+ (#try.Success [[bundle (transform state)] []])))
+
+(def: #export (lift action)
+ (All [s i o v]
+ (-> (//.Operation s v)
+ (//.Operation [(Bundle s i o) s] v)))
+ (function (_ [bundle state])
+ (case (action state)
+ (#try.Success [state' output])
+ (#try.Success [[bundle state'] output])
+
+ (#try.Failure error)
+ (#try.Failure error))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis.lux
new file mode 100644
index 000000000..a1a979555
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis.lux
@@ -0,0 +1,16 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]]
+ [////
+ [analysis (#+ Bundle)
+ [evaluation (#+ Eval)]]]
+ ["." / #_
+ ["#." lux]])
+
+(def: #export (bundle eval host-specific)
+ (-> Eval Bundle Bundle)
+ (dictionary.merge host-specific
+ (/lux.bundle eval)))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux
new file mode 100644
index 000000000..348124448
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux
@@ -0,0 +1,35 @@
+(.module:
+ [library
+ [lux #*
+ ["." ffi]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<c>" code (#+ Parser)]]]
+ [data
+ [collection
+ ["." array (#+ Array)]
+ ["." dictionary]
+ ["." list]]]
+ ["." type
+ ["." check]]
+ ["@" target
+ ["_" common_lisp]]]]
+ [//
+ ["/" lux (#+ custom)]
+ [//
+ ["." bundle]
+ [//
+ ["." analysis #_
+ ["#/." type]]
+ [//
+ ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
+ [///
+ ["." phase]]]]]])
+
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "common_lisp")
+ (|> bundle.empty
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux
new file mode 100644
index 000000000..5660a2a85
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux
@@ -0,0 +1,218 @@
+(.module:
+ [library
+ [lux #*
+ ["." ffi]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<c>" code (#+ Parser)]]]
+ [data
+ [collection
+ ["." array (#+ Array)]
+ ["." dictionary]
+ ["." list]]]
+ ["." type
+ ["." check]]
+ ["@" target
+ ["_" js]]]]
+ [//
+ ["/" lux (#+ custom)]
+ [//
+ ["." bundle]
+ [//
+ ["." analysis #_
+ ["#/." type]]
+ [//
+ ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
+ [///
+ ["." phase]]]]]])
+
+(def: array::new
+ Handler
+ (custom
+ [<c>.any
+ (function (_ extension phase archive lengthC)
+ (do phase.monad
+ [lengthA (analysis/type.with_type Nat
+ (phase archive lengthC))
+ [var_id varT] (analysis/type.with_env check.var)
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list lengthA)))))]))
+
+(def: array::length
+ Handler
+ (custom
+ [<c>.any
+ (function (_ extension phase archive arrayC)
+ (do phase.monad
+ [[var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer Nat)]
+ (wrap (#analysis.Extension extension (list arrayA)))))]))
+
+(def: array::read
+ Handler
+ (custom
+ [(<>.and <c>.any <c>.any)
+ (function (_ extension phase archive [indexC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer varT)]
+ (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
+
+(def: array::write
+ Handler
+ (custom
+ [($_ <>.and <c>.any <c>.any <c>.any)
+ (function (_ extension phase archive [indexC valueC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ valueA (analysis/type.with_type varT
+ (phase archive valueC))
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))]))
+
+(def: array::delete
+ Handler
+ (custom
+ [($_ <>.and <c>.any <c>.any)
+ (function (_ extension phase archive [indexC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
+
+(def: bundle::array
+ Bundle
+ (<| (bundle.prefix "array")
+ (|> bundle.empty
+ (bundle.install "new" array::new)
+ (bundle.install "length" array::length)
+ (bundle.install "read" array::read)
+ (bundle.install "write" array::write)
+ (bundle.install "delete" array::delete)
+ )))
+
+(def: object::new
+ Handler
+ (custom
+ [($_ <>.and <c>.any (<c>.tuple (<>.some <c>.any)))
+ (function (_ extension phase archive [constructorC inputsC])
+ (do {! phase.monad}
+ [constructorA (analysis/type.with_type Any
+ (phase archive constructorC))
+ inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
+ _ (analysis/type.infer .Any)]
+ (wrap (#analysis.Extension extension (list& constructorA inputsA)))))]))
+
+(def: object::get
+ Handler
+ (custom
+ [($_ <>.and <c>.text <c>.any)
+ (function (_ extension phase archive [fieldC objectC])
+ (do phase.monad
+ [objectA (analysis/type.with_type Any
+ (phase archive objectC))
+ _ (analysis/type.infer .Any)]
+ (wrap (#analysis.Extension extension (list (analysis.text fieldC)
+ objectA)))))]))
+
+(def: object::do
+ Handler
+ (custom
+ [($_ <>.and <c>.text <c>.any (<c>.tuple (<>.some <c>.any)))
+ (function (_ extension phase archive [methodC objectC inputsC])
+ (do {! phase.monad}
+ [objectA (analysis/type.with_type Any
+ (phase archive objectC))
+ inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
+ _ (analysis/type.infer .Any)]
+ (wrap (#analysis.Extension extension (list& (analysis.text methodC)
+ objectA
+ inputsA)))))]))
+
+(def: bundle::object
+ Bundle
+ (<| (bundle.prefix "object")
+ (|> bundle.empty
+ (bundle.install "new" object::new)
+ (bundle.install "get" object::get)
+ (bundle.install "do" object::do)
+ (bundle.install "null" (/.nullary Any))
+ (bundle.install "null?" (/.unary Any Bit))
+ (bundle.install "undefined" (/.nullary Any))
+ (bundle.install "undefined?" (/.unary Any Bit))
+ )))
+
+(def: js::constant
+ Handler
+ (custom
+ [<c>.text
+ (function (_ extension phase archive name)
+ (do phase.monad
+ [_ (analysis/type.infer Any)]
+ (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
+
+(def: js::apply
+ Handler
+ (custom
+ [($_ <>.and <c>.any (<>.some <c>.any))
+ (function (_ extension phase archive [abstractionC inputsC])
+ (do {! phase.monad}
+ [abstractionA (analysis/type.with_type Any
+ (phase archive abstractionC))
+ inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
+ _ (analysis/type.infer Any)]
+ (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))]))
+
+(def: js::type_of
+ Handler
+ (custom
+ [<c>.any
+ (function (_ extension phase archive objectC)
+ (do phase.monad
+ [objectA (analysis/type.with_type Any
+ (phase archive objectC))
+ _ (analysis/type.infer .Text)]
+ (wrap (#analysis.Extension extension (list objectA)))))]))
+
+(def: js::function
+ Handler
+ (custom
+ [($_ <>.and <c>.nat <c>.any)
+ (function (_ extension phase archive [arity abstractionC])
+ (do phase.monad
+ [#let [inputT (type.tuple (list.repeat arity Any))]
+ abstractionA (analysis/type.with_type (-> inputT Any)
+ (phase archive abstractionC))
+ _ (analysis/type.infer (for {@.js ffi.Function}
+ Any))]
+ (wrap (#analysis.Extension extension (list (analysis.nat arity)
+ abstractionA)))))]))
+
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "js")
+ (|> bundle.empty
+ (dictionary.merge bundle::array)
+ (dictionary.merge bundle::object)
+
+ (bundle.install "constant" js::constant)
+ (bundle.install "apply" js::apply)
+ (bundle.install "type-of" js::type_of)
+ (bundle.install "function" js::function)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux
new file mode 100644
index 000000000..76bcd528e
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux
@@ -0,0 +1,2076 @@
+(.module:
+ [library
+ [lux (#- Type Module primitive type char int)
+ ["." ffi (#+ import:)]
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ pipe
+ ["." try (#+ Try) ("#\." monad)]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<.>" code (#+ Parser)]
+ ["<.>" text]]]
+ [data
+ ["." maybe]
+ ["." product]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." fold monad monoid)]
+ ["." array]
+ ["." dictionary (#+ Dictionary)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [target
+ ["." jvm #_
+ [".!" reflection]
+ [encoding
+ [name (#+ External)]]
+ ["#" type (#+ Type Argument Typed) ("#\." equivalence)
+ ["." category (#+ Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method)]
+ ["." box]
+ ["." reflection]
+ ["." descriptor]
+ ["." signature]
+ ["#_." parser]
+ ["#_." alias (#+ Aliasing)]
+ [".T" lux (#+ Mapping)]]]]
+ ["." type
+ ["." check (#+ Check) ("#\." monad)]]]]
+ ["." // #_
+ ["#." lux (#+ custom)]
+ ["/#" //
+ ["#." bundle]
+ ["/#" // #_
+ [analysis
+ [".A" type]
+ [".A" inference]
+ ["." scope]]
+ ["/#" // #_
+ ["#." analysis (#+ Analysis Operation Phase Handler Bundle)]
+ ["#." synthesis]
+ [///
+ ["." phase ("#\." monad)]
+ [meta
+ [archive (#+ Archive)
+ [descriptor (#+ Module)]]]]]]]])
+
+(import: java/lang/Object
+ ["#::."
+ (equals [java/lang/Object] boolean)])
+
+(import: java/lang/reflect/Type)
+
+(import: (java/lang/reflect/TypeVariable d)
+ ["#::."
+ (getName [] java/lang/String)
+ (getBounds [] [java/lang/reflect/Type])])
+
+(import: java/lang/reflect/Modifier
+ ["#::."
+ (#static isStatic [int] boolean)
+ (#static isFinal [int] boolean)
+ (#static isInterface [int] boolean)
+ (#static isAbstract [int] boolean)])
+
+(import: java/lang/annotation/Annotation)
+
+(import: java/lang/reflect/Method
+ ["#::."
+ (getName [] java/lang/String)
+ (getModifiers [] int)
+ (getDeclaringClass [] (java/lang/Class java/lang/Object))
+ (getTypeParameters [] [(java/lang/reflect/TypeVariable java/lang/reflect/Method)])
+ (getGenericParameterTypes [] [java/lang/reflect/Type])
+ (getGenericReturnType [] java/lang/reflect/Type)
+ (getGenericExceptionTypes [] [java/lang/reflect/Type])
+ (getDeclaredAnnotations [] [java/lang/annotation/Annotation])])
+
+(import: (java/lang/reflect/Constructor c)
+ ["#::."
+ (getModifiers [] int)
+ (getDeclaringClass [] (java/lang/Class c))
+ (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/reflect/Constructor c))])
+ (getGenericParameterTypes [] [java/lang/reflect/Type])
+ (getGenericExceptionTypes [] [java/lang/reflect/Type])
+ (getDeclaredAnnotations [] [java/lang/annotation/Annotation])])
+
+(import: (java/lang/Class c)
+ ["#::."
+ (#static forName [java/lang/String] #try (java/lang/Class java/lang/Object))
+ (getName [] java/lang/String)
+ (getModifiers [] int)
+ (isAssignableFrom [(java/lang/Class java/lang/Object)] boolean)
+ (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/Class c))])
+ (getGenericInterfaces [] [java/lang/reflect/Type])
+ (getGenericSuperclass [] #? java/lang/reflect/Type)
+ (getDeclaredField [java/lang/String] #try java/lang/reflect/Field)
+ (getConstructors [] [(java/lang/reflect/Constructor java/lang/Object)])
+ (getDeclaredMethods [] [java/lang/reflect/Method])
+ (getDeclaredAnnotations [] [java/lang/annotation/Annotation])])
+
+(template [<name>]
+ [(exception: #export (<name> {class External} {field Text})
+ (exception.report
+ ["Class" (%.text class)]
+ ["Field" (%.text field)]))]
+
+ [cannot_set_a_final_field]
+ [deprecated_field]
+ )
+
+(exception: #export (deprecated_method {class External} {method Text} {type .Type})
+ (exception.report
+ ["Class" (%.text class)]
+ ["Method" (%.text method)]
+ ["Type" (%.type type)]))
+
+(exception: #export (deprecated_class {class External})
+ (exception.report
+ ["Class" (%.text class)]))
+
+(def: (ensure_fresh_class! name)
+ (-> External (Operation Any))
+ (do phase.monad
+ [class (phase.lift (reflection!.load name))]
+ (phase.assert ..deprecated_class [name]
+ (|> class
+ java/lang/Class::getDeclaredAnnotations
+ reflection!.deprecated?
+ not))))
+
+(def: reflection
+ (All [category]
+ (-> (Type (<| Return' Value' category)) Text))
+ (|>> jvm.reflection reflection.reflection))
+
+(def: signature (|>> jvm.signature signature.signature))
+
+(def: object_class
+ External
+ "java.lang.Object")
+
+(def: inheritance_relationship_type_name "_jvm_inheritance")
+(def: #export (inheritance_relationship_type class super_class super_interfaces)
+ (-> .Type .Type (List .Type) .Type)
+ (#.Primitive ..inheritance_relationship_type_name
+ (list& class super_class super_interfaces)))
+
+## TODO: Get rid of this template block and use the definition in
+## lux/ffi.jvm.lux ASAP
+(template [<name> <class>]
+ [(def: #export <name> .Type (#.Primitive <class> #.Nil))]
+
+ ## Boxes
+ [Boolean box.boolean]
+ [Byte box.byte]
+ [Short box.short]
+ [Integer box.int]
+ [Long box.long]
+ [Float box.float]
+ [Double box.double]
+ [Character box.char]
+ [String "java.lang.String"]
+
+ ## Primitives
+ [boolean (reflection.reflection reflection.boolean)]
+ [byte (reflection.reflection reflection.byte)]
+ [short (reflection.reflection reflection.short)]
+ [int (reflection.reflection reflection.int)]
+ [long (reflection.reflection reflection.long)]
+ [float (reflection.reflection reflection.float)]
+ [double (reflection.reflection reflection.double)]
+ [char (reflection.reflection reflection.char)]
+ )
+
+(type: Member
+ {#class External
+ #member Text})
+
+(def: member
+ (Parser Member)
+ ($_ <>.and <code>.text <code>.text))
+
+(type: Method_Signature
+ {#method .Type
+ #deprecated? Bit
+ #exceptions (List .Type)})
+
+(template [<name>]
+ [(exception: #export (<name> {type .Type})
+ (exception.report
+ ["Type" (%.type type)]))]
+
+ [non_object]
+ [non_array]
+ [non_parameter]
+ [non_jvm_type]
+ )
+
+(template [<name>]
+ [(exception: #export (<name> {class External})
+ (exception.report
+ ["Class/type" (%.text class)]))]
+
+ [non_interface]
+ [non_throwable]
+ [primitives_are_not_objects]
+ )
+
+(template [<name>]
+ [(exception: #export (<name> {class External}
+ {method Text}
+ {inputsJT (List (Type Value))}
+ {hints (List Method_Signature)})
+ (exception.report
+ ["Class" class]
+ ["Method" method]
+ ["Arguments" (exception.enumerate ..signature inputsJT)]
+ ["Hints" (exception.enumerate %.type (list\map product.left hints))]))]
+
+ [no_candidates]
+ [too_many_candidates]
+ )
+
+(exception: #export (cannot_cast {from .Type} {to .Type} {value Code})
+ (exception.report
+ ["From" (%.type from)]
+ ["To" (%.type to)]
+ ["Value" (%.code value)]))
+
+(template [<name>]
+ [(exception: #export (<name> {message Text})
+ message)]
+
+ [primitives_cannot_have_type_parameters]
+
+ [cannot_possibly_be_an_instance]
+
+ [unknown_type_var]
+ )
+
+(def: bundle::conversion
+ Bundle
+ (<| (///bundle.prefix "conversion")
+ (|> ///bundle.empty
+ (///bundle.install "double-to-float" (//lux.unary ..double ..float))
+ (///bundle.install "double-to-int" (//lux.unary ..double ..int))
+ (///bundle.install "double-to-long" (//lux.unary ..double ..long))
+ (///bundle.install "float-to-double" (//lux.unary ..float ..double))
+ (///bundle.install "float-to-int" (//lux.unary ..float ..int))
+ (///bundle.install "float-to-long" (//lux.unary ..float ..long))
+ (///bundle.install "int-to-byte" (//lux.unary ..int ..byte))
+ (///bundle.install "int-to-char" (//lux.unary ..int ..char))
+ (///bundle.install "int-to-double" (//lux.unary ..int ..double))
+ (///bundle.install "int-to-float" (//lux.unary ..int ..float))
+ (///bundle.install "int-to-long" (//lux.unary ..int ..long))
+ (///bundle.install "int-to-short" (//lux.unary ..int ..short))
+ (///bundle.install "long-to-double" (//lux.unary ..long ..double))
+ (///bundle.install "long-to-float" (//lux.unary ..long ..float))
+ (///bundle.install "long-to-int" (//lux.unary ..long ..int))
+ (///bundle.install "long-to-short" (//lux.unary ..long ..short))
+ (///bundle.install "long-to-byte" (//lux.unary ..long ..byte))
+ (///bundle.install "char-to-byte" (//lux.unary ..char ..byte))
+ (///bundle.install "char-to-short" (//lux.unary ..char ..short))
+ (///bundle.install "char-to-int" (//lux.unary ..char ..int))
+ (///bundle.install "char-to-long" (//lux.unary ..char ..long))
+ (///bundle.install "byte-to-long" (//lux.unary ..byte ..long))
+ (///bundle.install "short-to-long" (//lux.unary ..short ..long))
+ )))
+
+(template [<name> <prefix> <type>]
+ [(def: <name>
+ Bundle
+ (<| (///bundle.prefix (reflection.reflection <prefix>))
+ (|> ///bundle.empty
+ (///bundle.install "+" (//lux.binary <type> <type> <type>))
+ (///bundle.install "-" (//lux.binary <type> <type> <type>))
+ (///bundle.install "*" (//lux.binary <type> <type> <type>))
+ (///bundle.install "/" (//lux.binary <type> <type> <type>))
+ (///bundle.install "%" (//lux.binary <type> <type> <type>))
+ (///bundle.install "=" (//lux.binary <type> <type> Bit))
+ (///bundle.install "<" (//lux.binary <type> <type> Bit))
+ (///bundle.install "and" (//lux.binary <type> <type> <type>))
+ (///bundle.install "or" (//lux.binary <type> <type> <type>))
+ (///bundle.install "xor" (//lux.binary <type> <type> <type>))
+ (///bundle.install "shl" (//lux.binary ..int <type> <type>))
+ (///bundle.install "shr" (//lux.binary ..int <type> <type>))
+ (///bundle.install "ushr" (//lux.binary ..int <type> <type>))
+ )))]
+
+ [bundle::int reflection.int ..int]
+ [bundle::long reflection.long ..long]
+ )
+
+(template [<name> <prefix> <type>]
+ [(def: <name>
+ Bundle
+ (<| (///bundle.prefix (reflection.reflection <prefix>))
+ (|> ///bundle.empty
+ (///bundle.install "+" (//lux.binary <type> <type> <type>))
+ (///bundle.install "-" (//lux.binary <type> <type> <type>))
+ (///bundle.install "*" (//lux.binary <type> <type> <type>))
+ (///bundle.install "/" (//lux.binary <type> <type> <type>))
+ (///bundle.install "%" (//lux.binary <type> <type> <type>))
+ (///bundle.install "=" (//lux.binary <type> <type> Bit))
+ (///bundle.install "<" (//lux.binary <type> <type> Bit))
+ )))]
+
+ [bundle::float reflection.float ..float]
+ [bundle::double reflection.double ..double]
+ )
+
+(def: bundle::char
+ Bundle
+ (<| (///bundle.prefix (reflection.reflection reflection.char))
+ (|> ///bundle.empty
+ (///bundle.install "=" (//lux.binary ..char ..char Bit))
+ (///bundle.install "<" (//lux.binary ..char ..char Bit))
+ )))
+
+(def: #export boxes
+ (Dictionary External [External (Type Primitive)])
+ (|> (list [(reflection.reflection reflection.boolean) [box.boolean jvm.boolean]]
+ [(reflection.reflection reflection.byte) [box.byte jvm.byte]]
+ [(reflection.reflection reflection.short) [box.short jvm.short]]
+ [(reflection.reflection reflection.int) [box.int jvm.int]]
+ [(reflection.reflection reflection.long) [box.long jvm.long]]
+ [(reflection.reflection reflection.float) [box.float jvm.float]]
+ [(reflection.reflection reflection.double) [box.double jvm.double]]
+ [(reflection.reflection reflection.char) [box.char jvm.char]])
+ (dictionary.from_list text.hash)))
+
+(def: (jvm_type luxT)
+ (-> .Type (Operation (Type Value)))
+ (case luxT
+ (#.Named name anonymousT)
+ (jvm_type anonymousT)
+
+ (#.Apply inputT abstractionT)
+ (case (type.apply (list inputT) abstractionT)
+ (#.Some outputT)
+ (jvm_type outputT)
+
+ #.None
+ (/////analysis.throw ..non_jvm_type luxT))
+
+ (^ (#.Primitive (static array.type_name) (list elemT)))
+ (phase\map jvm.array (jvm_type elemT))
+
+ (#.Primitive class parametersT)
+ (case (dictionary.get class ..boxes)
+ (#.Some [_ primitive_type])
+ (case parametersT
+ #.Nil
+ (phase\wrap primitive_type)
+
+ _
+ (/////analysis.throw ..primitives_cannot_have_type_parameters class))
+
+ #.None
+ (do {! phase.monad}
+ [parametersJT (: (Operation (List (Type Parameter)))
+ (monad.map !
+ (function (_ parameterT)
+ (do phase.monad
+ [parameterJT (jvm_type parameterT)]
+ (case (jvm_parser.parameter? parameterJT)
+ (#.Some parameterJT)
+ (wrap parameterJT)
+
+ #.None
+ (/////analysis.throw ..non_parameter parameterT))))
+ parametersT))]
+ (wrap (jvm.class class parametersJT))))
+
+ (#.Ex _)
+ (phase\wrap (jvm.class ..object_class (list)))
+
+ _
+ (/////analysis.throw ..non_jvm_type luxT)))
+
+(def: (jvm_array_type objectT)
+ (-> .Type (Operation (Type Array)))
+ (do phase.monad
+ [objectJ (jvm_type objectT)]
+ (|> objectJ
+ ..signature
+ (<text>.run jvm_parser.array)
+ phase.lift)))
+
+(def: (primitive_array_length_handler primitive_type)
+ (-> (Type Primitive) Handler)
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list arrayC))
+ (do phase.monad
+ [_ (typeA.infer ..int)
+ arrayA (typeA.with_type (#.Primitive (|> (jvm.array primitive_type)
+ ..reflection)
+ (list))
+ (analyse archive arrayC))]
+ (wrap (#/////analysis.Extension extension_name (list arrayA))))
+
+ _
+ (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
+
+(def: array::length::object
+ Handler
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list arrayC))
+ (do phase.monad
+ [_ (typeA.infer ..int)
+ [var_id varT] (typeA.with_env check.var)
+ arrayA (typeA.with_type (.type (array.Array varT))
+ (analyse archive arrayC))
+ varT (typeA.with_env (check.clean varT))
+ arrayJT (jvm_array_type (.type (array.Array varT)))]
+ (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature arrayJT))
+ arrayA))))
+
+ _
+ (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
+
+(def: (new_primitive_array_handler primitive_type)
+ (-> (Type Primitive) Handler)
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list lengthC))
+ (do phase.monad
+ [lengthA (typeA.with_type ..int
+ (analyse archive lengthC))
+ _ (typeA.infer (#.Primitive (|> (jvm.array primitive_type) ..reflection)
+ (list)))]
+ (wrap (#/////analysis.Extension extension_name (list lengthA))))
+
+ _
+ (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
+
+(def: array::new::object
+ Handler
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list lengthC))
+ (do phase.monad
+ [lengthA (typeA.with_type ..int
+ (analyse archive lengthC))
+ expectedT (///.lift meta.expected_type)
+ expectedJT (jvm_array_type expectedT)
+ elementJT (case (jvm_parser.array? expectedJT)
+ (#.Some elementJT)
+ (wrap elementJT)
+
+ #.None
+ (/////analysis.throw ..non_array expectedT))]
+ (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature elementJT))
+ lengthA))))
+
+ _
+ (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
+
+(def: (check_parameter objectT)
+ (-> .Type (Operation (Type Parameter)))
+ (case objectT
+ (^ (#.Primitive (static array.type_name)
+ (list elementT)))
+ (/////analysis.throw ..non_parameter objectT)
+
+ (#.Primitive name parameters)
+ (`` (cond (or (~~ (template [<type>]
+ [(text\= (..reflection <type>) name)]
+
+ [jvm.boolean]
+ [jvm.byte]
+ [jvm.short]
+ [jvm.int]
+ [jvm.long]
+ [jvm.float]
+ [jvm.double]
+ [jvm.char]))
+ (text.starts_with? descriptor.array_prefix name))
+ (/////analysis.throw ..non_parameter objectT)
+
+ ## else
+ (phase\wrap (jvm.class name (list)))))
+
+ (#.Named name anonymous)
+ (check_parameter anonymous)
+
+ (^template [<tag>]
+ [(<tag> id)
+ (phase\wrap (jvm.class ..object_class (list)))])
+ ([#.Var]
+ [#.Ex])
+
+ (^template [<tag>]
+ [(<tag> env unquantified)
+ (check_parameter unquantified)])
+ ([#.UnivQ]
+ [#.ExQ])
+
+ (#.Apply inputT abstractionT)
+ (case (type.apply (list inputT) abstractionT)
+ (#.Some outputT)
+ (check_parameter outputT)
+
+ #.None
+ (/////analysis.throw ..non_parameter objectT))
+
+ _
+ (/////analysis.throw ..non_parameter objectT)))
+
+(def: (check_jvm objectT)
+ (-> .Type (Operation (Type Value)))
+ (case objectT
+ (#.Primitive name #.Nil)
+ (`` (cond (~~ (template [<type>]
+ [(text\= (..reflection <type>) name)
+ (phase\wrap <type>)]
+
+ [jvm.boolean]
+ [jvm.byte]
+ [jvm.short]
+ [jvm.int]
+ [jvm.long]
+ [jvm.float]
+ [jvm.double]
+ [jvm.char]))
+
+ (~~ (template [<type>]
+ [(text\= (..reflection (jvm.array <type>)) name)
+ (phase\wrap (jvm.array <type>))]
+
+ [jvm.boolean]
+ [jvm.byte]
+ [jvm.short]
+ [jvm.int]
+ [jvm.long]
+ [jvm.float]
+ [jvm.double]
+ [jvm.char]))
+
+ (text.starts_with? descriptor.array_prefix name)
+ (let [[_ unprefixed] (maybe.assume (text.split_with descriptor.array_prefix name))]
+ (\ phase.monad map jvm.array
+ (check_jvm (#.Primitive unprefixed (list)))))
+
+ ## else
+ (phase\wrap (jvm.class name (list)))))
+
+ (^ (#.Primitive (static array.type_name)
+ (list elementT)))
+ (|> elementT
+ check_jvm
+ (phase\map jvm.array))
+
+ (#.Primitive name parameters)
+ (do {! phase.monad}
+ [parameters (monad.map ! check_parameter parameters)]
+ (phase\wrap (jvm.class name parameters)))
+
+ (#.Named name anonymous)
+ (check_jvm anonymous)
+
+ (^template [<tag>]
+ [(<tag> env unquantified)
+ (check_jvm unquantified)])
+ ([#.UnivQ]
+ [#.ExQ])
+
+ (#.Apply inputT abstractionT)
+ (case (type.apply (list inputT) abstractionT)
+ (#.Some outputT)
+ (check_jvm outputT)
+
+ #.None
+ (/////analysis.throw ..non_object objectT))
+
+ _
+ (check_parameter objectT)))
+
+(def: (check_object objectT)
+ (-> .Type (Operation External))
+ (do {! phase.monad}
+ [name (\ ! map ..reflection (check_jvm objectT))]
+ (if (dictionary.key? ..boxes name)
+ (/////analysis.throw ..primitives_are_not_objects [name])
+ (phase\wrap name))))
+
+(def: (check_return type)
+ (-> .Type (Operation (Type Return)))
+ (if (is? .Any type)
+ (phase\wrap jvm.void)
+ (check_jvm type)))
+
+(def: (read_primitive_array_handler lux_type jvm_type)
+ (-> .Type (Type Primitive) Handler)
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list idxC arrayC))
+ (do phase.monad
+ [_ (typeA.infer lux_type)
+ idxA (typeA.with_type ..int
+ (analyse archive idxC))
+ arrayA (typeA.with_type (#.Primitive (|> (jvm.array jvm_type) ..reflection)
+ (list))
+ (analyse archive arrayC))]
+ (wrap (#/////analysis.Extension extension_name (list idxA arrayA))))
+
+ _
+ (/////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)]))))
+
+(def: array::read::object
+ Handler
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list idxC arrayC))
+ (do phase.monad
+ [[var_id varT] (typeA.with_env check.var)
+ _ (typeA.infer varT)
+ arrayA (typeA.with_type (.type (array.Array varT))
+ (analyse archive arrayC))
+ varT (typeA.with_env
+ (check.clean varT))
+ arrayJT (jvm_array_type (.type (array.Array varT)))
+ idxA (typeA.with_type ..int
+ (analyse archive idxC))]
+ (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature arrayJT))
+ idxA
+ arrayA))))
+
+ _
+ (/////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)]))))
+
+(def: (write_primitive_array_handler lux_type jvm_type)
+ (-> .Type (Type Primitive) Handler)
+ (let [array_type (#.Primitive (|> (jvm.array jvm_type) ..reflection)
+ (list))]
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list idxC valueC arrayC))
+ (do phase.monad
+ [_ (typeA.infer array_type)
+ idxA (typeA.with_type ..int
+ (analyse archive idxC))
+ valueA (typeA.with_type lux_type
+ (analyse archive valueC))
+ arrayA (typeA.with_type array_type
+ (analyse archive arrayC))]
+ (wrap (#/////analysis.Extension extension_name (list idxA
+ valueA
+ arrayA))))
+
+ _
+ (/////analysis.throw ///.incorrect_arity [extension_name 3 (list.size args)])))))
+
+(def: array::write::object
+ Handler
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list idxC valueC arrayC))
+ (do phase.monad
+ [[var_id varT] (typeA.with_env check.var)
+ _ (typeA.infer (.type (array.Array varT)))
+ arrayA (typeA.with_type (.type (array.Array varT))
+ (analyse archive arrayC))
+ varT (typeA.with_env
+ (check.clean varT))
+ arrayJT (jvm_array_type (.type (array.Array varT)))
+ idxA (typeA.with_type ..int
+ (analyse archive idxC))
+ valueA (typeA.with_type varT
+ (analyse archive valueC))]
+ (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature arrayJT))
+ idxA
+ valueA
+ arrayA))))
+
+ _
+ (/////analysis.throw ///.incorrect_arity [extension_name 3 (list.size args)]))))
+
+(def: bundle::array
+ Bundle
+ (<| (///bundle.prefix "array")
+ (|> ///bundle.empty
+ (dictionary.merge (<| (///bundle.prefix "length")
+ (|> ///bundle.empty
+ (///bundle.install (reflection.reflection reflection.boolean) (primitive_array_length_handler jvm.boolean))
+ (///bundle.install (reflection.reflection reflection.byte) (primitive_array_length_handler jvm.byte))
+ (///bundle.install (reflection.reflection reflection.short) (primitive_array_length_handler jvm.short))
+ (///bundle.install (reflection.reflection reflection.int) (primitive_array_length_handler jvm.int))
+ (///bundle.install (reflection.reflection reflection.long) (primitive_array_length_handler jvm.long))
+ (///bundle.install (reflection.reflection reflection.float) (primitive_array_length_handler jvm.float))
+ (///bundle.install (reflection.reflection reflection.double) (primitive_array_length_handler jvm.double))
+ (///bundle.install (reflection.reflection reflection.char) (primitive_array_length_handler jvm.char))
+ (///bundle.install "object" array::length::object))))
+ (dictionary.merge (<| (///bundle.prefix "new")
+ (|> ///bundle.empty
+ (///bundle.install (reflection.reflection reflection.boolean) (new_primitive_array_handler jvm.boolean))
+ (///bundle.install (reflection.reflection reflection.byte) (new_primitive_array_handler jvm.byte))
+ (///bundle.install (reflection.reflection reflection.short) (new_primitive_array_handler jvm.short))
+ (///bundle.install (reflection.reflection reflection.int) (new_primitive_array_handler jvm.int))
+ (///bundle.install (reflection.reflection reflection.long) (new_primitive_array_handler jvm.long))
+ (///bundle.install (reflection.reflection reflection.float) (new_primitive_array_handler jvm.float))
+ (///bundle.install (reflection.reflection reflection.double) (new_primitive_array_handler jvm.double))
+ (///bundle.install (reflection.reflection reflection.char) (new_primitive_array_handler jvm.char))
+ (///bundle.install "object" array::new::object))))
+ (dictionary.merge (<| (///bundle.prefix "read")
+ (|> ///bundle.empty
+ (///bundle.install (reflection.reflection reflection.boolean) (read_primitive_array_handler ..boolean jvm.boolean))
+ (///bundle.install (reflection.reflection reflection.byte) (read_primitive_array_handler ..byte jvm.byte))
+ (///bundle.install (reflection.reflection reflection.short) (read_primitive_array_handler ..short jvm.short))
+ (///bundle.install (reflection.reflection reflection.int) (read_primitive_array_handler ..int jvm.int))
+ (///bundle.install (reflection.reflection reflection.long) (read_primitive_array_handler ..long jvm.long))
+ (///bundle.install (reflection.reflection reflection.float) (read_primitive_array_handler ..float jvm.float))
+ (///bundle.install (reflection.reflection reflection.double) (read_primitive_array_handler ..double jvm.double))
+ (///bundle.install (reflection.reflection reflection.char) (read_primitive_array_handler ..char jvm.char))
+ (///bundle.install "object" array::read::object))))
+ (dictionary.merge (<| (///bundle.prefix "write")
+ (|> ///bundle.empty
+ (///bundle.install (reflection.reflection reflection.boolean) (write_primitive_array_handler ..boolean jvm.boolean))
+ (///bundle.install (reflection.reflection reflection.byte) (write_primitive_array_handler ..byte jvm.byte))
+ (///bundle.install (reflection.reflection reflection.short) (write_primitive_array_handler ..short jvm.short))
+ (///bundle.install (reflection.reflection reflection.int) (write_primitive_array_handler ..int jvm.int))
+ (///bundle.install (reflection.reflection reflection.long) (write_primitive_array_handler ..long jvm.long))
+ (///bundle.install (reflection.reflection reflection.float) (write_primitive_array_handler ..float jvm.float))
+ (///bundle.install (reflection.reflection reflection.double) (write_primitive_array_handler ..double jvm.double))
+ (///bundle.install (reflection.reflection reflection.char) (write_primitive_array_handler ..char jvm.char))
+ (///bundle.install "object" array::write::object))))
+ )))
+
+(def: object::null
+ Handler
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list))
+ (do phase.monad
+ [expectedT (///.lift meta.expected_type)
+ _ (check_object expectedT)]
+ (wrap (#/////analysis.Extension extension_name (list))))
+
+ _
+ (/////analysis.throw ///.incorrect_arity [extension_name 0 (list.size args)]))))
+
+(def: object::null?
+ Handler
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list objectC))
+ (do phase.monad
+ [_ (typeA.infer Bit)
+ [objectT objectA] (typeA.with_inference
+ (analyse archive objectC))
+ _ (check_object objectT)]
+ (wrap (#/////analysis.Extension extension_name (list objectA))))
+
+ _
+ (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
+
+(def: object::synchronized
+ Handler
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list monitorC exprC))
+ (do phase.monad
+ [[monitorT monitorA] (typeA.with_inference
+ (analyse archive monitorC))
+ _ (check_object monitorT)
+ exprA (analyse archive exprC)]
+ (wrap (#/////analysis.Extension extension_name (list monitorA exprA))))
+
+ _
+ (/////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)]))))
+
+(def: object::throw
+ Handler
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list exceptionC))
+ (do phase.monad
+ [_ (typeA.infer Nothing)
+ [exceptionT exceptionA] (typeA.with_inference
+ (analyse archive exceptionC))
+ exception_class (check_object exceptionT)
+ ? (phase.lift (reflection!.sub? "java.lang.Throwable" exception_class))
+ _ (: (Operation Any)
+ (if ?
+ (wrap [])
+ (/////analysis.throw non_throwable exception_class)))]
+ (wrap (#/////analysis.Extension extension_name (list exceptionA))))
+
+ _
+ (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
+
+(def: object::class
+ Handler
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list classC))
+ (case classC
+ [_ (#.Text class)]
+ (do phase.monad
+ [_ (..ensure_fresh_class! class)
+ _ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list)))))
+ _ (phase.lift (reflection!.load class))]
+ (wrap (#/////analysis.Extension extension_name (list (/////analysis.text class)))))
+
+ _
+ (/////analysis.throw ///.invalid_syntax [extension_name %.code args]))
+
+ _
+ (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
+
+(def: object::instance?
+ Handler
+ (..custom
+ [($_ <>.and <code>.text <code>.any)
+ (function (_ extension_name analyse archive [sub_class objectC])
+ (do phase.monad
+ [_ (..ensure_fresh_class! sub_class)
+ _ (typeA.infer Bit)
+ [objectT objectA] (typeA.with_inference
+ (analyse archive objectC))
+ object_class (check_object objectT)
+ ? (phase.lift (reflection!.sub? object_class sub_class))]
+ (if ?
+ (wrap (#/////analysis.Extension extension_name (list (/////analysis.text sub_class) objectA)))
+ (/////analysis.throw cannot_possibly_be_an_instance (format sub_class " !<= " object_class)))))]))
+
+(template [<name> <category> <parser>]
+ [(def: (<name> mapping typeJ)
+ (-> Mapping (Type <category>) (Operation .Type))
+ (case (|> typeJ ..signature (<text>.run (<parser> mapping)))
+ (#try.Success check)
+ (typeA.with_env
+ check)
+
+ (#try.Failure error)
+ (phase.fail error)))]
+
+ [reflection_type Value luxT.type]
+ [reflection_return Return luxT.return]
+ )
+
+(def: (class_candidate_parents from_name fromT to_name to_class)
+ (-> External .Type External (java/lang/Class java/lang/Object) (Operation (List [[Text .Type] Bit])))
+ (do {! phase.monad}
+ [from_class (phase.lift (reflection!.load from_name))
+ mapping (phase.lift (reflection!.correspond from_class fromT))]
+ (monad.map !
+ (function (_ superJT)
+ (do !
+ [superJT (phase.lift (reflection!.type superJT))
+ #let [super_name (|> superJT ..reflection)]
+ super_class (phase.lift (reflection!.load super_name))
+ superT (reflection_type mapping superJT)]
+ (wrap [[super_name superT] (java/lang/Class::isAssignableFrom super_class to_class)])))
+ (case (java/lang/Class::getGenericSuperclass from_class)
+ (#.Some super)
+ (list& super (array.to_list (java/lang/Class::getGenericInterfaces from_class)))
+
+ #.None
+ (if (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers from_class))
+ (#.Cons (:as java/lang/reflect/Type (ffi.class_for java/lang/Object))
+ (array.to_list (java/lang/Class::getGenericInterfaces from_class)))
+ (array.to_list (java/lang/Class::getGenericInterfaces from_class)))))))
+
+(def: (inheritance_candidate_parents fromT to_class toT fromC)
+ (-> .Type (java/lang/Class java/lang/Object) .Type Code (Operation (List [[Text .Type] Bit])))
+ (case fromT
+ (^ (#.Primitive _ (list& self_classT super_classT super_interfacesT+)))
+ (monad.map phase.monad
+ (function (_ superT)
+ (do {! phase.monad}
+ [super_name (\ ! map ..reflection (check_jvm superT))
+ super_class (phase.lift (reflection!.load super_name))]
+ (wrap [[super_name superT]
+ (java/lang/Class::isAssignableFrom super_class to_class)])))
+ (list& super_classT super_interfacesT+))
+
+ _
+ (/////analysis.throw ..cannot_cast [fromT toT fromC])))
+
+(def: object::cast
+ Handler
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list fromC))
+ (do {! phase.monad}
+ [toT (///.lift meta.expected_type)
+ to_name (\ ! map ..reflection (check_jvm toT))
+ [fromT fromA] (typeA.with_inference
+ (analyse archive fromC))
+ from_name (\ ! map ..reflection (check_jvm fromT))
+ can_cast? (: (Operation Bit)
+ (`` (cond (~~ (template [<primitive> <object>]
+ [(let [=primitive (reflection.reflection <primitive>)]
+ (or (and (text\= =primitive from_name)
+ (or (text\= <object> to_name)
+ (text\= =primitive to_name)))
+ (and (text\= <object> from_name)
+ (text\= =primitive to_name))))
+ (wrap true)]
+
+ [reflection.boolean box.boolean]
+ [reflection.byte box.byte]
+ [reflection.short box.short]
+ [reflection.int box.int]
+ [reflection.long box.long]
+ [reflection.float box.float]
+ [reflection.double box.double]
+ [reflection.char box.char]))
+
+ ## else
+ (do !
+ [_ (phase.assert ..primitives_are_not_objects [from_name]
+ (not (dictionary.key? ..boxes from_name)))
+ _ (phase.assert ..primitives_are_not_objects [to_name]
+ (not (dictionary.key? ..boxes to_name)))
+ to_class (phase.lift (reflection!.load to_name))
+ _ (if (text\= ..inheritance_relationship_type_name from_name)
+ (wrap [])
+ (do !
+ [from_class (phase.lift (reflection!.load from_name))]
+ (phase.assert ..cannot_cast [fromT toT fromC]
+ (java/lang/Class::isAssignableFrom from_class to_class))))]
+ (loop [[current_name currentT] [from_name fromT]]
+ (if (text\= to_name current_name)
+ (wrap true)
+ (do !
+ [candidate_parents (: (Operation (List [[Text .Type] Bit]))
+ (if (text\= ..inheritance_relationship_type_name current_name)
+ (inheritance_candidate_parents currentT to_class toT fromC)
+ (class_candidate_parents current_name currentT to_name to_class)))]
+ (case (|> candidate_parents
+ (list.filter product.right)
+ (list\map product.left))
+ (#.Cons [next_name nextT] _)
+ (recur [next_name nextT])
+
+ #.Nil
+ (wrap false)))))))))]
+ (if can_cast?
+ (wrap (#/////analysis.Extension extension_name (list (/////analysis.text from_name)
+ (/////analysis.text to_name)
+ fromA)))
+ (/////analysis.throw ..cannot_cast [fromT toT fromC])))
+
+ _
+ (/////analysis.throw ///.invalid_syntax [extension_name %.code args]))))
+
+(def: bundle::object
+ Bundle
+ (<| (///bundle.prefix "object")
+ (|> ///bundle.empty
+ (///bundle.install "null" object::null)
+ (///bundle.install "null?" object::null?)
+ (///bundle.install "synchronized" object::synchronized)
+ (///bundle.install "throw" object::throw)
+ (///bundle.install "class" object::class)
+ (///bundle.install "instance?" object::instance?)
+ (///bundle.install "cast" object::cast)
+ )))
+
+(def: get::static
+ Handler
+ (..custom
+ [..member
+ (function (_ extension_name analyse archive [class field])
+ (do phase.monad
+ [_ (..ensure_fresh_class! class)
+ [final? deprecated? fieldJT] (phase.lift
+ (do try.monad
+ [class (reflection!.load class)]
+ (reflection!.static_field field class)))
+ _ (phase.assert ..deprecated_field [class field]
+ (not deprecated?))
+ fieldT (reflection_type luxT.fresh fieldJT)
+ _ (typeA.infer fieldT)]
+ (wrap (<| (#/////analysis.Extension extension_name)
+ (list (/////analysis.text class)
+ (/////analysis.text field)
+ (/////analysis.text (|> fieldJT ..reflection)))))))]))
+
+(def: put::static
+ Handler
+ (..custom
+ [($_ <>.and ..member <code>.any)
+ (function (_ extension_name analyse archive [[class field] valueC])
+ (do phase.monad
+ [_ (..ensure_fresh_class! class)
+ _ (typeA.infer Any)
+ [final? deprecated? fieldJT] (phase.lift
+ (do try.monad
+ [class (reflection!.load class)]
+ (reflection!.static_field field class)))
+ _ (phase.assert ..deprecated_field [class field]
+ (not deprecated?))
+ _ (phase.assert ..cannot_set_a_final_field [class field]
+ (not final?))
+ fieldT (reflection_type luxT.fresh fieldJT)
+ valueA (typeA.with_type fieldT
+ (analyse archive valueC))]
+ (wrap (<| (#/////analysis.Extension extension_name)
+ (list (/////analysis.text class)
+ (/////analysis.text field)
+ valueA)))))]))
+
+(def: get::virtual
+ Handler
+ (..custom
+ [($_ <>.and ..member <code>.any)
+ (function (_ extension_name analyse archive [[class field] objectC])
+ (do phase.monad
+ [_ (..ensure_fresh_class! class)
+ [objectT objectA] (typeA.with_inference
+ (analyse archive objectC))
+ [deprecated? mapping fieldJT] (phase.lift
+ (do try.monad
+ [class (reflection!.load class)
+ [final? deprecated? fieldJT] (reflection!.virtual_field field class)
+ mapping (reflection!.correspond class objectT)]
+ (wrap [deprecated? mapping fieldJT])))
+ _ (phase.assert ..deprecated_field [class field]
+ (not deprecated?))
+ fieldT (reflection_type mapping fieldJT)
+ _ (typeA.infer fieldT)]
+ (wrap (<| (#/////analysis.Extension extension_name)
+ (list (/////analysis.text class)
+ (/////analysis.text field)
+ objectA)))))]))
+
+(def: put::virtual
+ Handler
+ (..custom
+ [($_ <>.and ..member <code>.any <code>.any)
+ (function (_ extension_name analyse archive [[class field] valueC objectC])
+ (do phase.monad
+ [_ (..ensure_fresh_class! class)
+ [objectT objectA] (typeA.with_inference
+ (analyse archive objectC))
+ _ (typeA.infer objectT)
+ [final? deprecated? mapping fieldJT] (phase.lift
+ (do try.monad
+ [class (reflection!.load class)
+ [final? deprecated? fieldJT] (reflection!.virtual_field field class)
+ mapping (reflection!.correspond class objectT)]
+ (wrap [final? deprecated? mapping fieldJT])))
+ _ (phase.assert ..deprecated_field [class field]
+ (not deprecated?))
+ _ (phase.assert ..cannot_set_a_final_field [class field]
+ (not final?))
+ fieldT (reflection_type mapping fieldJT)
+ valueA (typeA.with_type fieldT
+ (analyse archive valueC))]
+ (wrap (<| (#/////analysis.Extension extension_name)
+ (list (/////analysis.text class)
+ (/////analysis.text field)
+ valueA
+ objectA)))))]))
+
+(type: Method_Style
+ #Static
+ #Abstract
+ #Virtual
+ #Special
+ #Interface)
+
+(def: (check_method aliasing class method_name method_style inputsJT method)
+ (-> Aliasing (java/lang/Class java/lang/Object) Text Method_Style (List (Type Value)) java/lang/reflect/Method (Operation Bit))
+ (do phase.monad
+ [parameters (|> (java/lang/reflect/Method::getGenericParameterTypes method)
+ array.to_list
+ (monad.map try.monad reflection!.type)
+ phase.lift)
+ #let [modifiers (java/lang/reflect/Method::getModifiers method)
+ correct_class? (java/lang/Object::equals class (java/lang/reflect/Method::getDeclaringClass method))
+ correct_method? (text\= method_name (java/lang/reflect/Method::getName method))
+ static_matches? (case method_style
+ #Static
+ (java/lang/reflect/Modifier::isStatic modifiers)
+
+ _
+ true)
+ special_matches? (case method_style
+ #Special
+ (not (or (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class))
+ (java/lang/reflect/Modifier::isAbstract modifiers)))
+
+ _
+ true)
+ arity_matches? (n.= (list.size inputsJT) (list.size parameters))
+ inputs_match? (and arity_matches?
+ (list\fold (function (_ [expectedJC actualJC] prev)
+ (and prev
+ (jvm\= expectedJC (: (Type Value)
+ (case (jvm_parser.var? actualJC)
+ (#.Some name)
+ (|> aliasing
+ (dictionary.get name)
+ (maybe.default name)
+ jvm.var)
+
+ #.None
+ actualJC)))))
+ true
+ (list.zip/2 parameters inputsJT)))]]
+ (wrap (and correct_class?
+ correct_method?
+ static_matches?
+ special_matches?
+ arity_matches?
+ inputs_match?))))
+
+(def: (check_constructor aliasing class inputsJT constructor)
+ (-> Aliasing (java/lang/Class java/lang/Object) (List (Type Value)) (java/lang/reflect/Constructor java/lang/Object) (Operation Bit))
+ (do phase.monad
+ [parameters (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor)
+ array.to_list
+ (monad.map try.monad reflection!.type)
+ phase.lift)]
+ (wrap (and (java/lang/Object::equals class (java/lang/reflect/Constructor::getDeclaringClass constructor))
+ (n.= (list.size inputsJT) (list.size parameters))
+ (list\fold (function (_ [expectedJC actualJC] prev)
+ (and prev
+ (jvm\= expectedJC (: (Type Value)
+ (case (jvm_parser.var? actualJC)
+ (#.Some name)
+ (|> aliasing
+ (dictionary.get name)
+ (maybe.default name)
+ jvm.var)
+
+ #.None
+ actualJC)))))
+ true
+ (list.zip/2 parameters inputsJT))))))
+
+(def: idx_to_parameter
+ (-> Nat .Type)
+ (|>> (n.* 2) inc #.Parameter))
+
+(def: (jvm_type_var_mapping owner_tvars method_tvars)
+ (-> (List Text) (List Text) [(List .Type) Mapping])
+ (let [jvm_tvars (list\compose owner_tvars method_tvars)
+ lux_tvars (|> jvm_tvars
+ list.reverse
+ list.enumeration
+ (list\map (function (_ [idx name])
+ [name (idx_to_parameter idx)]))
+ list.reverse)
+ num_owner_tvars (list.size owner_tvars)
+ owner_tvarsT (|> lux_tvars (list.take num_owner_tvars) (list\map product.right))
+ mapping (dictionary.from_list text.hash lux_tvars)]
+ [owner_tvarsT mapping]))
+
+(def: (method_signature method_style method)
+ (-> Method_Style java/lang/reflect/Method (Operation Method_Signature))
+ (let [owner (java/lang/reflect/Method::getDeclaringClass method)
+ owner_tvars (case method_style
+ #Static
+ (list)
+
+ _
+ (|> (java/lang/Class::getTypeParameters owner)
+ array.to_list
+ (list\map (|>> java/lang/reflect/TypeVariable::getName))))
+ method_tvars (|> (java/lang/reflect/Method::getTypeParameters method)
+ array.to_list
+ (list\map (|>> java/lang/reflect/TypeVariable::getName)))
+ [owner_tvarsT mapping] (jvm_type_var_mapping owner_tvars method_tvars)]
+ (do {! phase.monad}
+ [inputsT (|> (java/lang/reflect/Method::getGenericParameterTypes method)
+ array.to_list
+ (monad.map ! (|>> reflection!.type phase.lift))
+ (phase\map (monad.map ! (..reflection_type mapping)))
+ phase\join)
+ outputT (|> method
+ java/lang/reflect/Method::getGenericReturnType
+ reflection!.return
+ phase.lift
+ (phase\map (..reflection_return mapping))
+ phase\join)
+ exceptionsT (|> (java/lang/reflect/Method::getGenericExceptionTypes method)
+ array.to_list
+ (monad.map ! (|>> reflection!.type phase.lift))
+ (phase\map (monad.map ! (..reflection_type mapping)))
+ phase\join)
+ #let [methodT (<| (type.univ_q (dictionary.size mapping))
+ (type.function (case method_style
+ #Static
+ inputsT
+
+ _
+ (list& (#.Primitive (java/lang/Class::getName owner) owner_tvarsT)
+ inputsT)))
+ outputT)]]
+ (wrap [methodT
+ (reflection!.deprecated? (java/lang/reflect/Method::getDeclaredAnnotations method))
+ exceptionsT]))))
+
+(def: (constructor_signature constructor)
+ (-> (java/lang/reflect/Constructor java/lang/Object) (Operation Method_Signature))
+ (let [owner (java/lang/reflect/Constructor::getDeclaringClass constructor)
+ owner_tvars (|> (java/lang/Class::getTypeParameters owner)
+ array.to_list
+ (list\map (|>> java/lang/reflect/TypeVariable::getName)))
+ method_tvars (|> (java/lang/reflect/Constructor::getTypeParameters constructor)
+ array.to_list
+ (list\map (|>> java/lang/reflect/TypeVariable::getName)))
+ [owner_tvarsT mapping] (jvm_type_var_mapping owner_tvars method_tvars)]
+ (do {! phase.monad}
+ [inputsT (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor)
+ array.to_list
+ (monad.map ! (|>> reflection!.type phase.lift))
+ (phase\map (monad.map ! (reflection_type mapping)))
+ phase\join)
+ exceptionsT (|> (java/lang/reflect/Constructor::getGenericExceptionTypes constructor)
+ array.to_list
+ (monad.map ! (|>> reflection!.type phase.lift))
+ (phase\map (monad.map ! (reflection_type mapping)))
+ phase\join)
+ #let [objectT (#.Primitive (java/lang/Class::getName owner) owner_tvarsT)
+ constructorT (<| (type.univ_q (dictionary.size mapping))
+ (type.function inputsT)
+ objectT)]]
+ (wrap [constructorT
+ (reflection!.deprecated? (java/lang/reflect/Constructor::getDeclaredAnnotations constructor))
+ exceptionsT]))))
+
+(type: Evaluation
+ (#Pass Method_Signature)
+ (#Hint Method_Signature))
+
+(template [<name> <tag>]
+ [(def: <name>
+ (-> Evaluation (Maybe Method_Signature))
+ (|>> (case> (<tag> output)
+ (#.Some output)
+
+ _
+ #.None)))]
+
+ [pass! #Pass]
+ [hint! #Hint]
+ )
+
+(template [<name> <type> <method>]
+ [(def: <name>
+ (-> <type> (List (Type Var)))
+ (|>> <method>
+ array.to_list
+ (list\map (|>> java/lang/reflect/TypeVariable::getName jvm.var))))]
+
+ [class_type_variables (java/lang/Class java/lang/Object) java/lang/Class::getTypeParameters]
+ [constructor_type_variables (java/lang/reflect/Constructor java/lang/Object) java/lang/reflect/Constructor::getTypeParameters]
+ [method_type_variables java/lang/reflect/Method java/lang/reflect/Method::getTypeParameters]
+ )
+
+(def: (aliasing expected actual)
+ (-> (List (Type Var)) (List (Type Var)) Aliasing)
+ (|> (list.zip/2 (list\map jvm_parser.name actual)
+ (list\map jvm_parser.name expected))
+ (dictionary.from_list text.hash)))
+
+(def: (method_candidate actual_class_tvars class_name actual_method_tvars method_name method_style inputsJT)
+ (-> (List (Type Var)) External (List (Type Var)) Text Method_Style (List (Type Value)) (Operation Method_Signature))
+ (do {! phase.monad}
+ [class (phase.lift (reflection!.load class_name))
+ #let [expected_class_tvars (class_type_variables class)]
+ candidates (|> class
+ java/lang/Class::getDeclaredMethods
+ array.to_list
+ (list.filter (|>> java/lang/reflect/Method::getName (text\= method_name)))
+ (monad.map ! (: (-> java/lang/reflect/Method (Operation Evaluation))
+ (function (_ method)
+ (do !
+ [#let [expected_method_tvars (method_type_variables method)
+ aliasing (dictionary.merge (..aliasing expected_class_tvars actual_class_tvars)
+ (..aliasing expected_method_tvars actual_method_tvars))]
+ passes? (check_method aliasing class method_name method_style inputsJT method)]
+ (\ ! map (if passes?
+ (|>> #Pass)
+ (|>> #Hint))
+ (method_signature method_style method)))))))]
+ (case (list.all pass! candidates)
+ (#.Cons method #.Nil)
+ (wrap method)
+
+ #.Nil
+ (/////analysis.throw ..no_candidates [class_name method_name inputsJT (list.all hint! candidates)])
+
+ candidates
+ (/////analysis.throw ..too_many_candidates [class_name method_name inputsJT candidates]))))
+
+(def: constructor_method
+ "<init>")
+
+(def: (constructor_candidate actual_class_tvars class_name actual_method_tvars inputsJT)
+ (-> (List (Type Var)) External (List (Type Var)) (List (Type Value)) (Operation Method_Signature))
+ (do {! phase.monad}
+ [class (phase.lift (reflection!.load class_name))
+ #let [expected_class_tvars (class_type_variables class)]
+ candidates (|> class
+ java/lang/Class::getConstructors
+ array.to_list
+ (monad.map ! (function (_ constructor)
+ (do !
+ [#let [expected_method_tvars (constructor_type_variables constructor)
+ aliasing (dictionary.merge (..aliasing expected_class_tvars actual_class_tvars)
+ (..aliasing expected_method_tvars actual_method_tvars))]
+ passes? (check_constructor aliasing class inputsJT constructor)]
+ (\ ! map
+ (if passes? (|>> #Pass) (|>> #Hint))
+ (constructor_signature constructor))))))]
+ (case (list.all pass! candidates)
+ (#.Cons constructor #.Nil)
+ (wrap constructor)
+
+ #.Nil
+ (/////analysis.throw ..no_candidates [class_name ..constructor_method inputsJT (list.all hint! candidates)])
+
+ candidates
+ (/////analysis.throw ..too_many_candidates [class_name ..constructor_method inputsJT candidates]))))
+
+(template [<name> <category> <parser>]
+ [(def: #export <name>
+ (Parser (Type <category>))
+ (<text>.embed <parser> <code>.text))]
+
+ [var Var jvm_parser.var]
+ [class Class jvm_parser.class]
+ [type Value jvm_parser.value]
+ [return Return jvm_parser.return]
+ )
+
+(def: input
+ (Parser (Typed Code))
+ (<code>.tuple (<>.and ..type <code>.any)))
+
+(def: (decorate_inputs typesT inputsA)
+ (-> (List (Type Value)) (List Analysis) (List Analysis))
+ (|> inputsA
+ (list.zip/2 (list\map (|>> ..signature /////analysis.text) typesT))
+ (list\map (function (_ [type value])
+ (/////analysis.tuple (list type value))))))
+
+(def: type_vars
+ (<code>.tuple (<>.some ..var)))
+
+(def: invoke::static
+ Handler
+ (..custom
+ [($_ <>.and ..type_vars ..member ..type_vars (<>.some ..input))
+ (function (_ extension_name analyse archive [class_tvars [class method] method_tvars argsTC])
+ (do phase.monad
+ [_ (..ensure_fresh_class! class)
+ #let [argsT (list\map product.left argsTC)]
+ [methodT deprecated? exceptionsT] (..method_candidate class_tvars class method_tvars method #Static argsT)
+ _ (phase.assert ..deprecated_method [class method methodT]
+ (not deprecated?))
+ [outputT argsA] (inferenceA.general archive analyse methodT (list\map product.right argsTC))
+ outputJT (check_return outputT)]
+ (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list))))
+ (/////analysis.text method)
+ (/////analysis.text (..signature outputJT))
+ (decorate_inputs argsT argsA))))))]))
+
+(def: invoke::virtual
+ Handler
+ (..custom
+ [($_ <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input))
+ (function (_ extension_name analyse archive [class_tvars [class method] method_tvars objectC argsTC])
+ (do phase.monad
+ [_ (..ensure_fresh_class! class)
+ #let [argsT (list\map product.left argsTC)]
+ [methodT deprecated? exceptionsT] (..method_candidate class_tvars class method_tvars method #Virtual argsT)
+ _ (phase.assert ..deprecated_method [class method methodT]
+ (not deprecated?))
+ [outputT allA] (inferenceA.general archive analyse methodT (list& objectC (list\map product.right argsTC)))
+ #let [[objectA argsA] (case allA
+ (#.Cons objectA argsA)
+ [objectA argsA]
+
+ _
+ (undefined))]
+ outputJT (check_return outputT)]
+ (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list))))
+ (/////analysis.text method)
+ (/////analysis.text (..signature outputJT))
+ objectA
+ (decorate_inputs argsT argsA))))))]))
+
+(def: invoke::special
+ Handler
+ (..custom
+ [($_ <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input))
+ (function (_ extension_name analyse archive [class_tvars [class method] method_tvars objectC argsTC])
+ (do phase.monad
+ [_ (..ensure_fresh_class! class)
+ #let [argsT (list\map product.left argsTC)]
+ [methodT deprecated? exceptionsT] (..method_candidate class_tvars class method_tvars method #Special argsT)
+ _ (phase.assert ..deprecated_method [class method methodT]
+ (not deprecated?))
+ [outputT argsA] (inferenceA.general archive analyse methodT (list& objectC (list\map product.right argsTC)))
+ outputJT (check_return outputT)]
+ (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list))))
+ (/////analysis.text method)
+ (/////analysis.text (..signature outputJT))
+ (decorate_inputs argsT argsA))))))]))
+
+(def: invoke::interface
+ Handler
+ (..custom
+ [($_ <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input))
+ (function (_ extension_name analyse archive [class_tvars [class_name method] method_tvars objectC argsTC])
+ (do phase.monad
+ [_ (..ensure_fresh_class! class_name)
+ #let [argsT (list\map product.left argsTC)]
+ class (phase.lift (reflection!.load class_name))
+ _ (phase.assert non_interface class_name
+ (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class)))
+ [methodT deprecated? exceptionsT] (..method_candidate class_tvars class_name method_tvars method #Interface argsT)
+ _ (phase.assert ..deprecated_method [class_name method methodT]
+ (not deprecated?))
+ [outputT allA] (inferenceA.general archive analyse methodT (list& objectC (list\map product.right argsTC)))
+ #let [[objectA argsA] (case allA
+ (#.Cons objectA argsA)
+ [objectA argsA]
+
+ _
+ (undefined))]
+ outputJT (check_return outputT)]
+ (wrap (#/////analysis.Extension extension_name
+ (list& (/////analysis.text (..signature (jvm.class class_name (list))))
+ (/////analysis.text method)
+ (/////analysis.text (..signature outputJT))
+ objectA
+ (decorate_inputs argsT argsA))))))]))
+
+(def: invoke::constructor
+ (..custom
+ [($_ <>.and ..type_vars <code>.text ..type_vars (<>.some ..input))
+ (function (_ extension_name analyse archive [class_tvars class method_tvars argsTC])
+ (do phase.monad
+ [_ (..ensure_fresh_class! class)
+ #let [argsT (list\map product.left argsTC)]
+ [methodT deprecated? exceptionsT] (..constructor_candidate class_tvars class method_tvars argsT)
+ _ (phase.assert ..deprecated_method [class ..constructor_method methodT]
+ (not deprecated?))
+ [outputT argsA] (inferenceA.general archive analyse methodT (list\map product.right argsTC))]
+ (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list))))
+ (decorate_inputs argsT argsA))))))]))
+
+(def: bundle::member
+ Bundle
+ (<| (///bundle.prefix "member")
+ (|> ///bundle.empty
+ (dictionary.merge (<| (///bundle.prefix "get")
+ (|> ///bundle.empty
+ (///bundle.install "static" get::static)
+ (///bundle.install "virtual" get::virtual))))
+ (dictionary.merge (<| (///bundle.prefix "put")
+ (|> ///bundle.empty
+ (///bundle.install "static" put::static)
+ (///bundle.install "virtual" put::virtual))))
+ (dictionary.merge (<| (///bundle.prefix "invoke")
+ (|> ///bundle.empty
+ (///bundle.install "static" invoke::static)
+ (///bundle.install "virtual" invoke::virtual)
+ (///bundle.install "special" invoke::special)
+ (///bundle.install "interface" invoke::interface)
+ (///bundle.install "constructor" invoke::constructor)
+ )))
+ )))
+
+(type: #export (Annotation_Parameter a)
+ [Text a])
+
+(def: annotation_parameter
+ (Parser (Annotation_Parameter Code))
+ (<code>.tuple (<>.and <code>.text <code>.any)))
+
+(type: #export (Annotation a)
+ [Text (List (Annotation_Parameter a))])
+
+(def: #export annotation
+ (Parser (Annotation Code))
+ (<code>.form (<>.and <code>.text (<>.some ..annotation_parameter))))
+
+(def: #export argument
+ (Parser Argument)
+ (<code>.tuple (<>.and <code>.text ..type)))
+
+(def: (annotation_parameter_analysis [name value])
+ (-> (Annotation_Parameter Analysis) Analysis)
+ (/////analysis.tuple (list (/////analysis.text name) value)))
+
+(def: (annotation_analysis [name parameters])
+ (-> (Annotation Analysis) Analysis)
+ (/////analysis.tuple (list& (/////analysis.text name)
+ (list\map annotation_parameter_analysis parameters))))
+
+(template [<name> <category>]
+ [(def: <name>
+ (-> (Type <category>) Analysis)
+ (|>> ..signature /////analysis.text))]
+
+ [var_analysis Var]
+ [class_analysis Class]
+ [value_analysis Value]
+ [return_analysis Return]
+ )
+
+(def: (typed_analysis [type term])
+ (-> (Typed Analysis) Analysis)
+ (/////analysis.tuple (list (value_analysis type) term)))
+
+(def: (argument_analysis [argument argumentJT])
+ (-> Argument Analysis)
+ (/////analysis.tuple
+ (list (/////analysis.text argument)
+ (value_analysis argumentJT))))
+
+(template [<name> <filter>]
+ [(def: <name>
+ (-> (java/lang/Class java/lang/Object)
+ (Try (List [Text (Type Method)])))
+ (|>> java/lang/Class::getDeclaredMethods
+ array.to_list
+ <filter>
+ (monad.map try.monad
+ (function (_ method)
+ (do {! try.monad}
+ [inputs (|> (java/lang/reflect/Method::getGenericParameterTypes method)
+ array.to_list
+ (monad.map ! reflection!.type))
+ return (|> method
+ java/lang/reflect/Method::getGenericReturnType
+ reflection!.return)
+ exceptions (|> (java/lang/reflect/Method::getGenericExceptionTypes method)
+ array.to_list
+ (monad.map ! reflection!.class))]
+ (wrap [(java/lang/reflect/Method::getName method)
+ (jvm.method [inputs return exceptions])]))))))]
+
+ [abstract_methods (list.filter (|>> java/lang/reflect/Method::getModifiers java/lang/reflect/Modifier::isAbstract))]
+ [methods (<|)]
+ )
+
+(def: jvm_package_separator ".")
+
+(template [<name> <methods>]
+ [(def: <name>
+ (-> (List (Type Class)) (Try (List [Text (Type Method)])))
+ (|>> (monad.map try.monad (|>> ..reflection reflection!.load))
+ (try\map (monad.map try.monad <methods>))
+ try\join
+ (try\map list\join)))]
+
+ [all_abstract_methods ..abstract_methods]
+ [all_methods ..methods]
+ )
+
+(template [<name>]
+ [(exception: #export (<name> {methods (List [Text (Type Method)])})
+ (exception.report
+ ["Methods" (exception.enumerate
+ (function (_ [name type])
+ (format (%.text name) " " (..signature type)))
+ methods)]))]
+
+ [missing_abstract_methods]
+ [invalid_overriden_methods]
+ )
+
+(type: #export Visibility
+ #Public
+ #Private
+ #Protected
+ #Default)
+
+(type: #export Finality Bit)
+(type: #export Strictness Bit)
+
+(def: #export public_tag "public")
+(def: #export private_tag "private")
+(def: #export protected_tag "protected")
+(def: #export default_tag "default")
+
+(def: #export visibility
+ (Parser Visibility)
+ ($_ <>.or
+ (<code>.text! ..public_tag)
+ (<code>.text! ..private_tag)
+ (<code>.text! ..protected_tag)
+ (<code>.text! ..default_tag)))
+
+(def: #export (visibility_analysis visibility)
+ (-> Visibility Analysis)
+ (/////analysis.text (case visibility
+ #Public ..public_tag
+ #Private ..private_tag
+ #Protected ..protected_tag
+ #Default ..default_tag)))
+
+(type: #export (Constructor a)
+ [Visibility
+ Strictness
+ (List (Annotation a))
+ (List (Type Var))
+ (List (Type Class)) ## Exceptions
+ Text
+ (List Argument)
+ (List (Typed a))
+ a])
+
+(def: #export constructor_tag "init")
+
+(def: #export constructor_definition
+ (Parser (Constructor Code))
+ (<| <code>.form
+ (<>.after (<code>.text! ..constructor_tag))
+ ($_ <>.and
+ ..visibility
+ <code>.bit
+ (<code>.tuple (<>.some ..annotation))
+ (<code>.tuple (<>.some ..var))
+ (<code>.tuple (<>.some ..class))
+ <code>.text
+ (<code>.tuple (<>.some ..argument))
+ (<code>.tuple (<>.some ..input))
+ <code>.any)))
+
+(def: #export (analyse_constructor_method analyse archive selfT mapping method)
+ (-> Phase Archive .Type Mapping (Constructor Code) (Operation Analysis))
+ (let [[visibility strict_fp?
+ annotations vars exceptions
+ self_name arguments super_arguments body] method]
+ (do {! phase.monad}
+ [annotationsA (monad.map ! (function (_ [name parameters])
+ (do !
+ [parametersA (monad.map ! (function (_ [name value])
+ (do !
+ [valueA (analyse archive value)]
+ (wrap [name valueA])))
+ parameters)]
+ (wrap [name parametersA])))
+ annotations)
+ super_arguments (monad.map ! (function (_ [jvmT super_argC])
+ (do !
+ [luxT (reflection_type mapping jvmT)
+ super_argA (typeA.with_type luxT
+ (analyse archive super_argC))]
+ (wrap [jvmT super_argA])))
+ super_arguments)
+ arguments' (monad.map !
+ (function (_ [name jvmT])
+ (do !
+ [luxT (reflection_type mapping jvmT)]
+ (wrap [name luxT])))
+ arguments)
+ [scope bodyA] (|> arguments'
+ (#.Cons [self_name selfT])
+ list.reverse
+ (list\fold scope.with_local (analyse archive body))
+ (typeA.with_type .Any)
+ /////analysis.with_scope)]
+ (wrap (/////analysis.tuple (list (/////analysis.text ..constructor_tag)
+ (visibility_analysis visibility)
+ (/////analysis.bit strict_fp?)
+ (/////analysis.tuple (list\map annotation_analysis annotationsA))
+ (/////analysis.tuple (list\map var_analysis vars))
+ (/////analysis.text self_name)
+ (/////analysis.tuple (list\map ..argument_analysis arguments))
+ (/////analysis.tuple (list\map class_analysis exceptions))
+ (/////analysis.tuple (list\map typed_analysis super_arguments))
+ (#/////analysis.Function
+ (list\map (|>> /////analysis.variable)
+ (scope.environment scope))
+ (/////analysis.tuple (list bodyA)))
+ ))))))
+
+(type: #export (Virtual_Method a)
+ [Text
+ Visibility
+ Finality
+ Strictness
+ (List (Annotation a))
+ (List (Type Var))
+ Text
+ (List Argument)
+ (Type Return)
+ (List (Type Class)) ## Exceptions
+ a])
+
+(def: virtual_tag "virtual")
+
+(def: #export virtual_method_definition
+ (Parser (Virtual_Method Code))
+ (<| <code>.form
+ (<>.after (<code>.text! ..virtual_tag))
+ ($_ <>.and
+ <code>.text
+ ..visibility
+ <code>.bit
+ <code>.bit
+ (<code>.tuple (<>.some ..annotation))
+ (<code>.tuple (<>.some ..var))
+ <code>.text
+ (<code>.tuple (<>.some ..argument))
+ ..return
+ (<code>.tuple (<>.some ..class))
+ <code>.any)))
+
+(def: #export (analyse_virtual_method analyse archive selfT mapping method)
+ (-> Phase Archive .Type Mapping (Virtual_Method Code) (Operation Analysis))
+ (let [[method_name visibility
+ final? strict_fp? annotations vars
+ self_name arguments return exceptions
+ body] method]
+ (do {! phase.monad}
+ [annotationsA (monad.map ! (function (_ [name parameters])
+ (do !
+ [parametersA (monad.map ! (function (_ [name value])
+ (do !
+ [valueA (analyse archive value)]
+ (wrap [name valueA])))
+ parameters)]
+ (wrap [name parametersA])))
+ annotations)
+ returnT (reflection_return mapping return)
+ arguments' (monad.map !
+ (function (_ [name jvmT])
+ (do !
+ [luxT (reflection_type mapping jvmT)]
+ (wrap [name luxT])))
+ arguments)
+ [scope bodyA] (|> arguments'
+ (#.Cons [self_name selfT])
+ list.reverse
+ (list\fold scope.with_local (analyse archive body))
+ (typeA.with_type returnT)
+ /////analysis.with_scope)]
+ (wrap (/////analysis.tuple (list (/////analysis.text ..virtual_tag)
+ (/////analysis.text method_name)
+ (visibility_analysis visibility)
+ (/////analysis.bit final?)
+ (/////analysis.bit strict_fp?)
+ (/////analysis.tuple (list\map annotation_analysis annotationsA))
+ (/////analysis.tuple (list\map var_analysis vars))
+ (/////analysis.text self_name)
+ (/////analysis.tuple (list\map ..argument_analysis arguments))
+ (return_analysis return)
+ (/////analysis.tuple (list\map class_analysis exceptions))
+ (#/////analysis.Function
+ (list\map (|>> /////analysis.variable)
+ (scope.environment scope))
+ (/////analysis.tuple (list bodyA)))
+ ))))))
+
+(type: #export (Static_Method a)
+ [Text
+ Visibility
+ Strictness
+ (List (Annotation a))
+ (List (Type Var))
+ (List (Type Class)) ## Exceptions
+ (List Argument)
+ (Type Return)
+ a])
+
+(def: #export static_tag "static")
+
+(def: #export static_method_definition
+ (Parser (Static_Method Code))
+ (<| <code>.form
+ (<>.after (<code>.text! ..static_tag))
+ ($_ <>.and
+ <code>.text
+ ..visibility
+ <code>.bit
+ (<code>.tuple (<>.some ..annotation))
+ (<code>.tuple (<>.some ..var))
+ (<code>.tuple (<>.some ..class))
+ (<code>.tuple (<>.some ..argument))
+ ..return
+ <code>.any)))
+
+(def: #export (analyse_static_method analyse archive mapping method)
+ (-> Phase Archive Mapping (Static_Method Code) (Operation Analysis))
+ (let [[method_name visibility
+ strict_fp? annotations vars exceptions
+ arguments return
+ body] method]
+ (do {! phase.monad}
+ [annotationsA (monad.map ! (function (_ [name parameters])
+ (do !
+ [parametersA (monad.map ! (function (_ [name value])
+ (do !
+ [valueA (analyse archive value)]
+ (wrap [name valueA])))
+ parameters)]
+ (wrap [name parametersA])))
+ annotations)
+ returnT (reflection_return mapping return)
+ arguments' (monad.map !
+ (function (_ [name jvmT])
+ (do !
+ [luxT (reflection_type mapping jvmT)]
+ (wrap [name luxT])))
+ arguments)
+ [scope bodyA] (|> arguments'
+ list.reverse
+ (list\fold scope.with_local (analyse archive body))
+ (typeA.with_type returnT)
+ /////analysis.with_scope)]
+ (wrap (/////analysis.tuple (list (/////analysis.text ..static_tag)
+ (/////analysis.text method_name)
+ (visibility_analysis visibility)
+ (/////analysis.bit strict_fp?)
+ (/////analysis.tuple (list\map annotation_analysis annotationsA))
+ (/////analysis.tuple (list\map var_analysis vars))
+ (/////analysis.tuple (list\map ..argument_analysis arguments))
+ (return_analysis return)
+ (/////analysis.tuple (list\map class_analysis
+ exceptions))
+ (#/////analysis.Function
+ (list\map (|>> /////analysis.variable)
+ (scope.environment scope))
+ (/////analysis.tuple (list bodyA)))
+ ))))))
+
+(type: #export (Overriden_Method a)
+ [(Type Class)
+ Text
+ Bit
+ (List (Annotation a))
+ (List (Type Var))
+ Text
+ (List Argument)
+ (Type Return)
+ (List (Type Class))
+ a])
+
+(def: #export overriden_tag "override")
+
+(def: #export overriden_method_definition
+ (Parser (Overriden_Method Code))
+ (<| <code>.form
+ (<>.after (<code>.text! ..overriden_tag))
+ ($_ <>.and
+ ..class
+ <code>.text
+ <code>.bit
+ (<code>.tuple (<>.some ..annotation))
+ (<code>.tuple (<>.some ..var))
+ <code>.text
+ (<code>.tuple (<>.some ..argument))
+ ..return
+ (<code>.tuple (<>.some ..class))
+ <code>.any
+ )))
+
+(def: #export (analyse_overriden_method analyse archive selfT mapping method)
+ (-> Phase Archive .Type Mapping (Overriden_Method Code) (Operation Analysis))
+ (let [[parent_type method_name
+ strict_fp? annotations vars
+ self_name arguments return exceptions
+ body] method]
+ (do {! phase.monad}
+ [annotationsA (monad.map ! (function (_ [name parameters])
+ (do !
+ [parametersA (monad.map ! (function (_ [name value])
+ (do !
+ [valueA (analyse archive value)]
+ (wrap [name valueA])))
+ parameters)]
+ (wrap [name parametersA])))
+ annotations)
+ returnT (reflection_return mapping return)
+ arguments' (monad.map !
+ (function (_ [name jvmT])
+ (do !
+ [luxT (reflection_type mapping jvmT)]
+ (wrap [name luxT])))
+ arguments)
+ [scope bodyA] (|> arguments'
+ (#.Cons [self_name selfT])
+ list.reverse
+ (list\fold scope.with_local (analyse archive body))
+ (typeA.with_type returnT)
+ /////analysis.with_scope)]
+ (wrap (/////analysis.tuple (list (/////analysis.text ..overriden_tag)
+ (class_analysis parent_type)
+ (/////analysis.text method_name)
+ (/////analysis.bit strict_fp?)
+ (/////analysis.tuple (list\map annotation_analysis annotationsA))
+ (/////analysis.tuple (list\map var_analysis vars))
+ (/////analysis.text self_name)
+ (/////analysis.tuple (list\map ..argument_analysis arguments))
+ (return_analysis return)
+ (/////analysis.tuple (list\map class_analysis
+ exceptions))
+ (#/////analysis.Function
+ (list\map (|>> /////analysis.variable)
+ (scope.environment scope))
+ (/////analysis.tuple (list bodyA)))
+ ))))))
+
+(type: #export (Method_Definition a)
+ (#Overriden_Method (Overriden_Method a)))
+
+(def: #export parameter_types
+ (-> (List (Type Var)) (Check (List [(Type Var) .Type])))
+ (monad.map check.monad
+ (function (_ parameterJ)
+ (do check.monad
+ [[_ parameterT] check.existential]
+ (wrap [parameterJ parameterT])))))
+
+(def: (mismatched_methods super_set sub_set)
+ (-> (List [Text (Type Method)])
+ (List [Text (Type Method)])
+ (List [Text (Type Method)]))
+ (list.filter (function (_ [sub_name subJT])
+ (|> super_set
+ (list.filter (function (_ [super_name superJT])
+ (and (text\= super_name sub_name)
+ (jvm\= superJT subJT))))
+ list.size
+ (n.= 1)
+ not))
+ sub_set))
+
+(exception: #export (class_parameter_mismatch {expected (List Text)}
+ {actual (List (Type Parameter))})
+ (exception.report
+ ["Expected (amount)" (%.nat (list.size expected))]
+ ["Expected (parameters)" (exception.enumerate %.text expected)]
+ ["Actual (amount)" (%.nat (list.size actual))]
+ ["Actual (parameters)" (exception.enumerate ..signature actual)]))
+
+(def: (super_aliasing class)
+ (-> (Type Class) (Operation Aliasing))
+ (do phase.monad
+ [#let [[name actual_parameters] (jvm_parser.read_class class)]
+ class (phase.lift (reflection!.load name))
+ #let [expected_parameters (|> (java/lang/Class::getTypeParameters class)
+ array.to_list
+ (list\map (|>> java/lang/reflect/TypeVariable::getName)))]
+ _ (phase.assert ..class_parameter_mismatch [expected_parameters actual_parameters]
+ (n.= (list.size expected_parameters)
+ (list.size actual_parameters)))]
+ (wrap (|> (list.zip/2 expected_parameters actual_parameters)
+ (list\fold (function (_ [expected actual] mapping)
+ (case (jvm_parser.var? actual)
+ (#.Some actual)
+ (dictionary.put actual expected mapping)
+
+ #.None
+ mapping))
+ jvm_alias.fresh)))))
+
+(def: (anonymous_class_name module id)
+ (-> Module Nat Text)
+ (let [global (text.replace_all .module_separator ..jvm_package_separator module)
+ local (format "anonymous-class" (%.nat id))]
+ (format global ..jvm_package_separator local)))
+
+(def: class::anonymous
+ Handler
+ (..custom
+ [($_ <>.and
+ (<code>.tuple (<>.some ..var))
+ ..class
+ (<code>.tuple (<>.some ..class))
+ (<code>.tuple (<>.some ..input))
+ (<code>.tuple (<>.some ..overriden_method_definition)))
+ (function (_ extension_name analyse archive [parameters
+ super_class
+ super_interfaces
+ constructor_args
+ methods])
+ (do {! phase.monad}
+ [_ (..ensure_fresh_class! (..reflection super_class))
+ _ (monad.map ! (|>> ..reflection ..ensure_fresh_class!) super_interfaces)
+ parameters (typeA.with_env
+ (..parameter_types parameters))
+ #let [mapping (list\fold (function (_ [parameterJ parameterT] mapping)
+ (dictionary.put (jvm_parser.name parameterJ)
+ parameterT
+ mapping))
+ luxT.fresh
+ parameters)]
+ super_classT (typeA.with_env
+ (luxT.check (luxT.class mapping) (..signature super_class)))
+ super_interfaceT+ (typeA.with_env
+ (monad.map check.monad
+ (|>> ..signature (luxT.check (luxT.class mapping)))
+ super_interfaces))
+ selfT (///.lift (do meta.monad
+ [where meta.current_module_name
+ id meta.count]
+ (wrap (inheritance_relationship_type (#.Primitive (..anonymous_class_name where id) (list))
+ super_classT
+ super_interfaceT+))))
+ _ (typeA.infer selfT)
+ constructor_argsA+ (monad.map ! (function (_ [type term])
+ (do !
+ [argT (reflection_type mapping type)
+ termA (typeA.with_type argT
+ (analyse archive term))]
+ (wrap [type termA])))
+ constructor_args)
+ methodsA (monad.map ! (analyse_overriden_method analyse archive selfT mapping) methods)
+ required_abstract_methods (phase.lift (all_abstract_methods (list& super_class super_interfaces)))
+ available_methods (phase.lift (all_methods (list& super_class super_interfaces)))
+ overriden_methods (monad.map ! (function (_ [parent_type method_name
+ strict_fp? annotations vars
+ self_name arguments return exceptions
+ body])
+ (do !
+ [aliasing (super_aliasing parent_type)]
+ (wrap [method_name (|> (jvm.method [(list\map product.right arguments)
+ return
+ exceptions])
+ (jvm_alias.method aliasing))])))
+ methods)
+ #let [missing_abstract_methods (mismatched_methods overriden_methods required_abstract_methods)
+ invalid_overriden_methods (mismatched_methods available_methods overriden_methods)]
+ _ (phase.assert ..missing_abstract_methods missing_abstract_methods
+ (list.empty? missing_abstract_methods))
+ _ (phase.assert ..invalid_overriden_methods invalid_overriden_methods
+ (list.empty? invalid_overriden_methods))]
+ (wrap (#/////analysis.Extension extension_name
+ (list (class_analysis super_class)
+ (/////analysis.tuple (list\map class_analysis super_interfaces))
+ (/////analysis.tuple (list\map typed_analysis constructor_argsA+))
+ (/////analysis.tuple methodsA))))))]))
+
+(def: bundle::class
+ Bundle
+ (<| (///bundle.prefix "class")
+ (|> ///bundle.empty
+ (///bundle.install "anonymous" class::anonymous)
+ )))
+
+(def: #export bundle
+ Bundle
+ (<| (///bundle.prefix "jvm")
+ (|> ///bundle.empty
+ (dictionary.merge bundle::conversion)
+ (dictionary.merge bundle::int)
+ (dictionary.merge bundle::long)
+ (dictionary.merge bundle::float)
+ (dictionary.merge bundle::double)
+ (dictionary.merge bundle::char)
+ (dictionary.merge bundle::array)
+ (dictionary.merge bundle::object)
+ (dictionary.merge bundle::member)
+ (dictionary.merge bundle::class)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux
new file mode 100644
index 000000000..b0bdba0cb
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux
@@ -0,0 +1,252 @@
+(.module:
+ [library
+ [lux #*
+ ["." ffi]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ [collection
+ ["." array (#+ Array)]
+ ["." dictionary]
+ ["." list]]]
+ ["." type
+ ["." check]]
+ ["@" target
+ ["_" lua]]]]
+ [//
+ ["/" lux (#+ custom)]
+ [//
+ ["." bundle]
+ [//
+ ["." analysis #_
+ ["#/." type]]
+ [//
+ ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
+ [///
+ ["." phase]]]]]])
+
+(def: Nil
+ (for {@.lua ffi.Nil}
+ Any))
+
+(def: Object
+ (for {@.lua (type (ffi.Object Any))}
+ Any))
+
+(def: Function
+ (for {@.lua ffi.Function}
+ Any))
+
+(def: array::new
+ Handler
+ (custom
+ [<code>.any
+ (function (_ extension phase archive lengthC)
+ (do phase.monad
+ [lengthA (analysis/type.with_type Nat
+ (phase archive lengthC))
+ [var_id varT] (analysis/type.with_env check.var)
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list lengthA)))))]))
+
+(def: array::length
+ Handler
+ (custom
+ [<code>.any
+ (function (_ extension phase archive arrayC)
+ (do phase.monad
+ [[var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer Nat)]
+ (wrap (#analysis.Extension extension (list arrayA)))))]))
+
+(def: array::read
+ Handler
+ (custom
+ [(<>.and <code>.any <code>.any)
+ (function (_ extension phase archive [indexC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer varT)]
+ (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
+
+(def: array::write
+ Handler
+ (custom
+ [($_ <>.and <code>.any <code>.any <code>.any)
+ (function (_ extension phase archive [indexC valueC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ valueA (analysis/type.with_type varT
+ (phase archive valueC))
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))]))
+
+(def: array::delete
+ Handler
+ (custom
+ [($_ <>.and <code>.any <code>.any)
+ (function (_ extension phase archive [indexC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
+
+(def: bundle::array
+ Bundle
+ (<| (bundle.prefix "array")
+ (|> bundle.empty
+ (bundle.install "new" array::new)
+ (bundle.install "length" array::length)
+ (bundle.install "read" array::read)
+ (bundle.install "write" array::write)
+ (bundle.install "delete" array::delete)
+ )))
+
+(def: object::get
+ Handler
+ (custom
+ [($_ <>.and <code>.text <code>.any)
+ (function (_ extension phase archive [fieldC objectC])
+ (do phase.monad
+ [objectA (analysis/type.with_type ..Object
+ (phase archive objectC))
+ _ (analysis/type.infer .Any)]
+ (wrap (#analysis.Extension extension (list (analysis.text fieldC)
+ objectA)))))]))
+
+(def: object::do
+ Handler
+ (custom
+ [($_ <>.and <code>.text <code>.any (<>.some <code>.any))
+ (function (_ extension phase archive [methodC objectC inputsC])
+ (do {! phase.monad}
+ [objectA (analysis/type.with_type ..Object
+ (phase archive objectC))
+ inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
+ _ (analysis/type.infer .Any)]
+ (wrap (#analysis.Extension extension (list& (analysis.text methodC)
+ objectA
+ inputsA)))))]))
+
+(def: bundle::object
+ Bundle
+ (<| (bundle.prefix "object")
+ (|> bundle.empty
+ (bundle.install "get" object::get)
+ (bundle.install "do" object::do)
+ (bundle.install "nil" (/.nullary ..Nil))
+ (bundle.install "nil?" (/.unary Any Bit))
+ )))
+
+(template [<name> <fromT> <toT>]
+ [(def: <name>
+ Handler
+ (custom
+ [<code>.any
+ (function (_ extension phase archive inputC)
+ (do {! phase.monad}
+ [inputA (analysis/type.with_type (type <fromT>)
+ (phase archive inputC))
+ _ (analysis/type.infer (type <toT>))]
+ (wrap (#analysis.Extension extension (list inputA)))))]))]
+
+ [utf8::encode Text (array.Array (I64 Any))]
+ [utf8::decode (array.Array (I64 Any)) Text]
+ )
+
+(def: bundle::utf8
+ Bundle
+ (<| (bundle.prefix "utf8")
+ (|> bundle.empty
+ (bundle.install "encode" utf8::encode)
+ (bundle.install "decode" utf8::decode)
+ )))
+
+(def: lua::constant
+ Handler
+ (custom
+ [<code>.text
+ (function (_ extension phase archive name)
+ (do phase.monad
+ [_ (analysis/type.infer Any)]
+ (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
+
+(def: lua::apply
+ Handler
+ (custom
+ [($_ <>.and <code>.any (<>.some <code>.any))
+ (function (_ extension phase archive [abstractionC inputsC])
+ (do {! phase.monad}
+ [abstractionA (analysis/type.with_type ..Function
+ (phase archive abstractionC))
+ inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
+ _ (analysis/type.infer Any)]
+ (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))]))
+
+(def: lua::power
+ Handler
+ (custom
+ [($_ <>.and <code>.any <code>.any)
+ (function (_ extension phase archive [powerC baseC])
+ (do {! phase.monad}
+ [powerA (analysis/type.with_type Frac
+ (phase archive powerC))
+ baseA (analysis/type.with_type Frac
+ (phase archive baseC))
+ _ (analysis/type.infer Frac)]
+ (wrap (#analysis.Extension extension (list powerA baseA)))))]))
+
+(def: lua::import
+ Handler
+ (custom
+ [<code>.text
+ (function (_ extension phase archive name)
+ (do phase.monad
+ [_ (analysis/type.infer ..Object)]
+ (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
+
+(def: lua::function
+ Handler
+ (custom
+ [($_ <>.and <code>.nat <code>.any)
+ (function (_ extension phase archive [arity abstractionC])
+ (do phase.monad
+ [#let [inputT (type.tuple (list.repeat arity Any))]
+ abstractionA (analysis/type.with_type (-> inputT Any)
+ (phase archive abstractionC))
+ _ (analysis/type.infer ..Function)]
+ (wrap (#analysis.Extension extension (list (analysis.nat arity)
+ abstractionA)))))]))
+
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "lua")
+ (|> bundle.empty
+ (dictionary.merge bundle::array)
+ (dictionary.merge bundle::object)
+ (dictionary.merge bundle::utf8)
+
+ (bundle.install "constant" lua::constant)
+ (bundle.install "apply" lua::apply)
+ (bundle.install "power" lua::power)
+ (bundle.install "import" lua::import)
+ (bundle.install "function" lua::function)
+ (bundle.install "script universe" (/.nullary .Bit))
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux
new file mode 100644
index 000000000..a5e924af1
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux
@@ -0,0 +1,301 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." maybe]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." dictionary (#+ Dictionary)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [type
+ ["." check]]
+ ["." meta]]]
+ ["." ///
+ ["#." bundle]
+ ["/#" // #_
+ [analysis
+ [".A" type]]
+ [//
+ ["#." analysis (#+ Analysis Operation Phase Handler Bundle)
+ [evaluation (#+ Eval)]]
+ [///
+ ["#" phase]
+ [meta
+ [archive (#+ Archive)]]]]]])
+
+(def: #export (custom [syntax handler])
+ (All [s]
+ (-> [(Parser s)
+ (-> Text Phase Archive s (Operation Analysis))]
+ Handler))
+ (function (_ extension_name analyse archive args)
+ (case (<code>.run syntax args)
+ (#try.Success inputs)
+ (handler extension_name analyse archive inputs)
+
+ (#try.Failure _)
+ (////analysis.throw ///.invalid_syntax [extension_name %.code args]))))
+
+(def: (simple inputsT+ outputT)
+ (-> (List Type) Type Handler)
+ (let [num_expected (list.size inputsT+)]
+ (function (_ extension_name analyse archive args)
+ (let [num_actual (list.size args)]
+ (if (n.= num_expected num_actual)
+ (do {! ////.monad}
+ [_ (typeA.infer outputT)
+ argsA (monad.map !
+ (function (_ [argT argC])
+ (typeA.with_type argT
+ (analyse archive argC)))
+ (list.zip/2 inputsT+ args))]
+ (wrap (#////analysis.Extension extension_name argsA)))
+ (////analysis.throw ///.incorrect_arity [extension_name num_expected num_actual]))))))
+
+(def: #export (nullary valueT)
+ (-> Type Handler)
+ (simple (list) valueT))
+
+(def: #export (unary inputT outputT)
+ (-> Type Type Handler)
+ (simple (list inputT) outputT))
+
+(def: #export (binary subjectT paramT outputT)
+ (-> Type Type Type Handler)
+ (simple (list subjectT paramT) outputT))
+
+(def: #export (trinary subjectT param0T param1T outputT)
+ (-> Type Type Type Type Handler)
+ (simple (list subjectT param0T param1T) outputT))
+
+## TODO: Get rid of this ASAP
+(as_is
+ (exception: #export (char_text_must_be_size_1 {text Text})
+ (exception.report
+ ["Text" (%.text text)]))
+
+ (def: text_char
+ (Parser text.Char)
+ (do <>.monad
+ [raw <code>.text]
+ (case (text.size raw)
+ 1 (wrap (|> raw (text.nth 0) maybe.assume))
+ _ (<>.fail (exception.construct ..char_text_must_be_size_1 [raw])))))
+
+ (def: lux::syntax_char_case!
+ (..custom
+ [($_ <>.and
+ <code>.any
+ (<code>.tuple (<>.some (<>.and (<code>.tuple (<>.many ..text_char))
+ <code>.any)))
+ <code>.any)
+ (function (_ extension_name phase archive [input conditionals else])
+ (do {! ////.monad}
+ [input (typeA.with_type text.Char
+ (phase archive input))
+ expectedT (///.lift meta.expected_type)
+ conditionals (monad.map ! (function (_ [cases branch])
+ (do !
+ [branch (typeA.with_type expectedT
+ (phase archive branch))]
+ (wrap [cases branch])))
+ conditionals)
+ else (typeA.with_type expectedT
+ (phase archive else))]
+ (wrap (|> conditionals
+ (list\map (function (_ [cases branch])
+ (////analysis.tuple
+ (list (////analysis.tuple (list\map (|>> ////analysis.nat) cases))
+ branch))))
+ (list& input else)
+ (#////analysis.Extension extension_name)))))])))
+
+## "lux is" represents reference/pointer equality.
+(def: lux::is
+ Handler
+ (function (_ extension_name analyse archive args)
+ (do ////.monad
+ [[var_id varT] (typeA.with_env check.var)]
+ ((binary varT varT Bit extension_name)
+ analyse archive args))))
+
+## "lux try" provides a simple way to interact with the host platform's
+## error_handling facilities.
+(def: lux::try
+ Handler
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list opC))
+ (do ////.monad
+ [[var_id varT] (typeA.with_env check.var)
+ _ (typeA.infer (type (Either Text varT)))
+ opA (typeA.with_type (type (-> .Any varT))
+ (analyse archive opC))]
+ (wrap (#////analysis.Extension extension_name (list opA))))
+
+ _
+ (////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
+
+(def: lux::in_module
+ Handler
+ (function (_ extension_name analyse archive argsC+)
+ (case argsC+
+ (^ (list [_ (#.Text module_name)] exprC))
+ (////analysis.with_current_module module_name
+ (analyse archive exprC))
+
+ _
+ (////analysis.throw ///.invalid_syntax [extension_name %.code argsC+]))))
+
+(def: (lux::type::check eval)
+ (-> Eval Handler)
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list typeC valueC))
+ (do {! ////.monad}
+ [count (///.lift meta.count)
+ actualT (\ ! map (|>> (:as Type))
+ (eval archive count Type typeC))
+ _ (typeA.infer actualT)]
+ (typeA.with_type actualT
+ (analyse archive valueC)))
+
+ _
+ (////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)]))))
+
+(def: (lux::type::as eval)
+ (-> Eval Handler)
+ (function (_ extension_name analyse archive args)
+ (case args
+ (^ (list typeC valueC))
+ (do {! ////.monad}
+ [count (///.lift meta.count)
+ actualT (\ ! map (|>> (:as Type))
+ (eval archive count Type typeC))
+ _ (typeA.infer actualT)
+ [valueT valueA] (typeA.with_inference
+ (analyse archive valueC))]
+ (wrap valueA))
+
+ _
+ (////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)]))))
+
+(def: (caster input output)
+ (-> Type Type Handler)
+ (..custom
+ [<code>.any
+ (function (_ extension_name phase archive valueC)
+ (do {! ////.monad}
+ [_ (typeA.infer output)]
+ (typeA.with_type input
+ (phase archive valueC))))]))
+
+(def: lux::macro
+ Handler
+ (..custom
+ [<code>.any
+ (function (_ extension_name phase archive valueC)
+ (do {! ////.monad}
+ [_ (typeA.infer .Macro)
+ input_type (loop [input_name (name_of .Macro')]
+ (do !
+ [input_type (///.lift (meta.find_def (name_of .Macro')))]
+ (case input_type
+ (#.Definition [exported? def_type def_data def_value])
+ (wrap (:as Type def_value))
+
+ (#.Alias real_name)
+ (recur real_name))))]
+ (typeA.with_type input_type
+ (phase archive valueC))))]))
+
+(def: (bundle::lux eval)
+ (-> Eval Bundle)
+ (|> ///bundle.empty
+ (///bundle.install "syntax char case!" lux::syntax_char_case!)
+ (///bundle.install "is" lux::is)
+ (///bundle.install "try" lux::try)
+ (///bundle.install "type check" (lux::type::check eval))
+ (///bundle.install "type as" (lux::type::as eval))
+ (///bundle.install "macro" ..lux::macro)
+ (///bundle.install "type check type" (..caster .Type .Type))
+ (///bundle.install "in-module" lux::in_module)))
+
+(def: bundle::io
+ Bundle
+ (<| (///bundle.prefix "io")
+ (|> ///bundle.empty
+ (///bundle.install "log" (unary Text Any))
+ (///bundle.install "error" (unary Text Nothing))
+ (///bundle.install "exit" (unary Int Nothing)))))
+
+(def: I64* (type (I64 Any)))
+
+(def: bundle::i64
+ Bundle
+ (<| (///bundle.prefix "i64")
+ (|> ///bundle.empty
+ (///bundle.install "and" (binary I64* I64* I64))
+ (///bundle.install "or" (binary I64* I64* I64))
+ (///bundle.install "xor" (binary I64* I64* I64))
+ (///bundle.install "left-shift" (binary Nat I64* I64))
+ (///bundle.install "right-shift" (binary Nat I64* I64))
+ (///bundle.install "=" (binary I64* I64* Bit))
+ (///bundle.install "<" (binary Int Int Bit))
+ (///bundle.install "+" (binary I64* I64* I64))
+ (///bundle.install "-" (binary I64* I64* I64))
+ (///bundle.install "*" (binary Int Int Int))
+ (///bundle.install "/" (binary Int Int Int))
+ (///bundle.install "%" (binary Int Int Int))
+ (///bundle.install "f64" (unary Int Frac))
+ (///bundle.install "char" (unary Int Text)))))
+
+(def: bundle::f64
+ Bundle
+ (<| (///bundle.prefix "f64")
+ (|> ///bundle.empty
+ (///bundle.install "+" (binary Frac Frac Frac))
+ (///bundle.install "-" (binary Frac Frac Frac))
+ (///bundle.install "*" (binary Frac Frac Frac))
+ (///bundle.install "/" (binary Frac Frac Frac))
+ (///bundle.install "%" (binary Frac Frac Frac))
+ (///bundle.install "=" (binary Frac Frac Bit))
+ (///bundle.install "<" (binary Frac Frac Bit))
+ (///bundle.install "i64" (unary Frac Int))
+ (///bundle.install "encode" (unary Frac Text))
+ (///bundle.install "decode" (unary Text (type (Maybe Frac)))))))
+
+(def: bundle::text
+ Bundle
+ (<| (///bundle.prefix "text")
+ (|> ///bundle.empty
+ (///bundle.install "=" (binary Text Text Bit))
+ (///bundle.install "<" (binary Text Text Bit))
+ (///bundle.install "concat" (binary Text Text Text))
+ (///bundle.install "index" (trinary Nat Text Text (type (Maybe Nat))))
+ (///bundle.install "size" (unary Text Nat))
+ (///bundle.install "char" (binary Nat Text Nat))
+ (///bundle.install "clip" (trinary Nat Nat Text Text))
+ )))
+
+(def: #export (bundle eval)
+ (-> Eval Bundle)
+ (<| (///bundle.prefix "lux")
+ (|> ///bundle.empty
+ (dictionary.merge (bundle::lux eval))
+ (dictionary.merge bundle::i64)
+ (dictionary.merge bundle::f64)
+ (dictionary.merge bundle::text)
+ (dictionary.merge bundle::io)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux
new file mode 100644
index 000000000..a30c9e6f0
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux
@@ -0,0 +1,214 @@
+(.module:
+ [library
+ [lux #*
+ ["." ffi]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<c>" code (#+ Parser)]]]
+ [data
+ [collection
+ ["." array (#+ Array)]
+ ["." dictionary]
+ ["." list]]]
+ ["." type
+ ["." check]]
+ ["@" target
+ ["_" php]]]]
+ [//
+ ["/" lux (#+ custom)]
+ [//
+ ["." bundle]
+ [//
+ ["." analysis #_
+ ["#/." type]]
+ [//
+ ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
+ [///
+ ["." phase]]]]]])
+
+(def: array::new
+ Handler
+ (custom
+ [<c>.any
+ (function (_ extension phase archive lengthC)
+ (do phase.monad
+ [lengthA (analysis/type.with_type Nat
+ (phase archive lengthC))
+ [var_id varT] (analysis/type.with_env check.var)
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list lengthA)))))]))
+
+(def: array::length
+ Handler
+ (custom
+ [<c>.any
+ (function (_ extension phase archive arrayC)
+ (do phase.monad
+ [[var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer Nat)]
+ (wrap (#analysis.Extension extension (list arrayA)))))]))
+
+(def: array::read
+ Handler
+ (custom
+ [(<>.and <c>.any <c>.any)
+ (function (_ extension phase archive [indexC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer varT)]
+ (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
+
+(def: array::write
+ Handler
+ (custom
+ [($_ <>.and <c>.any <c>.any <c>.any)
+ (function (_ extension phase archive [indexC valueC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ valueA (analysis/type.with_type varT
+ (phase archive valueC))
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))]))
+
+(def: array::delete
+ Handler
+ (custom
+ [($_ <>.and <c>.any <c>.any)
+ (function (_ extension phase archive [indexC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
+
+(def: bundle::array
+ Bundle
+ (<| (bundle.prefix "array")
+ (|> bundle.empty
+ (bundle.install "new" array::new)
+ (bundle.install "length" array::length)
+ (bundle.install "read" array::read)
+ (bundle.install "write" array::write)
+ (bundle.install "delete" array::delete)
+ )))
+
+(def: Null
+ (for {@.php ffi.Null}
+ Any))
+
+(def: Object
+ (for {@.php (type (ffi.Object Any))}
+ Any))
+
+(def: Function
+ (for {@.php ffi.Function}
+ Any))
+
+(def: object::new
+ Handler
+ (custom
+ [($_ <>.and <c>.text (<>.some <c>.any))
+ (function (_ extension phase archive [constructor inputsC])
+ (do {! phase.monad}
+ [inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
+ _ (analysis/type.infer .Any)]
+ (wrap (#analysis.Extension extension (list& (analysis.text constructor) inputsA)))))]))
+
+(def: object::get
+ Handler
+ (custom
+ [($_ <>.and <c>.text <c>.any)
+ (function (_ extension phase archive [fieldC objectC])
+ (do phase.monad
+ [objectA (analysis/type.with_type ..Object
+ (phase archive objectC))
+ _ (analysis/type.infer .Any)]
+ (wrap (#analysis.Extension extension (list (analysis.text fieldC)
+ objectA)))))]))
+
+(def: object::do
+ Handler
+ (custom
+ [($_ <>.and <c>.text <c>.any (<>.some <c>.any))
+ (function (_ extension phase archive [methodC objectC inputsC])
+ (do {! phase.monad}
+ [objectA (analysis/type.with_type ..Object
+ (phase archive objectC))
+ inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
+ _ (analysis/type.infer .Any)]
+ (wrap (#analysis.Extension extension (list& (analysis.text methodC)
+ objectA
+ inputsA)))))]))
+
+(def: bundle::object
+ Bundle
+ (<| (bundle.prefix "object")
+ (|> bundle.empty
+ (bundle.install "new" object::new)
+ (bundle.install "get" object::get)
+ (bundle.install "do" object::do)
+ (bundle.install "null" (/.nullary ..Null))
+ (bundle.install "null?" (/.unary Any Bit))
+ )))
+
+(def: php::constant
+ Handler
+ (custom
+ [<c>.text
+ (function (_ extension phase archive name)
+ (do phase.monad
+ [_ (analysis/type.infer Any)]
+ (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
+
+(def: php::apply
+ Handler
+ (custom
+ [($_ <>.and <c>.any (<>.some <c>.any))
+ (function (_ extension phase archive [abstractionC inputsC])
+ (do {! phase.monad}
+ [abstractionA (analysis/type.with_type ..Function
+ (phase archive abstractionC))
+ inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
+ _ (analysis/type.infer Any)]
+ (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))]))
+
+(def: php::pack
+ Handler
+ (custom
+ [($_ <>.and <c>.any <c>.any)
+ (function (_ extension phase archive [formatC dataC])
+ (do {! phase.monad}
+ [formatA (analysis/type.with_type Text
+ (phase archive formatC))
+ dataA (analysis/type.with_type (type (Array (I64 Any)))
+ (phase archive dataC))
+ _ (analysis/type.infer Text)]
+ (wrap (#analysis.Extension extension (list formatA dataA)))))]))
+
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "php")
+ (|> bundle.empty
+ (dictionary.merge bundle::array)
+ (dictionary.merge bundle::object)
+
+ (bundle.install "constant" php::constant)
+ (bundle.install "apply" php::apply)
+ (bundle.install "pack" php::pack)
+ (bundle.install "script universe" (/.nullary .Bit))
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux
new file mode 100644
index 000000000..a3635cf96
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux
@@ -0,0 +1,231 @@
+(.module:
+ [library
+ [lux #*
+ ["." ffi]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ [collection
+ ["." array (#+ Array)]
+ ["." dictionary]
+ ["." list]]]
+ ["." type
+ ["." check]]
+ ["@" target
+ ["_" python]]]]
+ [//
+ ["/" lux (#+ custom)]
+ [//
+ ["." bundle]
+ [//
+ ["." analysis #_
+ ["#/." type]]
+ [//
+ ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
+ [///
+ ["." phase]]]]]])
+
+(def: array::new
+ Handler
+ (custom
+ [<code>.any
+ (function (_ extension phase archive lengthC)
+ (do phase.monad
+ [lengthA (analysis/type.with_type Nat
+ (phase archive lengthC))
+ [var_id varT] (analysis/type.with_env check.var)
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list lengthA)))))]))
+
+(def: array::length
+ Handler
+ (custom
+ [<code>.any
+ (function (_ extension phase archive arrayC)
+ (do phase.monad
+ [[var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer Nat)]
+ (wrap (#analysis.Extension extension (list arrayA)))))]))
+
+(def: array::read
+ Handler
+ (custom
+ [(<>.and <code>.any <code>.any)
+ (function (_ extension phase archive [indexC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer varT)]
+ (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
+
+(def: array::write
+ Handler
+ (custom
+ [($_ <>.and <code>.any <code>.any <code>.any)
+ (function (_ extension phase archive [indexC valueC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ valueA (analysis/type.with_type varT
+ (phase archive valueC))
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))]))
+
+(def: array::delete
+ Handler
+ (custom
+ [($_ <>.and <code>.any <code>.any)
+ (function (_ extension phase archive [indexC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
+
+(def: bundle::array
+ Bundle
+ (<| (bundle.prefix "array")
+ (|> bundle.empty
+ (bundle.install "new" array::new)
+ (bundle.install "length" array::length)
+ (bundle.install "read" array::read)
+ (bundle.install "write" array::write)
+ (bundle.install "delete" array::delete)
+ )))
+
+(def: None
+ (for {@.python
+ ffi.None}
+ Any))
+
+(def: Object
+ (for {@.python (type (ffi.Object Any))}
+ Any))
+
+(def: Function
+ (for {@.python ffi.Function}
+ Any))
+
+(def: Dict
+ (for {@.python ffi.Dict}
+ Any))
+
+(def: object::get
+ Handler
+ (custom
+ [($_ <>.and <code>.text <code>.any)
+ (function (_ extension phase archive [fieldC objectC])
+ (do phase.monad
+ [objectA (analysis/type.with_type ..Object
+ (phase archive objectC))
+ _ (analysis/type.infer .Any)]
+ (wrap (#analysis.Extension extension (list (analysis.text fieldC)
+ objectA)))))]))
+
+(def: object::do
+ Handler
+ (custom
+ [($_ <>.and <code>.text <code>.any (<>.some <code>.any))
+ (function (_ extension phase archive [methodC objectC inputsC])
+ (do {! phase.monad}
+ [objectA (analysis/type.with_type ..Object
+ (phase archive objectC))
+ inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
+ _ (analysis/type.infer .Any)]
+ (wrap (#analysis.Extension extension (list& (analysis.text methodC)
+ objectA
+ inputsA)))))]))
+
+(def: bundle::object
+ Bundle
+ (<| (bundle.prefix "object")
+ (|> bundle.empty
+ (bundle.install "get" object::get)
+ (bundle.install "do" object::do)
+ (bundle.install "none" (/.nullary ..None))
+ (bundle.install "none?" (/.unary Any Bit))
+ )))
+
+(def: python::constant
+ Handler
+ (custom
+ [<code>.text
+ (function (_ extension phase archive name)
+ (do phase.monad
+ [_ (analysis/type.infer Any)]
+ (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
+
+(def: python::import
+ Handler
+ (custom
+ [<code>.text
+ (function (_ extension phase archive name)
+ (do phase.monad
+ [_ (analysis/type.infer ..Object)]
+ (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
+
+(def: python::apply
+ Handler
+ (custom
+ [($_ <>.and <code>.any (<>.some <code>.any))
+ (function (_ extension phase archive [abstractionC inputsC])
+ (do {! phase.monad}
+ [abstractionA (analysis/type.with_type ..Function
+ (phase archive abstractionC))
+ inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
+ _ (analysis/type.infer Any)]
+ (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))]))
+
+(def: python::function
+ Handler
+ (custom
+ [($_ <>.and <code>.nat <code>.any)
+ (function (_ extension phase archive [arity abstractionC])
+ (do phase.monad
+ [#let [inputT (type.tuple (list.repeat arity Any))]
+ abstractionA (analysis/type.with_type (-> inputT Any)
+ (phase archive abstractionC))
+ _ (analysis/type.infer ..Function)]
+ (wrap (#analysis.Extension extension (list (analysis.nat arity)
+ abstractionA)))))]))
+
+(def: python::exec
+ Handler
+ (custom
+ [($_ <>.and <code>.any <code>.any)
+ (function (_ extension phase archive [codeC globalsC])
+ (do phase.monad
+ [codeA (analysis/type.with_type Text
+ (phase archive codeC))
+ globalsA (analysis/type.with_type ..Dict
+ (phase archive globalsC))
+ _ (analysis/type.infer .Any)]
+ (wrap (#analysis.Extension extension (list codeA globalsA)))))]))
+
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "python")
+ (|> bundle.empty
+ (dictionary.merge bundle::array)
+ (dictionary.merge bundle::object)
+
+ (bundle.install "constant" python::constant)
+ (bundle.install "import" python::import)
+ (bundle.install "apply" python::apply)
+ (bundle.install "function" python::function)
+ (bundle.install "exec" python::exec)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux
new file mode 100644
index 000000000..6dfbf707e
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux
@@ -0,0 +1,35 @@
+(.module:
+ [library
+ [lux #*
+ ["." ffi]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<c>" code (#+ Parser)]]]
+ [data
+ [collection
+ ["." array (#+ Array)]
+ ["." dictionary]
+ ["." list]]]
+ ["." type
+ ["." check]]
+ ["@" target
+ ["_" r]]]]
+ [//
+ ["/" lux (#+ custom)]
+ [//
+ ["." bundle]
+ [//
+ ["." analysis #_
+ ["#/." type]]
+ [//
+ ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
+ [///
+ ["." phase]]]]]])
+
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "r")
+ (|> bundle.empty
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux
new file mode 100644
index 000000000..1d01b479d
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux
@@ -0,0 +1,199 @@
+(.module:
+ [library
+ [lux #*
+ ["." ffi]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<c>" code (#+ Parser)]]]
+ [data
+ [collection
+ ["." array (#+ Array)]
+ ["." dictionary]
+ ["." list]]]
+ ["." type
+ ["." check]]
+ ["@" target
+ ["_" ruby]]]]
+ [//
+ ["/" lux (#+ custom)]
+ [//
+ ["." bundle]
+ [//
+ ["." analysis #_
+ ["#/." type]]
+ [//
+ ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
+ [///
+ ["." phase]]]]]])
+
+(def: array::new
+ Handler
+ (custom
+ [<c>.any
+ (function (_ extension phase archive lengthC)
+ (do phase.monad
+ [lengthA (analysis/type.with_type Nat
+ (phase archive lengthC))
+ [var_id varT] (analysis/type.with_env check.var)
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list lengthA)))))]))
+
+(def: array::length
+ Handler
+ (custom
+ [<c>.any
+ (function (_ extension phase archive arrayC)
+ (do phase.monad
+ [[var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer Nat)]
+ (wrap (#analysis.Extension extension (list arrayA)))))]))
+
+(def: array::read
+ Handler
+ (custom
+ [(<>.and <c>.any <c>.any)
+ (function (_ extension phase archive [indexC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer varT)]
+ (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
+
+(def: array::write
+ Handler
+ (custom
+ [($_ <>.and <c>.any <c>.any <c>.any)
+ (function (_ extension phase archive [indexC valueC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ valueA (analysis/type.with_type varT
+ (phase archive valueC))
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))]))
+
+(def: array::delete
+ Handler
+ (custom
+ [($_ <>.and <c>.any <c>.any)
+ (function (_ extension phase archive [indexC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
+
+(def: bundle::array
+ Bundle
+ (<| (bundle.prefix "array")
+ (|> bundle.empty
+ (bundle.install "new" array::new)
+ (bundle.install "length" array::length)
+ (bundle.install "read" array::read)
+ (bundle.install "write" array::write)
+ (bundle.install "delete" array::delete)
+ )))
+
+(def: Nil
+ (for {@.ruby ffi.Nil}
+ Any))
+
+(def: Object
+ (for {@.ruby (type (ffi.Object Any))}
+ Any))
+
+(def: Function
+ (for {@.ruby ffi.Function}
+ Any))
+
+(def: object::get
+ Handler
+ (custom
+ [($_ <>.and <c>.text <c>.any)
+ (function (_ extension phase archive [fieldC objectC])
+ (do phase.monad
+ [objectA (analysis/type.with_type ..Object
+ (phase archive objectC))
+ _ (analysis/type.infer .Any)]
+ (wrap (#analysis.Extension extension (list (analysis.text fieldC)
+ objectA)))))]))
+
+(def: object::do
+ Handler
+ (custom
+ [($_ <>.and <c>.text <c>.any (<>.some <c>.any))
+ (function (_ extension phase archive [methodC objectC inputsC])
+ (do {! phase.monad}
+ [objectA (analysis/type.with_type ..Object
+ (phase archive objectC))
+ inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
+ _ (analysis/type.infer .Any)]
+ (wrap (#analysis.Extension extension (list& (analysis.text methodC)
+ objectA
+ inputsA)))))]))
+
+(def: bundle::object
+ Bundle
+ (<| (bundle.prefix "object")
+ (|> bundle.empty
+ (bundle.install "get" object::get)
+ (bundle.install "do" object::do)
+ (bundle.install "nil" (/.nullary ..Nil))
+ (bundle.install "nil?" (/.unary Any Bit))
+ )))
+
+(def: ruby::constant
+ Handler
+ (custom
+ [<c>.text
+ (function (_ extension phase archive name)
+ (do phase.monad
+ [_ (analysis/type.infer Any)]
+ (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
+
+(def: ruby::apply
+ Handler
+ (custom
+ [($_ <>.and <c>.any (<>.some <c>.any))
+ (function (_ extension phase archive [abstractionC inputsC])
+ (do {! phase.monad}
+ [abstractionA (analysis/type.with_type ..Function
+ (phase archive abstractionC))
+ inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
+ _ (analysis/type.infer Any)]
+ (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))]))
+
+(def: ruby::import
+ Handler
+ (custom
+ [<c>.text
+ (function (_ extension phase archive name)
+ (do phase.monad
+ [_ (analysis/type.infer Bit)]
+ (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
+
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "ruby")
+ (|> bundle.empty
+ (dictionary.merge bundle::array)
+ (dictionary.merge bundle::object)
+
+ (bundle.install "constant" ruby::constant)
+ (bundle.install "apply" ruby::apply)
+ (bundle.install "import" ruby::import)
+ (bundle.install "script universe" (/.nullary .Bit))
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux
new file mode 100644
index 000000000..e7ff4ba15
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux
@@ -0,0 +1,158 @@
+(.module:
+ [library
+ [lux #*
+ ["." ffi]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<c>" code (#+ Parser)]]]
+ [data
+ [collection
+ ["." array (#+ Array)]
+ ["." dictionary]
+ ["." list]]]
+ ["." type
+ ["." check]]
+ ["@" target
+ ["_" scheme]]]]
+ [//
+ ["/" lux (#+ custom)]
+ [//
+ ["." bundle]
+ [//
+ ["." analysis #_
+ ["#/." type]]
+ [//
+ ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
+ [///
+ ["." phase]]]]]])
+
+(def: array::new
+ Handler
+ (custom
+ [<c>.any
+ (function (_ extension phase archive lengthC)
+ (do phase.monad
+ [lengthA (analysis/type.with_type Nat
+ (phase archive lengthC))
+ [var_id varT] (analysis/type.with_env check.var)
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list lengthA)))))]))
+
+(def: array::length
+ Handler
+ (custom
+ [<c>.any
+ (function (_ extension phase archive arrayC)
+ (do phase.monad
+ [[var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer Nat)]
+ (wrap (#analysis.Extension extension (list arrayA)))))]))
+
+(def: array::read
+ Handler
+ (custom
+ [(<>.and <c>.any <c>.any)
+ (function (_ extension phase archive [indexC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer varT)]
+ (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
+
+(def: array::write
+ Handler
+ (custom
+ [($_ <>.and <c>.any <c>.any <c>.any)
+ (function (_ extension phase archive [indexC valueC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ valueA (analysis/type.with_type varT
+ (phase archive valueC))
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))]))
+
+(def: array::delete
+ Handler
+ (custom
+ [($_ <>.and <c>.any <c>.any)
+ (function (_ extension phase archive [indexC arrayC])
+ (do phase.monad
+ [indexA (analysis/type.with_type Nat
+ (phase archive indexC))
+ [var_id varT] (analysis/type.with_env check.var)
+ arrayA (analysis/type.with_type (type (Array varT))
+ (phase archive arrayC))
+ _ (analysis/type.infer (type (Array varT)))]
+ (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
+
+(def: bundle::array
+ Bundle
+ (<| (bundle.prefix "array")
+ (|> bundle.empty
+ (bundle.install "new" array::new)
+ (bundle.install "length" array::length)
+ (bundle.install "read" array::read)
+ (bundle.install "write" array::write)
+ (bundle.install "delete" array::delete)
+ )))
+
+(def: Nil
+ (for {@.scheme
+ ffi.Nil}
+ Any))
+
+(def: Function
+ (for {@.scheme ffi.Function}
+ Any))
+
+(def: bundle::object
+ Bundle
+ (<| (bundle.prefix "object")
+ (|> bundle.empty
+ (bundle.install "nil" (/.nullary ..Nil))
+ (bundle.install "nil?" (/.unary Any Bit))
+ )))
+
+(def: scheme::constant
+ Handler
+ (custom
+ [<c>.text
+ (function (_ extension phase archive name)
+ (do phase.monad
+ [_ (analysis/type.infer Any)]
+ (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
+
+(def: scheme::apply
+ Handler
+ (custom
+ [($_ <>.and <c>.any (<>.some <c>.any))
+ (function (_ extension phase archive [abstractionC inputsC])
+ (do {! phase.monad}
+ [abstractionA (analysis/type.with_type ..Function
+ (phase archive abstractionC))
+ inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
+ _ (analysis/type.infer Any)]
+ (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))]))
+
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "scheme")
+ (|> bundle.empty
+ (dictionary.merge bundle::array)
+ (dictionary.merge bundle::object)
+
+ (bundle.install "constant" scheme::constant)
+ (bundle.install "apply" scheme::apply)
+ (bundle.install "script universe" (/.nullary .Bit))
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/bundle.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/bundle.lux
new file mode 100644
index 000000000..3fb0c967e
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/bundle.lux
@@ -0,0 +1,29 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." dictionary (#+ Dictionary)]]]]]
+ [// (#+ Handler Bundle)])
+
+(def: #export empty
+ Bundle
+ (dictionary.new text.hash))
+
+(def: #export (install name anonymous)
+ (All [s i o]
+ (-> Text (Handler s i o)
+ (-> (Bundle s i o) (Bundle s i o))))
+ (dictionary.put name anonymous))
+
+(def: #export (prefix prefix)
+ (All [s i o]
+ (-> Text (-> (Bundle s i o) (Bundle s i o))))
+ (|>> dictionary.entries
+ (list\map (function (_ [key val]) [(format prefix " " key) val]))
+ (dictionary.from_list text.hash)))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux
new file mode 100644
index 000000000..8678c6269
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux
@@ -0,0 +1,307 @@
+(.module:
+ [library
+ [lux (#- Type Definition)
+ ["." host]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["<>" parser ("#\." monad)
+ ["<c>" code (#+ Parser)]
+ ["<t>" text]]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." dictionary]
+ ["." row]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["." i32]]]
+ [target
+ [jvm
+ ["_" bytecode (#+ Bytecode)]
+ ["." modifier (#+ Modifier) ("#\." monoid)]
+ ["." attribute]
+ ["." field]
+ ["." version]
+ ["." class]
+ ["." constant
+ ["." pool (#+ Resource)]]
+ [encoding
+ ["." name]]
+ ["." type (#+ Type Constraint Argument Typed)
+ [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
+ [".T" lux (#+ Mapping)]
+ ["." signature]
+ ["." descriptor (#+ Descriptor)]
+ ["." parser]]]]
+ [tool
+ [compiler
+ ["." analysis]
+ ["." synthesis]
+ ["." generation]
+ ["." directive (#+ Handler Bundle)]
+ ["." phase
+ [analysis
+ [".A" type]]
+ ["." generation
+ [jvm
+ [runtime (#+ Anchor Definition)]]]
+ ["." extension
+ ["." bundle]
+ [analysis
+ ["." jvm]]
+ [directive
+ ["/" lux]]]]]]
+ [type
+ ["." check (#+ Check)]]]])
+
+(type: Operation
+ (directive.Operation Anchor (Bytecode Any) Definition))
+
+(def: signature (|>> type.signature signature.signature))
+
+(type: Declaration
+ [Text (List (Type Var))])
+
+(def: declaration
+ (Parser Declaration)
+ (<c>.form (<>.and <c>.text (<>.some jvm.var))))
+
+(def: visibility
+ (Parser (Modifier field.Field))
+ (`` ($_ <>.either
+ (~~ (template [<label> <modifier>]
+ [(<>.after (<c>.text! <label>) (<>\wrap <modifier>))]
+
+ ["public" field.public]
+ ["private" field.private]
+ ["protected" field.protected]
+ ["default" modifier.empty])))))
+
+(def: inheritance
+ (Parser (Modifier class.Class))
+ (`` ($_ <>.either
+ (~~ (template [<label> <modifier>]
+ [(<>.after (<c>.text! <label>) (<>\wrap <modifier>))]
+
+ ["final" class.final]
+ ["abstract" class.abstract]
+ ["default" modifier.empty])))))
+
+(def: state
+ (Parser (Modifier field.Field))
+ (`` ($_ <>.either
+ (~~ (template [<label> <modifier>]
+ [(<>.after (<c>.text! <label>) (<>\wrap <modifier>))]
+
+ ["volatile" field.volatile]
+ ["final" field.final]
+ ["default" modifier.empty])))))
+
+(type: Annotation Any)
+
+(def: annotation
+ (Parser Annotation)
+ <c>.any)
+
+(def: field-type
+ (Parser (Type Value))
+ (<t>.embed parser.value <c>.text))
+
+(type: Constant
+ [Text (List Annotation) (Type Value) Code])
+
+(def: constant
+ (Parser Constant)
+ (<| <c>.form
+ (<>.after (<c>.text! "constant"))
+ ($_ <>.and
+ <c>.text
+ (<c>.tuple (<>.some ..annotation))
+ ..field-type
+ <c>.any
+ )))
+
+(type: Variable
+ [Text (Modifier field.Field) (Modifier field.Field) (List Annotation) (Type Value)])
+
+(def: variable
+ (Parser Variable)
+ (<| <c>.form
+ (<>.after (<c>.text! "variable"))
+ ($_ <>.and
+ <c>.text
+ ..visibility
+ ..state
+ (<c>.tuple (<>.some ..annotation))
+ ..field-type
+ )))
+
+(type: Field
+ (#Constant Constant)
+ (#Variable Variable))
+
+(def: field
+ (Parser Field)
+ ($_ <>.or
+ ..constant
+ ..variable
+ ))
+
+(type: Method-Definition
+ (#Constructor (jvm.Constructor Code))
+ (#Virtual-Method (jvm.Virtual-Method Code))
+ (#Static-Method (jvm.Static-Method Code))
+ (#Overriden-Method (jvm.Overriden-Method Code)))
+
+(def: method
+ (Parser Method-Definition)
+ ($_ <>.or
+ jvm.constructor-definition
+ jvm.virtual-method-definition
+ jvm.static-method-definition
+ jvm.overriden-method-definition
+ ))
+
+(def: (constraint name)
+ (-> Text Constraint)
+ {#type.name name
+ #type.super-class (type.class "java.lang.Object" (list))
+ #type.super-interfaces (list)})
+
+(def: constant::modifier
+ (Modifier field.Field)
+ ($_ modifier\compose
+ field.public
+ field.static
+ field.final))
+
+(def: (field-definition field)
+ (-> Field (Resource field.Field))
+ (case field
+ ## TODO: Handle annotations.
+ (#Constant [name annotations type value])
+ (case value
+ (^template [<tag> <type> <constant>]
+ [[_ (<tag> value)]
+ (do pool.monad
+ [constant (`` (|> value (~~ (template.splice <constant>))))
+ attribute (attribute.constant constant)]
+ (field.field ..constant::modifier name <type> (row.row attribute)))])
+ ([#.Bit type.boolean [(case> #0 +0 #1 +1) .i64 i32.i32 constant.integer pool.integer]]
+ [#.Int type.byte [.i64 i32.i32 constant.integer pool.integer]]
+ [#.Int type.short [.i64 i32.i32 constant.integer pool.integer]]
+ [#.Int type.int [.i64 i32.i32 constant.integer pool.integer]]
+ [#.Int type.long [constant.long pool.long]]
+ [#.Frac type.float [host.double-to-float constant.float pool.float]]
+ [#.Frac type.double [constant.double pool.double]]
+ [#.Nat type.char [.i64 i32.i32 constant.integer pool.integer]]
+ [#.Text (type.class "java.lang.String" (list)) [pool.string]]
+ )
+
+ ## TODO: Tighten this pattern-matching so this catch-all clause isn't necessary.
+ _
+ (undefined))
+
+ ## TODO: Handle annotations.
+ (#Variable [name visibility state annotations type])
+ (field.field (modifier\compose visibility state)
+ name type (row.row))))
+
+(def: (method-definition [mapping selfT] [analyse synthesize generate])
+ (-> [Mapping .Type]
+ [analysis.Phase
+ synthesis.Phase
+ (generation.Phase Anchor (Bytecode Any) Definition)]
+ (-> Method-Definition (Operation synthesis.Synthesis)))
+ (function (_ methodC)
+ (do phase.monad
+ [methodA (: (Operation analysis.Analysis)
+ (directive.lift-analysis
+ (case methodC
+ (#Constructor method)
+ (jvm.analyse-constructor-method analyse selfT mapping method)
+
+ (#Virtual-Method method)
+ (jvm.analyse-virtual-method analyse selfT mapping method)
+
+ (#Static-Method method)
+ (jvm.analyse-static-method analyse mapping method)
+
+ (#Overriden-Method method)
+ (jvm.analyse-overriden-method analyse selfT mapping method))))]
+ (directive.lift-synthesis
+ (synthesize methodA)))))
+
+(def: jvm::class
+ (Handler Anchor (Bytecode Any) Definition)
+ (/.custom
+ [($_ <>.and
+ ..declaration
+ jvm.class
+ (<c>.tuple (<>.some jvm.class))
+ ..inheritance
+ (<c>.tuple (<>.some ..annotation))
+ (<c>.tuple (<>.some ..field))
+ (<c>.tuple (<>.some ..method)))
+ (function (_ extension phase
+ [[name parameters]
+ super-class
+ super-interfaces
+ inheritance
+ ## TODO: Handle annotations.
+ annotations
+ fields
+ methods])
+ (do {! phase.monad}
+ [parameters (directive.lift-analysis
+ (typeA.with-env
+ (jvm.parameter-types parameters)))
+ #let [mapping (list\fold (function (_ [parameterJ parameterT] mapping)
+ (dictionary.put (parser.name parameterJ) parameterT mapping))
+ luxT.fresh
+ parameters)]
+ super-classT (directive.lift-analysis
+ (typeA.with-env
+ (luxT.check (luxT.class mapping) (..signature super-class))))
+ super-interfaceT+ (directive.lift-analysis
+ (typeA.with-env
+ (monad.map check.monad
+ (|>> ..signature (luxT.check (luxT.class mapping)))
+ super-interfaces)))
+ #let [selfT (jvm.inheritance-relationship-type (#.Primitive name (list\map product.right parameters))
+ super-classT
+ super-interfaceT+)]
+ state (extension.lift phase.get-state)
+ #let [analyse (get@ [#directive.analysis #directive.phase] state)
+ synthesize (get@ [#directive.synthesis #directive.phase] state)
+ generate (get@ [#directive.generation #directive.phase] state)]
+ methods (monad.map ! (..method-definition [mapping selfT] [analyse synthesize generate])
+ methods)
+ ## _ (directive.lift-generation
+ ## (generation.save! true ["" name]
+ ## [name
+ ## (class.class version.v6_0
+ ## (modifier\compose class.public inheritance)
+ ## (name.internal name) (list\map (|>> product.left parser.name ..constraint) parameters)
+ ## super-class super-interfaces
+ ## (list\map ..field-definition fields)
+ ## (list) ## TODO: Add methods
+ ## (row.row))]))
+ _ (directive.lift-generation
+ (generation.log! (format "Class " name)))]
+ (wrap directive.no-requirements)))]))
+
+(def: #export bundle
+ (Bundle Anchor (Bytecode Any) Definition)
+ (<| (bundle.prefix "jvm")
+ (|> bundle.empty
+ ## TODO: Finish handling methods and un-comment.
+ ## (dictionary.put "class" jvm::class)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
new file mode 100644
index 000000000..dc8272030
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
@@ -0,0 +1,451 @@
+(.module:
+ [library
+ [lux #*
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ [io (#+ IO)]
+ ["." try]
+ ["." exception (#+ exception:)]
+ ["p" parser
+ ["s" code (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary]]]
+ [macro
+ ["." code]]
+ [math
+ [number
+ ["n" nat]]]
+ ["." type (#+ :share)
+ ["." check]]]]
+ ["." /// (#+ Extender)
+ ["#." bundle]
+ ["#." analysis]
+ ["/#" // #_
+ [analysis
+ ["." module]
+ [".A" type]]
+ ["/#" // #_
+ ["#." analysis
+ [macro (#+ Expander)]
+ ["#/." evaluation]]
+ ["#." synthesis (#+ Synthesis)]
+ ["#." generation (#+ Context)]
+ ["#." directive (#+ Import Requirements Phase Operation Handler Bundle)]
+ ["#." program (#+ Program)]
+ [///
+ ["." phase]
+ [meta
+ ["." archive (#+ Archive)]]]]]])
+
+(def: #export (custom [syntax handler])
+ (All [anchor expression directive s]
+ (-> [(Parser s)
+ (-> Text
+ (Phase anchor expression directive)
+ Archive
+ s
+ (Operation anchor expression directive Requirements))]
+ (Handler anchor expression directive)))
+ (function (_ extension_name phase archive inputs)
+ (case (s.run syntax inputs)
+ (#try.Success inputs)
+ (handler extension_name phase archive inputs)
+
+ (#try.Failure error)
+ (phase.throw ///.invalid_syntax [extension_name %.code inputs]))))
+
+(def: (context [module_id artifact_id])
+ (-> Context Context)
+ ## TODO: Find a better way that doesn't rely on clever tricks.
+ [module_id (n.- (inc artifact_id) 0)])
+
+## TODO: Inline "evaluate!'" into "evaluate!" ASAP
+(def: (evaluate!' archive generate code//type codeS)
+ (All [anchor expression directive]
+ (-> Archive
+ (/////generation.Phase anchor expression directive)
+ Type
+ Synthesis
+ (Operation anchor expression directive [Type expression Any])))
+ (/////directive.lift_generation
+ (do phase.monad
+ [module /////generation.module
+ id /////generation.next
+ codeG (generate archive codeS)
+ module_id (/////generation.module_id module archive)
+ codeV (/////generation.evaluate! (..context [module_id id]) codeG)]
+ (wrap [code//type codeG codeV]))))
+
+(def: #export (evaluate! archive type codeC)
+ (All [anchor expression directive]
+ (-> Archive Type Code (Operation anchor expression directive [Type expression Any])))
+ (do phase.monad
+ [state (///.lift phase.get_state)
+ #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state)
+ synthesize (get@ [#/////directive.synthesis #/////directive.phase] state)
+ generate (get@ [#/////directive.generation #/////directive.phase] state)]
+ [_ codeA] (/////directive.lift_analysis
+ (/////analysis.with_scope
+ (typeA.with_fresh_env
+ (typeA.with_type type
+ (analyse archive codeC)))))
+ codeS (/////directive.lift_synthesis
+ (synthesize archive codeA))]
+ (evaluate!' archive generate type codeS)))
+
+## TODO: Inline "definition'" into "definition" ASAP
+(def: (definition' archive generate [module name] code//type codeS)
+ (All [anchor expression directive]
+ (-> Archive
+ (/////generation.Phase anchor expression directive)
+ Name
+ Type
+ Synthesis
+ (Operation anchor expression directive [Type expression Any])))
+ (/////directive.lift_generation
+ (do phase.monad
+ [codeG (generate archive codeS)
+ id (/////generation.learn name)
+ module_id (phase.lift (archive.id module archive))
+ [target_name value directive] (/////generation.define! [module_id id] codeG)
+ _ (/////generation.save! id directive)]
+ (wrap [code//type codeG value]))))
+
+(def: (definition archive name expected codeC)
+ (All [anchor expression directive]
+ (-> Archive Name (Maybe Type) Code
+ (Operation anchor expression directive [Type expression Any])))
+ (do {! phase.monad}
+ [state (///.lift phase.get_state)
+ #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state)
+ synthesize (get@ [#/////directive.synthesis #/////directive.phase] state)
+ generate (get@ [#/////directive.generation #/////directive.phase] state)]
+ [_ code//type codeA] (/////directive.lift_analysis
+ (/////analysis.with_scope
+ (typeA.with_fresh_env
+ (case expected
+ #.None
+ (do !
+ [[code//type codeA] (typeA.with_inference
+ (analyse archive codeC))
+ code//type (typeA.with_env
+ (check.clean code//type))]
+ (wrap [code//type codeA]))
+
+ (#.Some expected)
+ (do !
+ [codeA (typeA.with_type expected
+ (analyse archive codeC))]
+ (wrap [expected codeA]))))))
+ codeS (/////directive.lift_synthesis
+ (synthesize archive codeA))]
+ (definition' archive generate name code//type codeS)))
+
+(template [<full> <partial> <learn>]
+ [## TODO: Inline "<partial>" into "<full>" ASAP
+ (def: (<partial> archive generate extension codeT codeS)
+ (All [anchor expression directive]
+ (-> Archive
+ (/////generation.Phase anchor expression directive)
+ Text
+ Type
+ Synthesis
+ (Operation anchor expression directive [expression Any])))
+ (do phase.monad
+ [current_module (/////directive.lift_analysis
+ (///.lift meta.current_module_name))]
+ (/////directive.lift_generation
+ (do phase.monad
+ [codeG (generate archive codeS)
+ module_id (phase.lift (archive.id current_module archive))
+ id (<learn> extension)
+ [target_name value directive] (/////generation.define! [module_id id] codeG)
+ _ (/////generation.save! id directive)]
+ (wrap [codeG value])))))
+
+ (def: #export (<full> archive extension codeT codeC)
+ (All [anchor expression directive]
+ (-> Archive Text Type Code
+ (Operation anchor expression directive [expression Any])))
+ (do phase.monad
+ [state (///.lift phase.get_state)
+ #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state)
+ synthesize (get@ [#/////directive.synthesis #/////directive.phase] state)
+ generate (get@ [#/////directive.generation #/////directive.phase] state)]
+ [_ codeA] (/////directive.lift_analysis
+ (/////analysis.with_scope
+ (typeA.with_fresh_env
+ (typeA.with_type codeT
+ (analyse archive codeC)))))
+ codeS (/////directive.lift_synthesis
+ (synthesize archive codeA))]
+ (<partial> archive generate extension codeT codeS)))]
+
+ [analyser analyser' /////generation.learn_analyser]
+ [synthesizer synthesizer' /////generation.learn_synthesizer]
+ [generator generator' /////generation.learn_generator]
+ [directive directive' /////generation.learn_directive]
+ )
+
+(def: (refresh expander host_analysis)
+ (All [anchor expression directive]
+ (-> Expander /////analysis.Bundle (Operation anchor expression directive Any)))
+ (do phase.monad
+ [[bundle state] phase.get_state
+ #let [eval (/////analysis/evaluation.evaluator expander
+ (get@ [#/////directive.synthesis #/////directive.state] state)
+ (get@ [#/////directive.generation #/////directive.state] state)
+ (get@ [#/////directive.generation #/////directive.phase] state))]]
+ (phase.set_state [bundle
+ (update@ [#/////directive.analysis #/////directive.state]
+ (: (-> /////analysis.State+ /////analysis.State+)
+ (|>> product.right
+ [(///analysis.bundle eval host_analysis)]))
+ state)])))
+
+(def: (announce_definition! short type)
+ (All [anchor expression directive]
+ (-> Text Type (Operation anchor expression directive Any)))
+ (/////directive.lift_generation
+ (/////generation.log! (format short " : " (%.type type)))))
+
+(def: (lux::def expander host_analysis)
+ (-> Expander /////analysis.Bundle Handler)
+ (function (_ extension_name phase archive inputsC+)
+ (case inputsC+
+ (^ (list [_ (#.Identifier ["" short_name])] valueC annotationsC [_ (#.Bit exported?)]))
+ (do phase.monad
+ [current_module (/////directive.lift_analysis
+ (///.lift meta.current_module_name))
+ #let [full_name [current_module short_name]]
+ [type valueT value] (..definition archive full_name #.None valueC)
+ [_ annotationsT annotations] (evaluate! archive Code annotationsC)
+ _ (/////directive.lift_analysis
+ (module.define short_name (#.Right [exported? type (:as Code annotations) value])))
+ _ (..refresh expander host_analysis)
+ _ (..announce_definition! short_name type)]
+ (wrap /////directive.no_requirements))
+
+ _
+ (phase.throw ///.invalid_syntax [extension_name %.code inputsC+]))))
+
+(def: (def::type_tagged expander host_analysis)
+ (-> Expander /////analysis.Bundle Handler)
+ (..custom
+ [($_ p.and s.local_identifier s.any s.any (s.tuple (p.some s.text)) s.bit)
+ (function (_ extension_name phase archive [short_name valueC annotationsC tags exported?])
+ (do phase.monad
+ [current_module (/////directive.lift_analysis
+ (///.lift meta.current_module_name))
+ #let [full_name [current_module short_name]]
+ [_ annotationsT annotations] (evaluate! archive Code annotationsC)
+ #let [annotations (:as Code annotations)]
+ [type valueT value] (..definition archive full_name (#.Some .Type) valueC)
+ _ (/////directive.lift_analysis
+ (do phase.monad
+ [_ (module.define short_name (#.Right [exported? type annotations value]))]
+ (module.declare_tags tags exported? (:as Type value))))
+ _ (..refresh expander host_analysis)
+ _ (..announce_definition! short_name type)]
+ (wrap /////directive.no_requirements)))]))
+
+(def: imports
+ (Parser (List Import))
+ (|> (s.tuple (p.and s.text s.text))
+ p.some
+ s.tuple))
+
+(def: def::module
+ Handler
+ (..custom
+ [($_ p.and s.any ..imports)
+ (function (_ extension_name phase archive [annotationsC imports])
+ (do {! phase.monad}
+ [[_ annotationsT annotationsV] (evaluate! archive Code annotationsC)
+ #let [annotationsV (:as Code annotationsV)]
+ _ (/////directive.lift_analysis
+ (do !
+ [_ (monad.map ! (function (_ [module alias])
+ (do !
+ [_ (module.import module)]
+ (case alias
+ "" (wrap [])
+ _ (module.alias alias module))))
+ imports)]
+ (module.set_annotations annotationsV)))]
+ (wrap {#/////directive.imports imports
+ #/////directive.referrals (list)})))]))
+
+(exception: #export (cannot_alias_an_alias {local Alias} {foreign Alias} {target Name})
+ (exception.report
+ ["Local alias" (%.name local)]
+ ["Foreign alias" (%.name foreign)]
+ ["Target definition" (%.name target)]))
+
+(def: (define_alias alias original)
+ (-> Text Name (/////analysis.Operation Any))
+ (do phase.monad
+ [current_module (///.lift meta.current_module_name)
+ constant (///.lift (meta.find_def original))]
+ (case constant
+ (#.Left de_aliased)
+ (phase.throw ..cannot_alias_an_alias [[current_module alias] original de_aliased])
+
+ (#.Right [exported? original_type original_annotations original_value])
+ (module.define alias (#.Left original)))))
+
+(def: def::alias
+ Handler
+ (..custom
+ [($_ p.and s.local_identifier s.identifier)
+ (function (_ extension_name phase archive [alias def_name])
+ (do phase.monad
+ [_ (///.lift
+ (phase.sub [(get@ [#/////directive.analysis #/////directive.state])
+ (set@ [#/////directive.analysis #/////directive.state])]
+ (define_alias alias def_name)))]
+ (wrap /////directive.no_requirements)))]))
+
+(template [<description> <mame> <def_type> <type> <scope> <definer>]
+ [(def: (<mame> [anchorT expressionT directiveT] extender)
+ (All [anchor expression directive]
+ (-> [Type Type Type] Extender
+ (Handler anchor expression directive)))
+ (function (handler extension_name phase archive inputsC+)
+ (case inputsC+
+ (^ (list nameC valueC))
+ (do phase.monad
+ [[_ _ name] (evaluate! archive Text nameC)
+ [_ handlerV] (<definer> archive (:as Text name)
+ (type <def_type>)
+ valueC)
+ _ (<| <scope>
+ (///.install extender (:as Text name))
+ (:share [anchor expression directive]
+ (Handler anchor expression directive)
+ handler
+
+ <type>
+ (:assume handlerV)))
+ _ (/////directive.lift_generation
+ (/////generation.log! (format <description> " " (%.text (:as Text name)))))]
+ (wrap /////directive.no_requirements))
+
+ _
+ (phase.throw ///.invalid_syntax [extension_name %.code inputsC+]))))]
+
+ ["Analysis"
+ def::analysis
+ /////analysis.Handler /////analysis.Handler
+ /////directive.lift_analysis
+ ..analyser]
+ ["Synthesis"
+ def::synthesis
+ /////synthesis.Handler /////synthesis.Handler
+ /////directive.lift_synthesis
+ ..synthesizer]
+ ["Generation"
+ def::generation
+ (/////generation.Handler anchorT expressionT directiveT) (/////generation.Handler anchor expression directive)
+ /////directive.lift_generation
+ ..generator]
+ ["Directive"
+ def::directive
+ (/////directive.Handler anchorT expressionT directiveT) (/////directive.Handler anchor expression directive)
+ (<|)
+ ..directive]
+ )
+
+## TODO; Both "prepare-program" and "define-program" exist only
+## because the old compiler couldn't handle a fully-inlined definition
+## for "def::program". Inline them ASAP.
+(def: (prepare_program archive analyse synthesize programC)
+ (All [anchor expression directive output]
+ (-> Archive
+ /////analysis.Phase
+ /////synthesis.Phase
+ Code
+ (Operation anchor expression directive Synthesis)))
+ (do phase.monad
+ [[_ programA] (/////directive.lift_analysis
+ (/////analysis.with_scope
+ (typeA.with_fresh_env
+ (typeA.with_type (type (-> (List Text) (IO Any)))
+ (analyse archive programC)))))]
+ (/////directive.lift_synthesis
+ (synthesize archive programA))))
+
+(def: (define_program archive module_id generate program programS)
+ (All [anchor expression directive output]
+ (-> Archive
+ archive.ID
+ (/////generation.Phase anchor expression directive)
+ (Program expression directive)
+ Synthesis
+ (/////generation.Operation anchor expression directive Any)))
+ (do phase.monad
+ [programG (generate archive programS)
+ artifact_id (/////generation.learn /////program.name)]
+ (/////generation.save! artifact_id (program [module_id artifact_id] programG))))
+
+(def: (def::program program)
+ (All [anchor expression directive]
+ (-> (Program expression directive) (Handler anchor expression directive)))
+ (function (handler extension_name phase archive inputsC+)
+ (case inputsC+
+ (^ (list programC))
+ (do phase.monad
+ [state (///.lift phase.get_state)
+ #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state)
+ synthesize (get@ [#/////directive.synthesis #/////directive.phase] state)
+ generate (get@ [#/////directive.generation #/////directive.phase] state)]
+ programS (prepare_program archive analyse synthesize programC)
+ current_module (/////directive.lift_analysis
+ (///.lift meta.current_module_name))
+ module_id (phase.lift (archive.id current_module archive))
+ _ (/////directive.lift_generation
+ (define_program archive module_id generate program programS))]
+ (wrap /////directive.no_requirements))
+
+ _
+ (phase.throw ///.invalid_syntax [extension_name %.code inputsC+]))))
+
+(def: (bundle::def expander host_analysis program anchorT,expressionT,directiveT extender)
+ (All [anchor expression directive]
+ (-> Expander
+ /////analysis.Bundle
+ (Program expression directive)
+ [Type Type Type]
+ Extender
+ (Bundle anchor expression directive)))
+ (<| (///bundle.prefix "def")
+ (|> ///bundle.empty
+ (dictionary.put "module" def::module)
+ (dictionary.put "alias" def::alias)
+ (dictionary.put "type tagged" (def::type_tagged expander host_analysis))
+ (dictionary.put "analysis" (def::analysis anchorT,expressionT,directiveT extender))
+ (dictionary.put "synthesis" (def::synthesis anchorT,expressionT,directiveT extender))
+ (dictionary.put "generation" (def::generation anchorT,expressionT,directiveT extender))
+ (dictionary.put "directive" (def::directive anchorT,expressionT,directiveT extender))
+ (dictionary.put "program" (def::program program))
+ )))
+
+(def: #export (bundle expander host_analysis program anchorT,expressionT,directiveT extender)
+ (All [anchor expression directive]
+ (-> Expander
+ /////analysis.Bundle
+ (Program expression directive)
+ [Type Type Type]
+ Extender
+ (Bundle anchor expression directive)))
+ (<| (///bundle.prefix "lux")
+ (|> ///bundle.empty
+ (dictionary.put "def" (lux::def expander host_analysis))
+ (dictionary.merge (..bundle::def expander host_analysis program anchorT,expressionT,directiveT extender)))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux
new file mode 100644
index 000000000..f42aa31ff
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux
@@ -0,0 +1,18 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]]
+ ["." / #_
+ ["#." common]
+ ["#." host]
+ [////
+ [generation
+ [common_lisp
+ [runtime (#+ Bundle)]]]]])
+
+(def: #export bundle
+ Bundle
+ (dictionary.merge /common.bundle
+ /host.bundle))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux
new file mode 100644
index 000000000..7f911e3b3
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux
@@ -0,0 +1,180 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary]
+ ["." set]
+ ["." list ("#\." functor fold)]]]
+ [math
+ [number
+ ["f" frac]]]
+ ["@" target
+ ["_" common_lisp (#+ Expression)]]]]
+ ["." //// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["." reference]
+ ["//" common_lisp #_
+ ["#." runtime (#+ Operation Phase Handler Bundle Generator)]
+ ["#." case]]]
+ [//
+ ["." synthesis (#+ %synthesis)]
+ ["." generation]
+ [///
+ ["#" phase]]]]])
+
+(def: #export (custom [parser handler])
+ (All [s]
+ (-> [(Parser s)
+ (-> Text (Generator s))]
+ Handler))
+ (function (_ extension_name phase archive input)
+ (case (<s>.run parser input)
+ (#try.Success input')
+ (handler extension_name phase archive input')
+
+ (#try.Failure error)
+ (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
+
+(template: (!unary function)
+ (|>> list _.apply/* (|> (_.constant function))))
+
+## ## TODO: Get rid of this ASAP
+## (def: lux::syntax_char_case!
+## (..custom [($_ <>.and
+## <s>.any
+## <s>.any
+## (<>.some (<s>.tuple ($_ <>.and
+## (<s>.tuple (<>.many <s>.i64))
+## <s>.any))))
+## (function (_ extension_name phase archive [input else conditionals])
+## (do {! /////.monad}
+## [@input (\ ! map _.var (generation.gensym "input"))
+## inputG (phase archive input)
+## elseG (phase archive else)
+## conditionalsG (: (Operation (List [Expression Expression]))
+## (monad.map ! (function (_ [chars branch])
+## (do !
+## [branchG (phase archive branch)]
+## (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or)
+## branchG])))
+## conditionals))]
+## (wrap (_.let (list [@input inputG])
+## (list (list\fold (function (_ [test then] else)
+## (_.if test then else))
+## elseG
+## conditionalsG))))))]))
+
+(def: lux_procs
+ Bundle
+ (|> /.empty
+ ## (/.install "syntax char case!" lux::syntax_char_case!)
+ (/.install "is" (binary _.eq/2))
+ ## (/.install "try" (unary //runtime.lux//try))
+ ))
+
+## (def: (capped operation parameter subject)
+## (-> (-> Expression Expression Expression)
+## (-> Expression Expression Expression))
+## (//runtime.i64//64 (operation parameter subject)))
+
+(def: i64_procs
+ Bundle
+ (<| (/.prefix "i64")
+ (|> /.empty
+ (/.install "and" (binary _.logand/2))
+ (/.install "or" (binary _.logior/2))
+ (/.install "xor" (binary _.logxor/2))
+ (/.install "left-shift" (binary _.ash/2))
+ (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift)))
+ (/.install "=" (binary _.=/2))
+ (/.install "<" (binary _.</2))
+ (/.install "+" (binary _.+/2))
+ (/.install "-" (binary _.-/2))
+ (/.install "*" (binary _.*/2))
+ (/.install "/" (binary _.floor/2))
+ (/.install "%" (binary _.rem/2))
+ ## (/.install "f64" (unary (_.//2 (_.float +1.0))))
+ (/.install "char" (unary (|>> _.code-char/1 _.string/1)))
+ )))
+
+(def: f64_procs
+ Bundle
+ (<| (/.prefix "f64")
+ (|> /.empty
+ ## (/.install "=" (binary (product.uncurry _.=/2)))
+ ## (/.install "<" (binary (product.uncurry _.</2)))
+ ## (/.install "+" (binary (product.uncurry _.+/2)))
+ ## (/.install "-" (binary (product.uncurry _.-/2)))
+ ## (/.install "*" (binary (product.uncurry _.*/2)))
+ ## (/.install "/" (binary (product.uncurry _.//2)))
+ ## (/.install "%" (binary (product.uncurry _.rem/2)))
+ ## (/.install "i64" (unary _.truncate/1))
+ (/.install "encode" (unary _.write-to-string/1))
+ ## (/.install "decode" (unary //runtime.f64//decode))
+ )))
+
+(def: (text//index [offset sub text])
+ (Trinary (Expression Any))
+ (//runtime.text//index offset sub text))
+
+(def: (text//clip [offset length text])
+ (Trinary (Expression Any))
+ (//runtime.text//clip offset length text))
+
+(def: (text//char [index text])
+ (Binary (Expression Any))
+ (_.char-code/1 (_.char/2 [text index])))
+
+(def: text_procs
+ Bundle
+ (<| (/.prefix "text")
+ (|> /.empty
+ (/.install "=" (binary _.string=/2))
+ ## (/.install "<" (binary (product.uncurry _.string<?/2)))
+ (/.install "concat" (binary (function (_ [left right])
+ (_.concatenate/3 [(_.symbol "string") left right]))))
+ (/.install "index" (trinary ..text//index))
+ (/.install "size" (unary _.length/1))
+ (/.install "char" (binary ..text//char))
+ (/.install "clip" (trinary ..text//clip))
+ )))
+
+(def: (io//log! message)
+ (Unary (Expression Any))
+ (_.progn (list (_.write-line/1 message)
+ //runtime.unit)))
+
+(def: io_procs
+ Bundle
+ (<| (/.prefix "io")
+ (|> /.empty
+ (/.install "log" (unary ..io//log!))
+ (/.install "error" (unary _.error/1))
+ )))
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "lux")
+ (|> /.empty
+ (dictionary.merge lux_procs)
+ (dictionary.merge i64_procs)
+ (dictionary.merge f64_procs)
+ (dictionary.merge text_procs)
+ (dictionary.merge io_procs)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux
new file mode 100644
index 000000000..9895f051a
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux
@@ -0,0 +1,40 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ [collection
+ ["." dictionary]
+ ["." list]]
+ [text
+ ["%" format (#+ format)]]]
+ [target
+ ["_" common_lisp (#+ Var Expression)]]]]
+ ["." // #_
+ ["#." common (#+ custom)]
+ ["//#" /// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["." reference]
+ ["//" common_lisp #_
+ ["#." runtime (#+ Operation Phase Handler Bundle
+ with_vars)]]]
+ ["/#" // #_
+ ["." generation]
+ ["//#" /// #_
+ ["#." phase]]]]]])
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "common_lisp")
+ (|> /.empty
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js.lux
new file mode 100644
index 000000000..ba83e257f
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js.lux
@@ -0,0 +1,18 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]]
+ ["." / #_
+ ["#." common]
+ ["#." host]
+ [////
+ [generation
+ [js
+ [runtime (#+ Bundle)]]]]])
+
+(def: #export bundle
+ Bundle
+ (dictionary.merge /common.bundle
+ /host.bundle))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux
new file mode 100644
index 000000000..a74c72d38
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux
@@ -0,0 +1,191 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ [collection
+ ["." list ("#\." functor)]
+ ["." dictionary]]]
+ [math
+ [number
+ ["f" frac]]]
+ ["@" target
+ ["_" js (#+ Literal Expression Statement)]]]]
+ ["." //// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["//" js #_
+ ["#." runtime (#+ Operation Phase Handler Bundle Generator)]
+ ["#." primitive]]]
+ [//
+ [synthesis (#+ %synthesis)]
+ [///
+ ["#" phase]]]]])
+
+(def: #export (custom [parser handler])
+ (All [s]
+ (-> [(Parser s)
+ (-> Text (Generator s))]
+ Handler))
+ (function (_ extension_name phase archive input)
+ (case (<s>.run parser input)
+ (#try.Success input')
+ (handler extension_name phase archive input')
+
+ (#try.Failure error)
+ (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
+
+## [Procedures]
+## [[Bits]]
+(template [<name> <op>]
+ [(def: (<name> [paramG subjectG])
+ (Binary Expression)
+ (<op> subjectG (//runtime.i64//to_number paramG)))]
+
+ [i64//left_shift //runtime.i64//left_shift]
+ [i64//right_shift //runtime.i64//right_shift]
+ )
+
+## [[Numbers]]
+(def: f64//decode
+ (Unary Expression)
+ (|>> list
+ (_.apply/* (_.var "parseFloat"))
+ _.return
+ (_.closure (list))
+ //runtime.lux//try))
+
+(def: i64//char
+ (Unary Expression)
+ (|>> //runtime.i64//to_number
+ (list)
+ (_.apply/* (_.var "String.fromCharCode"))))
+
+## [[Text]]
+(def: (text//concat [leftG rightG])
+ (Binary Expression)
+ (|> leftG (_.do "concat" (list rightG))))
+
+(def: (text//clip [startG endG subjectG])
+ (Trinary Expression)
+ (//runtime.text//clip startG endG subjectG))
+
+(def: (text//index [startG partG subjectG])
+ (Trinary Expression)
+ (//runtime.text//index startG partG subjectG))
+
+## [[IO]]
+(def: (io//log messageG)
+ (Unary Expression)
+ ($_ _.,
+ (//runtime.io//log messageG)
+ //runtime.unit))
+
+## TODO: Get rid of this ASAP
+(def: lux::syntax_char_case!
+ (..custom [($_ <>.and
+ <s>.any
+ <s>.any
+ (<>.some (<s>.tuple ($_ <>.and
+ (<s>.tuple (<>.many <s>.i64))
+ <s>.any))))
+ (function (_ extension_name phase archive [input else conditionals])
+ (do {! /////.monad}
+ [inputG (phase archive input)
+ elseG (phase archive else)
+ conditionalsG (: (Operation (List [(List Literal)
+ Statement]))
+ (monad.map ! (function (_ [chars branch])
+ (do !
+ [branchG (phase archive branch)]
+ (wrap [(list\map (|>> .int _.int) chars)
+ (_.return branchG)])))
+ conditionals))]
+ (wrap (_.apply/* (_.closure (list)
+ (_.switch (_.the //runtime.i64_low_field inputG)
+ conditionalsG
+ (#.Some (_.return elseG))))
+ (list)))))]))
+
+## [Bundles]
+(def: lux_procs
+ Bundle
+ (|> /.empty
+ (/.install "syntax char case!" lux::syntax_char_case!)
+ (/.install "is" (binary (product.uncurry _.=)))
+ (/.install "try" (unary //runtime.lux//try))))
+
+(def: i64_procs
+ Bundle
+ (<| (/.prefix "i64")
+ (|> /.empty
+ (/.install "and" (binary (product.uncurry //runtime.i64//and)))
+ (/.install "or" (binary (product.uncurry //runtime.i64//or)))
+ (/.install "xor" (binary (product.uncurry //runtime.i64//xor)))
+ (/.install "left-shift" (binary i64//left_shift))
+ (/.install "right-shift" (binary i64//right_shift))
+ (/.install "=" (binary (product.uncurry //runtime.i64//=)))
+ (/.install "<" (binary (product.uncurry //runtime.i64//<)))
+ (/.install "+" (binary (product.uncurry //runtime.i64//+)))
+ (/.install "-" (binary (product.uncurry //runtime.i64//-)))
+ (/.install "*" (binary (product.uncurry //runtime.i64//*)))
+ (/.install "/" (binary (product.uncurry //runtime.i64///)))
+ (/.install "%" (binary (product.uncurry //runtime.i64//%)))
+ (/.install "f64" (unary //runtime.i64//to_number))
+ (/.install "char" (unary i64//char))
+ )))
+
+(def: f64_procs
+ Bundle
+ (<| (/.prefix "f64")
+ (|> /.empty
+ (/.install "+" (binary (product.uncurry _.+)))
+ (/.install "-" (binary (product.uncurry _.-)))
+ (/.install "*" (binary (product.uncurry _.*)))
+ (/.install "/" (binary (product.uncurry _./)))
+ (/.install "%" (binary (product.uncurry _.%)))
+ (/.install "=" (binary (product.uncurry _.=)))
+ (/.install "<" (binary (product.uncurry _.<)))
+ (/.install "i64" (unary //runtime.i64//from_number))
+ (/.install "encode" (unary (_.do "toString" (list))))
+ (/.install "decode" (unary f64//decode)))))
+
+(def: text_procs
+ Bundle
+ (<| (/.prefix "text")
+ (|> /.empty
+ (/.install "=" (binary (product.uncurry _.=)))
+ (/.install "<" (binary (product.uncurry _.<)))
+ (/.install "concat" (binary text//concat))
+ (/.install "index" (trinary text//index))
+ (/.install "size" (unary (|>> (_.the "length") //runtime.i64//from_number)))
+ (/.install "char" (binary (product.uncurry //runtime.text//char)))
+ (/.install "clip" (trinary text//clip))
+ )))
+
+(def: io_procs
+ Bundle
+ (<| (/.prefix "io")
+ (|> /.empty
+ (/.install "log" (unary io//log))
+ (/.install "error" (unary //runtime.io//error)))))
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "lux")
+ (|> lux_procs
+ (dictionary.merge i64_procs)
+ (dictionary.merge f64_procs)
+ (dictionary.merge text_procs)
+ (dictionary.merge io_procs)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux
new file mode 100644
index 000000000..edc4e2321
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux
@@ -0,0 +1,160 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ [collection
+ ["." dictionary]
+ ["." list]]]
+ [target
+ ["_" js (#+ Var Expression)]]]]
+ ["." // #_
+ ["#." common (#+ custom)]
+ ["//#" /// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["//" js #_
+ ["#." runtime (#+ Operation Phase Handler Bundle
+ with_vars)]]]
+ ["/#" // #_
+ ["." generation]
+ ["//#" /// #_
+ ["#." phase]]]]]])
+
+(def: array::new
+ (Unary Expression)
+ (|>> (_.the //runtime.i64_low_field) list (_.new (_.var "Array"))))
+
+(def: array::length
+ (Unary Expression)
+ (|>> (_.the "length") //runtime.i64//from_number))
+
+(def: (array::read [indexG arrayG])
+ (Binary Expression)
+ (_.at (_.the //runtime.i64_low_field indexG)
+ arrayG))
+
+(def: (array::write [indexG valueG arrayG])
+ (Trinary Expression)
+ (//runtime.array//write indexG valueG arrayG))
+
+(def: (array::delete [indexG arrayG])
+ (Binary Expression)
+ (//runtime.array//delete indexG arrayG))
+
+(def: array
+ Bundle
+ (<| (/.prefix "array")
+ (|> /.empty
+ (/.install "new" (unary array::new))
+ (/.install "length" (unary array::length))
+ (/.install "read" (binary array::read))
+ (/.install "write" (trinary array::write))
+ (/.install "delete" (binary array::delete))
+ )))
+
+(def: object::new
+ (custom
+ [($_ <>.and <s>.any (<>.some <s>.any))
+ (function (_ extension phase archive [constructorS inputsS])
+ (do {! ////////phase.monad}
+ [constructorG (phase archive constructorS)
+ inputsG (monad.map ! (phase archive) inputsS)]
+ (wrap (_.new constructorG inputsG))))]))
+
+(def: object::get
+ Handler
+ (custom
+ [($_ <>.and <s>.text <s>.any)
+ (function (_ extension phase archive [fieldS objectS])
+ (do ////////phase.monad
+ [objectG (phase archive objectS)]
+ (wrap (_.the fieldS objectG))))]))
+
+(def: object::do
+ Handler
+ (custom
+ [($_ <>.and <s>.text <s>.any (<>.some <s>.any))
+ (function (_ extension phase archive [methodS objectS inputsS])
+ (do {! ////////phase.monad}
+ [objectG (phase archive objectS)
+ inputsG (monad.map ! (phase archive) inputsS)]
+ (wrap (_.do methodS inputsG objectG))))]))
+
+(template [<!> <?> <unit>]
+ [(def: <!> (Nullary Expression) (function.constant <unit>))
+ (def: <?> (Unary Expression) (_.= <unit>))]
+
+ [object::null object::null? _.null]
+ [object::undefined object::undefined? _.undefined]
+ )
+
+(def: object
+ Bundle
+ (<| (/.prefix "object")
+ (|> /.empty
+ (/.install "new" object::new)
+ (/.install "get" object::get)
+ (/.install "do" object::do)
+ (/.install "null" (nullary object::null))
+ (/.install "null?" (unary object::null?))
+ (/.install "undefined" (nullary object::undefined))
+ (/.install "undefined?" (unary object::undefined?))
+ )))
+
+(def: js::constant
+ (custom
+ [<s>.text
+ (function (_ extension phase archive name)
+ (\ ////////phase.monad wrap (_.var name)))]))
+
+(def: js::apply
+ (custom
+ [($_ <>.and <s>.any (<>.some <s>.any))
+ (function (_ extension phase archive [abstractionS inputsS])
+ (do {! ////////phase.monad}
+ [abstractionG (phase archive abstractionS)
+ inputsG (monad.map ! (phase archive) inputsS)]
+ (wrap (_.apply/* abstractionG inputsG))))]))
+
+(def: js::function
+ (custom
+ [($_ <>.and <s>.i64 <s>.any)
+ (function (_ extension phase archive [arity abstractionS])
+ (do {! ////////phase.monad}
+ [abstractionG (phase archive abstractionS)
+ #let [variable (: (-> Text (Operation Var))
+ (|>> generation.gensym
+ (\ ! map _.var)))]
+ g!inputs (monad.map ! (function (_ _) (variable "input"))
+ (list.repeat (.nat arity) []))
+ g!abstraction (variable "abstraction")]
+ (wrap (_.closure g!inputs
+ ($_ _.then
+ (_.define g!abstraction abstractionG)
+ (_.return (case (.nat arity)
+ 0 (_.apply/1 g!abstraction //runtime.unit)
+ 1 (_.apply/* g!abstraction g!inputs)
+ _ (_.apply/1 g!abstraction (_.array g!inputs)))))))))]))
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "js")
+ (|> /.empty
+ (dictionary.merge ..array)
+ (dictionary.merge ..object)
+
+ (/.install "constant" js::constant)
+ (/.install "apply" js::apply)
+ (/.install "type-of" (unary _.type_of))
+ (/.install "function" js::function)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux
new file mode 100644
index 000000000..396c3284e
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux
@@ -0,0 +1,20 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]]
+ ["." / #_
+ ["#." common]
+ ["#." host]
+ [////
+ [generation
+ [jvm
+ [runtime (#+ Bundle)]]]]])
+
+(def: #export bundle
+ Bundle
+ ($_ dictionary.merge
+ /common.bundle
+ /host.bundle
+ ))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux
new file mode 100644
index 000000000..da55a6c32
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux
@@ -0,0 +1,414 @@
+(.module:
+ [library
+ [lux (#- Type)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ [number
+ ["." i32]
+ ["f" frac]]
+ [collection
+ ["." list ("#\." monad)]
+ ["." dictionary]]]
+ [target
+ [jvm
+ ["_" bytecode (#+ Label Bytecode) ("#\." monad)]
+ [encoding
+ ["." signed (#+ S4)]]
+ ["." type (#+ Type)
+ [category (#+ Primitive Class)]]]]]]
+ ["." ///// #_
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary Variadic
+ nullary unary binary trinary variadic)]
+ ["///" jvm #_
+ ["#." value]
+ ["#." runtime (#+ Operation Phase Bundle Handler)]
+ ["#." function #_
+ ["#" abstract]]]]
+ [extension
+ ["#extension" /]
+ ["#." bundle]]
+ [//
+ ["/#." synthesis (#+ Synthesis %synthesis)]
+ [///
+ ["#" phase]
+ [meta
+ [archive (#+ Archive)]]]]])
+
+(def: #export (custom [parser handler])
+ (All [s]
+ (-> [(Parser s)
+ (-> Text Phase Archive s (Operation (Bytecode Any)))]
+ Handler))
+ (function (_ extension-name phase archive input)
+ (case (<s>.run parser input)
+ (#try.Success input')
+ (handler extension-name phase archive input')
+
+ (#try.Failure error)
+ (/////.throw /////extension.invalid-syntax [extension-name //////synthesis.%synthesis input]))))
+
+(def: $Boolean (type.class "java.lang.Boolean" (list)))
+(def: $Double (type.class "java.lang.Double" (list)))
+(def: $Character (type.class "java.lang.Character" (list)))
+(def: $String (type.class "java.lang.String" (list)))
+(def: $CharSequence (type.class "java.lang.CharSequence" (list)))
+(def: $Object (type.class "java.lang.Object" (list)))
+(def: $PrintStream (type.class "java.io.PrintStream" (list)))
+(def: $System (type.class "java.lang.System" (list)))
+(def: $Error (type.class "java.lang.Error" (list)))
+
+(def: lux-int
+ (Bytecode Any)
+ ($_ _.compose
+ _.i2l
+ (///value.wrap type.long)))
+
+(def: jvm-int
+ (Bytecode Any)
+ ($_ _.compose
+ (///value.unwrap type.long)
+ _.l2i))
+
+(def: ensure-string
+ (Bytecode Any)
+ (_.checkcast $String))
+
+(def: (predicate bytecode)
+ (-> (-> Label (Bytecode Any))
+ (Bytecode Any))
+ (do _.monad
+ [@then _.new-label
+ @end _.new-label]
+ ($_ _.compose
+ (bytecode @then)
+ (_.getstatic $Boolean "FALSE" $Boolean)
+ (_.goto @end)
+ (_.set-label @then)
+ (_.getstatic $Boolean "TRUE" $Boolean)
+ (_.set-label @end)
+ )))
+
+## TODO: Get rid of this ASAP
+(def: lux::syntax-char-case!
+ (..custom [($_ <>.and
+ <s>.any
+ <s>.any
+ (<>.some (<s>.tuple ($_ <>.and
+ (<s>.tuple (<>.many <s>.i64))
+ <s>.any))))
+ (function (_ extension-name phase archive [inputS elseS conditionalsS])
+ (do {! /////.monad}
+ [@end ///runtime.forge-label
+ inputG (phase archive inputS)
+ elseG (phase archive elseS)
+ conditionalsG+ (: (Operation (List [(List [S4 Label])
+ (Bytecode Any)]))
+ (monad.map ! (function (_ [chars branch])
+ (do !
+ [branchG (phase archive branch)
+ @branch ///runtime.forge-label]
+ (wrap [(list\map (function (_ char)
+ [(try.assume (signed.s4 (.int char))) @branch])
+ chars)
+ ($_ _.compose
+ (_.set-label @branch)
+ branchG
+ (_.goto @end))])))
+ conditionalsS))
+ #let [table (|> conditionalsG+
+ (list\map product.left)
+ list\join)
+ conditionalsG (|> conditionalsG+
+ (list\map product.right)
+ (monad.seq _.monad))]]
+ (wrap (do _.monad
+ [@else _.new-label]
+ ($_ _.compose
+ inputG (///value.unwrap type.long) _.l2i
+ (_.lookupswitch @else table)
+ conditionalsG
+ (_.set-label @else)
+ elseG
+ (_.set-label @end)
+ )))))]))
+
+(def: (lux::is [referenceG sampleG])
+ (Binary (Bytecode Any))
+ ($_ _.compose
+ referenceG
+ sampleG
+ (..predicate _.if-acmpeq)))
+
+(def: (lux::try riskyG)
+ (Unary (Bytecode Any))
+ ($_ _.compose
+ riskyG
+ (_.checkcast ///function.class)
+ ///runtime.try))
+
+(def: bundle::lux
+ Bundle
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "syntax char case!" ..lux::syntax-char-case!)
+ (/////bundle.install "is" (binary ..lux::is))
+ (/////bundle.install "try" (unary ..lux::try))))
+
+(template [<name> <op>]
+ [(def: (<name> [maskG inputG])
+ (Binary (Bytecode Any))
+ ($_ _.compose
+ inputG (///value.unwrap type.long)
+ maskG (///value.unwrap type.long)
+ <op> (///value.wrap type.long)))]
+
+ [i64::and _.land]
+ [i64::or _.lor]
+ [i64::xor _.lxor]
+ )
+
+(template [<name> <op>]
+ [(def: (<name> [shiftG inputG])
+ (Binary (Bytecode Any))
+ ($_ _.compose
+ inputG (///value.unwrap type.long)
+ shiftG ..jvm-int
+ <op> (///value.wrap type.long)))]
+
+ [i64::left-shift _.lshl]
+ [i64::right-shift _.lushr]
+ )
+
+(template [<name> <type> <op>]
+ [(def: (<name> [paramG subjectG])
+ (Binary (Bytecode Any))
+ ($_ _.compose
+ subjectG (///value.unwrap <type>)
+ paramG (///value.unwrap <type>)
+ <op> (///value.wrap <type>)))]
+
+ [i64::+ type.long _.ladd]
+ [i64::- type.long _.lsub]
+ [i64::* type.long _.lmul]
+ [i64::/ type.long _.ldiv]
+ [i64::% type.long _.lrem]
+
+ [f64::+ type.double _.dadd]
+ [f64::- type.double _.dsub]
+ [f64::* type.double _.dmul]
+ [f64::/ type.double _.ddiv]
+ [f64::% type.double _.drem]
+ )
+
+(template [<eq> <lt> <type> <cmp>]
+ [(template [<name> <reference>]
+ [(def: (<name> [paramG subjectG])
+ (Binary (Bytecode Any))
+ ($_ _.compose
+ subjectG (///value.unwrap <type>)
+ paramG (///value.unwrap <type>)
+ <cmp>
+ <reference>
+ (..predicate _.if-icmpeq)))]
+
+ [<eq> _.iconst-0]
+ [<lt> _.iconst-m1])]
+
+ [i64::= i64::< type.long _.lcmp]
+ [f64::= f64::< type.double _.dcmpg]
+ )
+
+(def: (to-string class from)
+ (-> (Type Class) (Type Primitive) (Bytecode Any))
+ (_.invokestatic class "toString" (type.method [(list from) ..$String (list)])))
+
+(template [<name> <prepare> <transform>]
+ [(def: (<name> inputG)
+ (Unary (Bytecode Any))
+ ($_ _.compose
+ inputG
+ <prepare>
+ <transform>))]
+
+ [i64::f64
+ (///value.unwrap type.long)
+ ($_ _.compose
+ _.l2d
+ (///value.wrap type.double))]
+
+ [i64::char
+ (///value.unwrap type.long)
+ ($_ _.compose
+ _.l2i
+ _.i2c
+ (..to-string ..$Character type.char))]
+
+ [f64::i64
+ (///value.unwrap type.double)
+ ($_ _.compose
+ _.d2l
+ (///value.wrap type.long))]
+
+ [f64::encode
+ (///value.unwrap type.double)
+ (..to-string ..$Double type.double)]
+
+ [f64::decode
+ ..ensure-string
+ ///runtime.decode-frac]
+ )
+
+(def: bundle::i64
+ Bundle
+ (<| (/////bundle.prefix "i64")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "and" (binary ..i64::and))
+ (/////bundle.install "or" (binary ..i64::or))
+ (/////bundle.install "xor" (binary ..i64::xor))
+ (/////bundle.install "left-shift" (binary ..i64::left-shift))
+ (/////bundle.install "right-shift" (binary ..i64::right-shift))
+ (/////bundle.install "=" (binary ..i64::=))
+ (/////bundle.install "<" (binary ..i64::<))
+ (/////bundle.install "+" (binary ..i64::+))
+ (/////bundle.install "-" (binary ..i64::-))
+ (/////bundle.install "*" (binary ..i64::*))
+ (/////bundle.install "/" (binary ..i64::/))
+ (/////bundle.install "%" (binary ..i64::%))
+ (/////bundle.install "f64" (unary ..i64::f64))
+ (/////bundle.install "char" (unary ..i64::char)))))
+
+(def: bundle::f64
+ Bundle
+ (<| (/////bundle.prefix "f64")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "+" (binary ..f64::+))
+ (/////bundle.install "-" (binary ..f64::-))
+ (/////bundle.install "*" (binary ..f64::*))
+ (/////bundle.install "/" (binary ..f64::/))
+ (/////bundle.install "%" (binary ..f64::%))
+ (/////bundle.install "=" (binary ..f64::=))
+ (/////bundle.install "<" (binary ..f64::<))
+ (/////bundle.install "i64" (unary ..f64::i64))
+ (/////bundle.install "encode" (unary ..f64::encode))
+ (/////bundle.install "decode" (unary ..f64::decode)))))
+
+(def: (text::size inputG)
+ (Unary (Bytecode Any))
+ ($_ _.compose
+ inputG
+ ..ensure-string
+ (_.invokevirtual ..$String "length" (type.method [(list) type.int (list)]))
+ ..lux-int))
+
+(def: no-op (Bytecode Any) (_\wrap []))
+
+(template [<name> <pre-subject> <pre-param> <op> <post>]
+ [(def: (<name> [paramG subjectG])
+ (Binary (Bytecode Any))
+ ($_ _.compose
+ subjectG <pre-subject>
+ paramG <pre-param>
+ <op> <post>))]
+
+ [text::= ..no-op ..no-op
+ (_.invokevirtual ..$Object "equals" (type.method [(list ..$Object) type.boolean (list)]))
+ (///value.wrap type.boolean)]
+ [text::< ..ensure-string ..ensure-string
+ (_.invokevirtual ..$String "compareTo" (type.method [(list ..$String) type.int (list)]))
+ (..predicate _.iflt)]
+ [text::char ..ensure-string ..jvm-int
+ (_.invokevirtual ..$String "charAt" (type.method [(list type.int) type.char (list)]))
+ ..lux-int]
+ )
+
+(def: (text::concat [leftG rightG])
+ (Binary (Bytecode Any))
+ ($_ _.compose
+ leftG ..ensure-string
+ rightG ..ensure-string
+ (_.invokevirtual ..$String "concat" (type.method [(list ..$String) ..$String (list)]))))
+
+(def: (text::clip [startG endG subjectG])
+ (Trinary (Bytecode Any))
+ ($_ _.compose
+ subjectG ..ensure-string
+ startG ..jvm-int
+ endG ..jvm-int
+ (_.invokevirtual ..$String "substring" (type.method [(list type.int type.int) ..$String (list)]))))
+
+(def: index-method (type.method [(list ..$String type.int) type.int (list)]))
+(def: (text::index [startG partG textG])
+ (Trinary (Bytecode Any))
+ (do _.monad
+ [@not-found _.new-label
+ @end _.new-label]
+ ($_ _.compose
+ textG ..ensure-string
+ partG ..ensure-string
+ startG ..jvm-int
+ (_.invokevirtual ..$String "indexOf" index-method)
+ _.dup
+ _.iconst-m1
+ (_.if-icmpeq @not-found)
+ ..lux-int
+ ///runtime.some-injection
+ (_.goto @end)
+ (_.set-label @not-found)
+ _.pop
+ ///runtime.none-injection
+ (_.set-label @end))))
+
+(def: bundle::text
+ Bundle
+ (<| (/////bundle.prefix "text")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "=" (binary ..text::=))
+ (/////bundle.install "<" (binary ..text::<))
+ (/////bundle.install "concat" (binary ..text::concat))
+ (/////bundle.install "index" (trinary ..text::index))
+ (/////bundle.install "size" (unary ..text::size))
+ (/////bundle.install "char" (binary ..text::char))
+ (/////bundle.install "clip" (trinary ..text::clip)))))
+
+(def: string-method (type.method [(list ..$String) type.void (list)]))
+(def: (io::log messageG)
+ (Unary (Bytecode Any))
+ ($_ _.compose
+ (_.getstatic ..$System "out" ..$PrintStream)
+ messageG
+ ..ensure-string
+ (_.invokevirtual ..$PrintStream "println" ..string-method)
+ ///runtime.unit))
+
+(def: (io::error messageG)
+ (Unary (Bytecode Any))
+ ($_ _.compose
+ (_.new ..$Error)
+ _.dup
+ messageG
+ ..ensure-string
+ (_.invokespecial ..$Error "<init>" ..string-method)
+ _.athrow))
+
+(def: bundle::io
+ Bundle
+ (<| (/////bundle.prefix "io")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "log" (unary ..io::log))
+ (/////bundle.install "error" (unary ..io::error)))))
+
+(def: #export bundle
+ Bundle
+ (<| (/////bundle.prefix "lux")
+ (|> bundle::lux
+ (dictionary.merge ..bundle::i64)
+ (dictionary.merge ..bundle::f64)
+ (dictionary.merge ..bundle::text)
+ (dictionary.merge ..bundle::io))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
new file mode 100644
index 000000000..b46934a86
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
@@ -0,0 +1,1106 @@
+(.module:
+ [library
+ [lux (#- Type)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<t>" text]
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [number
+ ["." i32]]
+ [collection
+ ["." list ("#\." monad)]
+ ["." dictionary (#+ Dictionary)]
+ ["." set]
+ ["." row]]
+ ["." format #_
+ ["#" binary]]]
+ [target
+ [jvm
+ ["." version]
+ ["." modifier ("#\." monoid)]
+ ["." method (#+ Method)]
+ ["." class (#+ Class)]
+ [constant
+ [pool (#+ Resource)]]
+ [encoding
+ ["." name]]
+ ["_" bytecode (#+ Label Bytecode) ("#\." monad)
+ ["__" instruction (#+ Primitive-Array-Type)]]
+ ["." type (#+ Type Typed Argument)
+ ["." category (#+ Void Value' Value Return' Return Primitive Object Array Var Parameter)]
+ ["." box]
+ ["." reflection]
+ ["." signature]
+ ["." parser]]]]]]
+ ["." // #_
+ [common (#+ custom)]
+ ["///#" //// #_
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary Variadic
+ nullary unary binary trinary variadic)]
+ ["///" jvm
+ ["#." runtime (#+ Operation Bundle Phase Handler)]
+ ["#." reference]
+ [function
+ [field
+ [variable
+ ["." foreign]]]]]]
+ [extension
+ ["#." bundle]
+ [analysis
+ ["/" jvm]]]
+ ["/#" // #_
+ [analysis (#+ Environment)]
+ ["#." synthesis (#+ Synthesis Path %synthesis)]
+ ["#." generation]
+ [///
+ ["#" phase]
+ [reference
+ ["#." variable (#+ Variable)]]
+ [meta
+ ["." archive (#+ Archive)]]]]]])
+
+(template [<name> <0> <1>]
+ [(def: <name>
+ (Bytecode Any)
+ ($_ _.compose
+ <0>
+ <1>))]
+
+ [l2s _.l2i _.i2s]
+ [l2b _.l2i _.i2b]
+ [l2c _.l2i _.i2c]
+ )
+
+(template [<conversion> <name>]
+ [(def: (<name> inputG)
+ (Unary (Bytecode Any))
+ (if (is? _.nop <conversion>)
+ inputG
+ ($_ _.compose
+ inputG
+ <conversion>)))]
+
+ [_.d2f conversion::double-to-float]
+ [_.d2i conversion::double-to-int]
+ [_.d2l conversion::double-to-long]
+ [_.f2d conversion::float-to-double]
+ [_.f2i conversion::float-to-int]
+ [_.f2l conversion::float-to-long]
+ [_.i2b conversion::int-to-byte]
+ [_.i2c conversion::int-to-char]
+ [_.i2d conversion::int-to-double]
+ [_.i2f conversion::int-to-float]
+ [_.i2l conversion::int-to-long]
+ [_.i2s conversion::int-to-short]
+ [_.l2d conversion::long-to-double]
+ [_.l2f conversion::long-to-float]
+ [_.l2i conversion::long-to-int]
+ [..l2s conversion::long-to-short]
+ [..l2b conversion::long-to-byte]
+ [..l2c conversion::long-to-char]
+ [_.i2b conversion::char-to-byte]
+ [_.i2s conversion::char-to-short]
+ [_.nop conversion::char-to-int]
+ [_.i2l conversion::char-to-long]
+ [_.i2l conversion::byte-to-long]
+ [_.i2l conversion::short-to-long]
+ )
+
+(def: bundle::conversion
+ Bundle
+ (<| (/////bundle.prefix "conversion")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "double-to-float" (unary conversion::double-to-float))
+ (/////bundle.install "double-to-int" (unary conversion::double-to-int))
+ (/////bundle.install "double-to-long" (unary conversion::double-to-long))
+ (/////bundle.install "float-to-double" (unary conversion::float-to-double))
+ (/////bundle.install "float-to-int" (unary conversion::float-to-int))
+ (/////bundle.install "float-to-long" (unary conversion::float-to-long))
+ (/////bundle.install "int-to-byte" (unary conversion::int-to-byte))
+ (/////bundle.install "int-to-char" (unary conversion::int-to-char))
+ (/////bundle.install "int-to-double" (unary conversion::int-to-double))
+ (/////bundle.install "int-to-float" (unary conversion::int-to-float))
+ (/////bundle.install "int-to-long" (unary conversion::int-to-long))
+ (/////bundle.install "int-to-short" (unary conversion::int-to-short))
+ (/////bundle.install "long-to-double" (unary conversion::long-to-double))
+ (/////bundle.install "long-to-float" (unary conversion::long-to-float))
+ (/////bundle.install "long-to-int" (unary conversion::long-to-int))
+ (/////bundle.install "long-to-short" (unary conversion::long-to-short))
+ (/////bundle.install "long-to-byte" (unary conversion::long-to-byte))
+ (/////bundle.install "long-to-char" (unary conversion::long-to-char))
+ (/////bundle.install "char-to-byte" (unary conversion::char-to-byte))
+ (/////bundle.install "char-to-short" (unary conversion::char-to-short))
+ (/////bundle.install "char-to-int" (unary conversion::char-to-int))
+ (/////bundle.install "char-to-long" (unary conversion::char-to-long))
+ (/////bundle.install "byte-to-long" (unary conversion::byte-to-long))
+ (/////bundle.install "short-to-long" (unary conversion::short-to-long))
+ )))
+
+(template [<name> <op>]
+ [(def: (<name> [xG yG])
+ (Binary (Bytecode Any))
+ ($_ _.compose
+ xG
+ yG
+ <op>))]
+
+ [int::+ _.iadd]
+ [int::- _.isub]
+ [int::* _.imul]
+ [int::/ _.idiv]
+ [int::% _.irem]
+ [int::and _.iand]
+ [int::or _.ior]
+ [int::xor _.ixor]
+ [int::shl _.ishl]
+ [int::shr _.ishr]
+ [int::ushr _.iushr]
+
+ [long::+ _.ladd]
+ [long::- _.lsub]
+ [long::* _.lmul]
+ [long::/ _.ldiv]
+ [long::% _.lrem]
+ [long::and _.land]
+ [long::or _.lor]
+ [long::xor _.lxor]
+ [long::shl _.lshl]
+ [long::shr _.lshr]
+ [long::ushr _.lushr]
+
+ [float::+ _.fadd]
+ [float::- _.fsub]
+ [float::* _.fmul]
+ [float::/ _.fdiv]
+ [float::% _.frem]
+
+ [double::+ _.dadd]
+ [double::- _.dsub]
+ [double::* _.dmul]
+ [double::/ _.ddiv]
+ [double::% _.drem]
+ )
+
+(def: $Boolean (type.class box.boolean (list)))
+(def: falseG (_.getstatic ..$Boolean "FALSE" ..$Boolean))
+(def: trueG (_.getstatic ..$Boolean "TRUE" ..$Boolean))
+
+(template [<name> <op>]
+ [(def: (<name> [xG yG])
+ (Binary (Bytecode Any))
+ (do _.monad
+ [@then _.new-label
+ @end _.new-label]
+ ($_ _.compose
+ xG
+ yG
+ (<op> @then)
+ falseG
+ (_.goto @end)
+ (_.set-label @then)
+ trueG
+ (_.set-label @end))))]
+
+ [int::= _.if-icmpeq]
+ [int::< _.if-icmplt]
+
+ [char::= _.if-icmpeq]
+ [char::< _.if-icmplt]
+ )
+
+(template [<name> <op> <reference>]
+ [(def: (<name> [xG yG])
+ (Binary (Bytecode Any))
+ (do _.monad
+ [@then _.new-label
+ @end _.new-label]
+ ($_ _.compose
+ xG
+ yG
+ <op>
+ (_.int (i32.i32 (.i64 <reference>)))
+ (_.if-icmpeq @then)
+ falseG
+ (_.goto @end)
+ (_.set-label @then)
+ trueG
+ (_.set-label @end))))]
+
+ [long::= _.lcmp +0]
+ [long::< _.lcmp -1]
+
+ [float::= _.fcmpg +0]
+ [float::< _.fcmpg -1]
+
+ [double::= _.dcmpg +0]
+ [double::< _.dcmpg -1]
+ )
+
+(def: bundle::int
+ Bundle
+ (<| (/////bundle.prefix (reflection.reflection reflection.int))
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "+" (binary int::+))
+ (/////bundle.install "-" (binary int::-))
+ (/////bundle.install "*" (binary int::*))
+ (/////bundle.install "/" (binary int::/))
+ (/////bundle.install "%" (binary int::%))
+ (/////bundle.install "=" (binary int::=))
+ (/////bundle.install "<" (binary int::<))
+ (/////bundle.install "and" (binary int::and))
+ (/////bundle.install "or" (binary int::or))
+ (/////bundle.install "xor" (binary int::xor))
+ (/////bundle.install "shl" (binary int::shl))
+ (/////bundle.install "shr" (binary int::shr))
+ (/////bundle.install "ushr" (binary int::ushr))
+ )))
+
+(def: bundle::long
+ Bundle
+ (<| (/////bundle.prefix (reflection.reflection reflection.long))
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "+" (binary long::+))
+ (/////bundle.install "-" (binary long::-))
+ (/////bundle.install "*" (binary long::*))
+ (/////bundle.install "/" (binary long::/))
+ (/////bundle.install "%" (binary long::%))
+ (/////bundle.install "=" (binary long::=))
+ (/////bundle.install "<" (binary long::<))
+ (/////bundle.install "and" (binary long::and))
+ (/////bundle.install "or" (binary long::or))
+ (/////bundle.install "xor" (binary long::xor))
+ (/////bundle.install "shl" (binary long::shl))
+ (/////bundle.install "shr" (binary long::shr))
+ (/////bundle.install "ushr" (binary long::ushr))
+ )))
+
+(def: bundle::float
+ Bundle
+ (<| (/////bundle.prefix (reflection.reflection reflection.float))
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "+" (binary float::+))
+ (/////bundle.install "-" (binary float::-))
+ (/////bundle.install "*" (binary float::*))
+ (/////bundle.install "/" (binary float::/))
+ (/////bundle.install "%" (binary float::%))
+ (/////bundle.install "=" (binary float::=))
+ (/////bundle.install "<" (binary float::<))
+ )))
+
+(def: bundle::double
+ Bundle
+ (<| (/////bundle.prefix (reflection.reflection reflection.double))
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "+" (binary double::+))
+ (/////bundle.install "-" (binary double::-))
+ (/////bundle.install "*" (binary double::*))
+ (/////bundle.install "/" (binary double::/))
+ (/////bundle.install "%" (binary double::%))
+ (/////bundle.install "=" (binary double::=))
+ (/////bundle.install "<" (binary double::<))
+ )))
+
+(def: bundle::char
+ Bundle
+ (<| (/////bundle.prefix (reflection.reflection reflection.char))
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "=" (binary char::=))
+ (/////bundle.install "<" (binary char::<))
+ )))
+
+(template [<name> <category> <parser>]
+ [(def: #export <name>
+ (Parser (Type <category>))
+ (<t>.embed <parser> <s>.text))]
+
+ [var Var parser.var]
+ [class category.Class parser.class]
+ [object Object parser.object]
+ [value Value parser.value]
+ [return Return parser.return]
+ )
+
+(exception: #export (not-an-object-array {arrayJT (Type Array)})
+ (exception.report
+ ["JVM Type" (|> arrayJT type.signature signature.signature)]))
+
+(def: #export object-array
+ (Parser (Type Object))
+ (do <>.monad
+ [arrayJT (<t>.embed parser.array <s>.text)]
+ (case (parser.array? arrayJT)
+ (#.Some elementJT)
+ (case (parser.object? elementJT)
+ (#.Some elementJT)
+ (wrap elementJT)
+
+ #.None
+ (<>.fail (exception.construct ..not-an-object-array arrayJT)))
+
+ #.None
+ (undefined))))
+
+(def: (primitive-array-length-handler jvm-primitive)
+ (-> (Type Primitive) Handler)
+ (..custom
+ [<s>.any
+ (function (_ extension-name generate archive arrayS)
+ (do //////.monad
+ [arrayG (generate archive arrayS)]
+ (wrap ($_ _.compose
+ arrayG
+ (_.checkcast (type.array jvm-primitive))
+ _.arraylength))))]))
+
+(def: array::length::object
+ Handler
+ (..custom
+ [($_ <>.and ..object-array <s>.any)
+ (function (_ extension-name generate archive [elementJT arrayS])
+ (do //////.monad
+ [arrayG (generate archive arrayS)]
+ (wrap ($_ _.compose
+ arrayG
+ (_.checkcast (type.array elementJT))
+ _.arraylength))))]))
+
+(def: (new-primitive-array-handler jvm-primitive)
+ (-> Primitive-Array-Type Handler)
+ (..custom
+ [<s>.any
+ (function (_ extension-name generate archive [lengthS])
+ (do //////.monad
+ [lengthG (generate archive lengthS)]
+ (wrap ($_ _.compose
+ lengthG
+ (_.newarray jvm-primitive)))))]))
+
+(def: array::new::object
+ Handler
+ (..custom
+ [($_ <>.and ..object <s>.any)
+ (function (_ extension-name generate archive [objectJT lengthS])
+ (do //////.monad
+ [lengthG (generate archive lengthS)]
+ (wrap ($_ _.compose
+ lengthG
+ (_.anewarray objectJT)))))]))
+
+(def: (read-primitive-array-handler jvm-primitive loadG)
+ (-> (Type Primitive) (Bytecode Any) Handler)
+ (..custom
+ [($_ <>.and <s>.any <s>.any)
+ (function (_ extension-name generate archive [idxS arrayS])
+ (do //////.monad
+ [arrayG (generate archive arrayS)
+ idxG (generate archive idxS)]
+ (wrap ($_ _.compose
+ arrayG
+ (_.checkcast (type.array jvm-primitive))
+ idxG
+ loadG))))]))
+
+(def: array::read::object
+ Handler
+ (..custom
+ [($_ <>.and ..object-array <s>.any <s>.any)
+ (function (_ extension-name generate archive [elementJT idxS arrayS])
+ (do //////.monad
+ [arrayG (generate archive arrayS)
+ idxG (generate archive idxS)]
+ (wrap ($_ _.compose
+ arrayG
+ (_.checkcast (type.array elementJT))
+ idxG
+ _.aaload))))]))
+
+(def: (write-primitive-array-handler jvm-primitive storeG)
+ (-> (Type Primitive) (Bytecode Any) Handler)
+ (..custom
+ [($_ <>.and <s>.any <s>.any <s>.any)
+ (function (_ extension-name generate archive [idxS valueS arrayS])
+ (do //////.monad
+ [arrayG (generate archive arrayS)
+ idxG (generate archive idxS)
+ valueG (generate archive valueS)]
+ (wrap ($_ _.compose
+ arrayG
+ (_.checkcast (type.array jvm-primitive))
+ _.dup
+ idxG
+ valueG
+ storeG))))]))
+
+(def: array::write::object
+ Handler
+ (..custom
+ [($_ <>.and ..object-array <s>.any <s>.any <s>.any)
+ (function (_ extension-name generate archive [elementJT idxS valueS arrayS])
+ (do //////.monad
+ [arrayG (generate archive arrayS)
+ idxG (generate archive idxS)
+ valueG (generate archive valueS)]
+ (wrap ($_ _.compose
+ arrayG
+ (_.checkcast (type.array elementJT))
+ _.dup
+ idxG
+ valueG
+ _.aastore))))]))
+
+(def: bundle::array
+ Bundle
+ (<| (/////bundle.prefix "array")
+ (|> /////bundle.empty
+ (dictionary.merge (<| (/////bundle.prefix "length")
+ (|> /////bundle.empty
+ (/////bundle.install (reflection.reflection reflection.boolean) (primitive-array-length-handler type.boolean))
+ (/////bundle.install (reflection.reflection reflection.byte) (primitive-array-length-handler type.byte))
+ (/////bundle.install (reflection.reflection reflection.short) (primitive-array-length-handler type.short))
+ (/////bundle.install (reflection.reflection reflection.int) (primitive-array-length-handler type.int))
+ (/////bundle.install (reflection.reflection reflection.long) (primitive-array-length-handler type.long))
+ (/////bundle.install (reflection.reflection reflection.float) (primitive-array-length-handler type.float))
+ (/////bundle.install (reflection.reflection reflection.double) (primitive-array-length-handler type.double))
+ (/////bundle.install (reflection.reflection reflection.char) (primitive-array-length-handler type.char))
+ (/////bundle.install "object" array::length::object))))
+ (dictionary.merge (<| (/////bundle.prefix "new")
+ (|> /////bundle.empty
+ (/////bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler __.t-boolean))
+ (/////bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler __.t-byte))
+ (/////bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler __.t-short))
+ (/////bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler __.t-int))
+ (/////bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler __.t-long))
+ (/////bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler __.t-float))
+ (/////bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler __.t-double))
+ (/////bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler __.t-char))
+ (/////bundle.install "object" array::new::object))))
+ (dictionary.merge (<| (/////bundle.prefix "read")
+ (|> /////bundle.empty
+ (/////bundle.install (reflection.reflection reflection.boolean) (read-primitive-array-handler type.boolean _.baload))
+ (/////bundle.install (reflection.reflection reflection.byte) (read-primitive-array-handler type.byte _.baload))
+ (/////bundle.install (reflection.reflection reflection.short) (read-primitive-array-handler type.short _.saload))
+ (/////bundle.install (reflection.reflection reflection.int) (read-primitive-array-handler type.int _.iaload))
+ (/////bundle.install (reflection.reflection reflection.long) (read-primitive-array-handler type.long _.laload))
+ (/////bundle.install (reflection.reflection reflection.float) (read-primitive-array-handler type.float _.faload))
+ (/////bundle.install (reflection.reflection reflection.double) (read-primitive-array-handler type.double _.daload))
+ (/////bundle.install (reflection.reflection reflection.char) (read-primitive-array-handler type.char _.caload))
+ (/////bundle.install "object" array::read::object))))
+ (dictionary.merge (<| (/////bundle.prefix "write")
+ (|> /////bundle.empty
+ (/////bundle.install (reflection.reflection reflection.boolean) (write-primitive-array-handler type.boolean _.bastore))
+ (/////bundle.install (reflection.reflection reflection.byte) (write-primitive-array-handler type.byte _.bastore))
+ (/////bundle.install (reflection.reflection reflection.short) (write-primitive-array-handler type.short _.sastore))
+ (/////bundle.install (reflection.reflection reflection.int) (write-primitive-array-handler type.int _.iastore))
+ (/////bundle.install (reflection.reflection reflection.long) (write-primitive-array-handler type.long _.lastore))
+ (/////bundle.install (reflection.reflection reflection.float) (write-primitive-array-handler type.float _.fastore))
+ (/////bundle.install (reflection.reflection reflection.double) (write-primitive-array-handler type.double _.dastore))
+ (/////bundle.install (reflection.reflection reflection.char) (write-primitive-array-handler type.char _.castore))
+ (/////bundle.install "object" array::write::object))))
+ )))
+
+(def: (object::null _)
+ (Nullary (Bytecode Any))
+ _.aconst-null)
+
+(def: (object::null? objectG)
+ (Unary (Bytecode Any))
+ (do _.monad
+ [@then _.new-label
+ @end _.new-label]
+ ($_ _.compose
+ objectG
+ (_.ifnull @then)
+ ..falseG
+ (_.goto @end)
+ (_.set-label @then)
+ ..trueG
+ (_.set-label @end))))
+
+(def: (object::synchronized [monitorG exprG])
+ (Binary (Bytecode Any))
+ ($_ _.compose
+ monitorG
+ _.dup
+ _.monitorenter
+ exprG
+ _.swap
+ _.monitorexit))
+
+(def: (object::throw exceptionG)
+ (Unary (Bytecode Any))
+ ($_ _.compose
+ exceptionG
+ _.athrow))
+
+(def: $Class (type.class "java.lang.Class" (list)))
+(def: $String (type.class "java.lang.String" (list)))
+
+(def: object::class
+ Handler
+ (..custom
+ [<s>.text
+ (function (_ extension-name generate archive [class])
+ (do //////.monad
+ []
+ (wrap ($_ _.compose
+ (_.string class)
+ (_.invokestatic ..$Class "forName" (type.method [(list ..$String) ..$Class (list)]))))))]))
+
+(def: object::instance?
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.any)
+ (function (_ extension-name generate archive [class objectS])
+ (do //////.monad
+ [objectG (generate archive objectS)]
+ (wrap ($_ _.compose
+ objectG
+ (_.instanceof (type.class class (list)))
+ (_.invokestatic ..$Boolean "valueOf" (type.method [(list type.boolean) ..$Boolean (list)]))))))]))
+
+(def: reflection
+ (All [category]
+ (-> (Type (<| Return' Value' category)) Text))
+ (|>> type.reflection reflection.reflection))
+
+(def: object::cast
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.any)
+ (function (_ extension-name generate archive [from to valueS])
+ (do //////.monad
+ [valueG (generate archive valueS)]
+ (wrap (`` (cond (~~ (template [<object> <type> <unwrap>]
+ [(and (text\= (..reflection <type>)
+ from)
+ (text\= <object>
+ to))
+ (let [$<object> (type.class <object> (list))]
+ ($_ _.compose
+ valueG
+ (_.invokestatic $<object> "valueOf" (type.method [(list <type>) $<object> (list)]))))
+
+ (and (text\= <object>
+ from)
+ (text\= (..reflection <type>)
+ to))
+ (let [$<object> (type.class <object> (list))]
+ ($_ _.compose
+ valueG
+ (_.checkcast $<object>)
+ (_.invokevirtual $<object> <unwrap> (type.method [(list) <type> (list)]))))]
+
+ [box.boolean type.boolean "booleanValue"]
+ [box.byte type.byte "byteValue"]
+ [box.short type.short "shortValue"]
+ [box.int type.int "intValue"]
+ [box.long type.long "longValue"]
+ [box.float type.float "floatValue"]
+ [box.double type.double "doubleValue"]
+ [box.char type.char "charValue"]))
+ ## else
+ valueG)))))]))
+
+(def: bundle::object
+ Bundle
+ (<| (/////bundle.prefix "object")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "null" (nullary object::null))
+ (/////bundle.install "null?" (unary object::null?))
+ (/////bundle.install "synchronized" (binary object::synchronized))
+ (/////bundle.install "throw" (unary object::throw))
+ (/////bundle.install "class" object::class)
+ (/////bundle.install "instance?" object::instance?)
+ (/////bundle.install "cast" object::cast)
+ )))
+
+(def: primitives
+ (Dictionary Text (Type Primitive))
+ (|> (list [(reflection.reflection reflection.boolean) type.boolean]
+ [(reflection.reflection reflection.byte) type.byte]
+ [(reflection.reflection reflection.short) type.short]
+ [(reflection.reflection reflection.int) type.int]
+ [(reflection.reflection reflection.long) type.long]
+ [(reflection.reflection reflection.float) type.float]
+ [(reflection.reflection reflection.double) type.double]
+ [(reflection.reflection reflection.char) type.char])
+ (dictionary.from-list text.hash)))
+
+(def: get::static
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text)
+ (function (_ extension-name generate archive [class field unboxed])
+ (do //////.monad
+ [#let [$class (type.class class (list))]]
+ (case (dictionary.get unboxed ..primitives)
+ (#.Some primitive)
+ (wrap (_.getstatic $class field primitive))
+
+ #.None
+ (wrap (_.getstatic $class field (type.class unboxed (list)))))))]))
+
+(def: unitG (_.string //////synthesis.unit))
+
+(def: put::static
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
+ (function (_ extension-name generate archive [class field unboxed valueS])
+ (do //////.monad
+ [valueG (generate archive valueS)
+ #let [$class (type.class class (list))]]
+ (case (dictionary.get unboxed ..primitives)
+ (#.Some primitive)
+ (wrap ($_ _.compose
+ valueG
+ (_.putstatic $class field primitive)
+ ..unitG))
+
+ #.None
+ (wrap ($_ _.compose
+ valueG
+ (_.checkcast $class)
+ (_.putstatic $class field $class)
+ ..unitG)))))]))
+
+(def: get::virtual
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
+ (function (_ extension-name generate archive [class field unboxed objectS])
+ (do //////.monad
+ [objectG (generate archive objectS)
+ #let [$class (type.class class (list))
+ getG (case (dictionary.get unboxed ..primitives)
+ (#.Some primitive)
+ (_.getfield $class field primitive)
+
+ #.None
+ (_.getfield $class field (type.class unboxed (list))))]]
+ (wrap ($_ _.compose
+ objectG
+ (_.checkcast $class)
+ getG))))]))
+
+(def: put::virtual
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any)
+ (function (_ extension-name generate archive [class field unboxed valueS objectS])
+ (do //////.monad
+ [valueG (generate archive valueS)
+ objectG (generate archive objectS)
+ #let [$class (type.class class (list))
+ putG (case (dictionary.get unboxed ..primitives)
+ (#.Some primitive)
+ (_.putfield $class field primitive)
+
+ #.None
+ (let [$unboxed (type.class unboxed (list))]
+ ($_ _.compose
+ (_.checkcast $unboxed)
+ (_.putfield $class field $unboxed))))]]
+ (wrap ($_ _.compose
+ objectG
+ (_.checkcast $class)
+ _.dup
+ valueG
+ putG))))]))
+
+(type: Input (Typed Synthesis))
+
+(def: input
+ (Parser Input)
+ (<s>.tuple (<>.and ..value <s>.any)))
+
+(def: (generate-input generate archive [valueT valueS])
+ (-> Phase Archive Input (Operation (Typed (Bytecode Any))))
+ (do //////.monad
+ [valueG (generate archive valueS)]
+ (case (type.primitive? valueT)
+ (#.Right valueT)
+ (wrap [valueT valueG])
+
+ (#.Left valueT)
+ (wrap [valueT ($_ _.compose
+ valueG
+ (_.checkcast valueT))]))))
+
+(def: (prepare-output outputT)
+ (-> (Type Return) (Bytecode Any))
+ (case (type.void? outputT)
+ (#.Right outputT)
+ ..unitG
+
+ (#.Left outputT)
+ (\ _.monad wrap [])))
+
+(def: invoke::static
+ Handler
+ (..custom
+ [($_ <>.and ..class <s>.text ..return (<>.some ..input))
+ (function (_ extension-name generate archive [class method outputT inputsTS])
+ (do {! //////.monad}
+ [inputsTG (monad.map ! (generate-input generate archive) inputsTS)]
+ (wrap ($_ _.compose
+ (monad.map _.monad product.right inputsTG)
+ (_.invokestatic class method (type.method [(list\map product.left inputsTG) outputT (list)]))
+ (prepare-output outputT)))))]))
+
+(template [<name> <invoke>]
+ [(def: <name>
+ Handler
+ (..custom
+ [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input))
+ (function (_ extension-name generate archive [class method outputT objectS inputsTS])
+ (do {! //////.monad}
+ [objectG (generate archive objectS)
+ inputsTG (monad.map ! (generate-input generate archive) inputsTS)]
+ (wrap ($_ _.compose
+ objectG
+ (_.checkcast class)
+ (monad.map _.monad product.right inputsTG)
+ (<invoke> class method (type.method [(list\map product.left inputsTG) outputT (list)]))
+ (prepare-output outputT)))))]))]
+
+ [invoke::virtual _.invokevirtual]
+ [invoke::special _.invokespecial]
+ [invoke::interface _.invokeinterface]
+ )
+
+(def: invoke::constructor
+ Handler
+ (..custom
+ [($_ <>.and ..class (<>.some ..input))
+ (function (_ extension-name generate archive [class inputsTS])
+ (do {! //////.monad}
+ [inputsTG (monad.map ! (generate-input generate archive) inputsTS)]
+ (wrap ($_ _.compose
+ (_.new class)
+ _.dup
+ (monad.map _.monad product.right inputsTG)
+ (_.invokespecial class "<init>" (type.method [(list\map product.left inputsTG) type.void (list)]))))))]))
+
+(def: bundle::member
+ Bundle
+ (<| (/////bundle.prefix "member")
+ (|> (: Bundle /////bundle.empty)
+ (dictionary.merge (<| (/////bundle.prefix "get")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "static" get::static)
+ (/////bundle.install "virtual" get::virtual))))
+ (dictionary.merge (<| (/////bundle.prefix "put")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "static" put::static)
+ (/////bundle.install "virtual" put::virtual))))
+ (dictionary.merge (<| (/////bundle.prefix "invoke")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "static" invoke::static)
+ (/////bundle.install "virtual" invoke::virtual)
+ (/////bundle.install "special" invoke::special)
+ (/////bundle.install "interface" invoke::interface)
+ (/////bundle.install "constructor" invoke::constructor))))
+ )))
+
+(def: annotation-parameter
+ (Parser (/.Annotation-Parameter Synthesis))
+ (<s>.tuple (<>.and <s>.text <s>.any)))
+
+(def: annotation
+ (Parser (/.Annotation Synthesis))
+ (<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter))))
+
+(def: argument
+ (Parser Argument)
+ (<s>.tuple (<>.and <s>.text ..value)))
+
+(def: overriden-method-definition
+ (Parser [(Environment Synthesis) (/.Overriden-Method Synthesis)])
+ (<s>.tuple (do <>.monad
+ [_ (<s>.text! /.overriden-tag)
+ ownerT ..class
+ name <s>.text
+ strict-fp? <s>.bit
+ annotations (<s>.tuple (<>.some ..annotation))
+ vars (<s>.tuple (<>.some ..var))
+ self-name <s>.text
+ arguments (<s>.tuple (<>.some ..argument))
+ returnT ..return
+ exceptionsT (<s>.tuple (<>.some ..class))
+ [environment body] (<s>.function 1
+ (<s>.tuple <s>.any))]
+ (wrap [environment
+ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ body]]))))
+
+(def: (normalize-path normalize)
+ (-> (-> Synthesis Synthesis)
+ (-> Path Path))
+ (function (recur path)
+ (case path
+ (^ (//////synthesis.path/then bodyS))
+ (//////synthesis.path/then (normalize bodyS))
+
+ (^template [<tag>]
+ [(^ (<tag> leftP rightP))
+ (<tag> (recur leftP) (recur rightP))])
+ ([#//////synthesis.Alt]
+ [#//////synthesis.Seq])
+
+ (^template [<tag>]
+ [(^ (<tag> value))
+ path])
+ ([#//////synthesis.Pop]
+ [#//////synthesis.Bind]
+ [#//////synthesis.Access])
+
+ _
+ (undefined))))
+
+(def: (normalize-method-body mapping)
+ (-> (Dictionary Variable Variable) Synthesis Synthesis)
+ (function (recur body)
+ (case body
+ (^template [<tag>]
+ [(^ (<tag> value))
+ body])
+ ([#//////synthesis.Primitive]
+ [//////synthesis.constant])
+
+ (^ (//////synthesis.variant [lefts right? sub]))
+ (//////synthesis.variant [lefts right? (recur sub)])
+
+ (^ (//////synthesis.tuple members))
+ (//////synthesis.tuple (list\map recur members))
+
+ (^ (//////synthesis.variable var))
+ (|> mapping
+ (dictionary.get var)
+ (maybe.default var)
+ //////synthesis.variable)
+
+ (^ (//////synthesis.branch/case [inputS pathS]))
+ (//////synthesis.branch/case [(recur inputS) (normalize-path recur pathS)])
+
+ (^ (//////synthesis.branch/let [inputS register outputS]))
+ (//////synthesis.branch/let [(recur inputS) register (recur outputS)])
+
+ (^ (//////synthesis.branch/if [testS thenS elseS]))
+ (//////synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)])
+
+ (^ (//////synthesis.branch/get [path recordS]))
+ (//////synthesis.branch/get [path (recur recordS)])
+
+ (^ (//////synthesis.loop/scope [offset initsS+ bodyS]))
+ (//////synthesis.loop/scope [offset (list\map recur initsS+) (recur bodyS)])
+
+ (^ (//////synthesis.loop/recur updatesS+))
+ (//////synthesis.loop/recur (list\map recur updatesS+))
+
+ (^ (//////synthesis.function/abstraction [environment arity bodyS]))
+ (//////synthesis.function/abstraction [(list\map (function (_ local)
+ (case local
+ (^ (//////synthesis.variable local))
+ (|> mapping
+ (dictionary.get local)
+ (maybe.default local)
+ //////synthesis.variable)
+
+ _
+ local))
+ environment)
+ arity
+ bodyS])
+
+ (^ (//////synthesis.function/apply [functionS inputsS+]))
+ (//////synthesis.function/apply [(recur functionS) (list\map recur inputsS+)])
+
+ (#//////synthesis.Extension [name inputsS+])
+ (#//////synthesis.Extension [name (list\map recur inputsS+)]))))
+
+(def: $Object (type.class "java.lang.Object" (list)))
+
+(def: (anonymous-init-method env)
+ (-> (Environment Synthesis) (Type category.Method))
+ (type.method [(list.repeat (list.size env) ..$Object)
+ type.void
+ (list)]))
+
+(def: (with-anonymous-init class env super-class inputsTG)
+ (-> (Type category.Class) (Environment Synthesis) (Type category.Class) (List (Typed (Bytecode Any))) (Resource Method))
+ (let [store-capturedG (|> env
+ list.size
+ list.indices
+ (monad.map _.monad (.function (_ register)
+ ($_ _.compose
+ (_.aload 0)
+ (_.aload (inc register))
+ (_.putfield class (///reference.foreign-name register) $Object)))))]
+ (method.method method.public "<init>" (anonymous-init-method env)
+ (list)
+ (#.Some ($_ _.compose
+ (_.aload 0)
+ (monad.map _.monad product.right inputsTG)
+ (_.invokespecial super-class "<init>" (type.method [(list\map product.left inputsTG) type.void (list)]))
+ store-capturedG
+ _.return)))))
+
+(def: (anonymous-instance generate archive class env)
+ (-> Phase Archive (Type category.Class) (Environment Synthesis) (Operation (Bytecode Any)))
+ (do {! //////.monad}
+ [captureG+ (monad.map ! (generate archive) env)]
+ (wrap ($_ _.compose
+ (_.new class)
+ _.dup
+ (monad.seq _.monad captureG+)
+ (_.invokespecial class "<init>" (anonymous-init-method env))))))
+
+(def: (returnG returnT)
+ (-> (Type Return) (Bytecode Any))
+ (case (type.void? returnT)
+ (#.Right returnT)
+ _.return
+
+ (#.Left returnT)
+ (case (type.primitive? returnT)
+ (#.Left returnT)
+ ($_ _.compose
+ (_.checkcast returnT)
+ _.areturn)
+
+ (#.Right returnT)
+ (cond (or (\ type.equivalence = type.boolean returnT)
+ (\ type.equivalence = type.byte returnT)
+ (\ type.equivalence = type.short returnT)
+ (\ type.equivalence = type.int returnT)
+ (\ type.equivalence = type.char returnT))
+ _.ireturn
+
+ (\ type.equivalence = type.long returnT)
+ _.lreturn
+
+ (\ type.equivalence = type.float returnT)
+ _.freturn
+
+ ## (\ type.equivalence = type.double returnT)
+ _.dreturn))))
+
+(def: class::anonymous
+ Handler
+ (..custom
+ [($_ <>.and
+ ..class
+ (<s>.tuple (<>.some ..class))
+ (<s>.tuple (<>.some ..input))
+ (<s>.tuple (<>.some ..overriden-method-definition)))
+ (function (_ extension-name generate archive [super-class super-interfaces
+ inputsTS
+ overriden-methods])
+ (do {! //////.monad}
+ [[context _] (//////generation.with-new-context archive (wrap []))
+ #let [[module-id artifact-id] context
+ anonymous-class-name (///runtime.class-name context)
+ class (type.class anonymous-class-name (list))
+ total-environment (|> overriden-methods
+ ## Get all the environments.
+ (list\map product.left)
+ ## Combine them.
+ list\join
+ ## Remove duplicates.
+ (set.from-list //////synthesis.hash)
+ set.to-list)
+ global-mapping (|> total-environment
+ ## Give them names as "foreign" variables.
+ list.enumeration
+ (list\map (function (_ [id capture])
+ [capture (#//////variable.Foreign id)]))
+ (dictionary.from-list //////variable.hash))
+ normalized-methods (list\map (function (_ [environment
+ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ body]])
+ (let [local-mapping (|> environment
+ list.enumeration
+ (list\map (function (_ [foreign-id capture])
+ [(#//////variable.Foreign foreign-id)
+ (|> global-mapping
+ (dictionary.get capture)
+ maybe.assume)]))
+ (dictionary.from-list //////variable.hash))]
+ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ (normalize-method-body local-mapping body)]))
+ overriden-methods)]
+ inputsTI (monad.map ! (generate-input generate archive) inputsTS)
+ method-definitions (monad.map ! (function (_ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ bodyS])
+ (do !
+ [bodyG (//////generation.with-context artifact-id
+ (generate archive bodyS))]
+ (wrap (method.method ($_ modifier\compose
+ method.public
+ method.final
+ (if strict-fp?
+ method.strict
+ modifier\identity))
+ name
+ (type.method [(list\map product.right arguments)
+ returnT
+ exceptionsT])
+ (list)
+ (#.Some ($_ _.compose
+ bodyG
+ (returnG returnT)))))))
+ normalized-methods)
+ bytecode (<| (\ ! map (format.run class.writer))
+ //////.lift
+ (class.class version.v6_0 ($_ modifier\compose class.public class.final)
+ (name.internal anonymous-class-name)
+ (name.internal (..reflection super-class))
+ (list\map (|>> ..reflection name.internal) super-interfaces)
+ (foreign.variables total-environment)
+ (list& (..with-anonymous-init class total-environment super-class inputsTI)
+ method-definitions)
+ (row.row)))
+ _ (//////generation.execute! [anonymous-class-name bytecode])
+ _ (//////generation.save! (%.nat artifact-id) [anonymous-class-name bytecode])]
+ (anonymous-instance generate archive class total-environment)))]))
+
+(def: bundle::class
+ Bundle
+ (<| (/////bundle.prefix "class")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "anonymous" class::anonymous)
+ )))
+
+(def: #export bundle
+ Bundle
+ (<| (/////bundle.prefix "jvm")
+ (|> ..bundle::conversion
+ (dictionary.merge ..bundle::int)
+ (dictionary.merge ..bundle::long)
+ (dictionary.merge ..bundle::float)
+ (dictionary.merge ..bundle::double)
+ (dictionary.merge ..bundle::char)
+ (dictionary.merge ..bundle::array)
+ (dictionary.merge ..bundle::object)
+ (dictionary.merge ..bundle::member)
+ (dictionary.merge ..bundle::class)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux
new file mode 100644
index 000000000..1f1bd7f91
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux
@@ -0,0 +1,18 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]]
+ ["." / #_
+ ["#." common]
+ ["#." host]
+ [////
+ [generation
+ [lua
+ [runtime (#+ Bundle)]]]]])
+
+(def: #export bundle
+ Bundle
+ (dictionary.merge /common.bundle
+ /host.bundle))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux
new file mode 100644
index 000000000..b31bf5610
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux
@@ -0,0 +1,181 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary]
+ ["." list ("#\." functor fold)]]]
+ [math
+ [number
+ ["f" frac]]]
+ ["@" target
+ ["_" lua (#+ Expression)]]]]
+ ["." //// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["//" lua #_
+ ["#." runtime (#+ Operation Phase Handler Bundle Generator)]]]
+ [//
+ [synthesis (#+ %synthesis)]
+ ["." generation]
+ [///
+ ["#" phase]]]]])
+
+(def: #export (custom [parser handler])
+ (All [s]
+ (-> [(Parser s)
+ (-> Text (Generator s))]
+ Handler))
+ (function (_ extension_name phase archive input)
+ (case (<s>.run parser input)
+ (#try.Success input')
+ (handler extension_name phase archive input')
+
+ (#try.Failure error)
+ (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
+
+(template: (!unary function)
+ (|>> list _.apply/* (|> (_.var function))))
+
+## TODO: Get rid of this ASAP
+(def: lux::syntax_char_case!
+ (..custom [($_ <>.and
+ <s>.any
+ <s>.any
+ (<>.some (<s>.tuple ($_ <>.and
+ (<s>.tuple (<>.many <s>.i64))
+ <s>.any))))
+ (function (_ extension_name phase archive [input else conditionals])
+ (do {! /////.monad}
+ [inputG (phase archive input)
+ elseG (phase archive else)
+ @input (\ ! map _.var (generation.gensym "input"))
+ conditionalsG (: (Operation (List [Expression Expression]))
+ (monad.map ! (function (_ [chars branch])
+ (do !
+ [branchG (phase archive branch)]
+ (wrap [(|> chars
+ (list\map (|>> .int _.int (_.= @input)))
+ (list\fold (function (_ clause total)
+ (if (is? _.nil total)
+ clause
+ (_.or clause total)))
+ _.nil))
+ branchG])))
+ conditionals))
+ #let [closure (_.closure (list @input)
+ (list\fold (function (_ [test then] else)
+ (_.if test (_.return then) else))
+ (_.return elseG)
+ conditionalsG))]]
+ (wrap (_.apply/1 closure inputG))))]))
+
+(def: lux_procs
+ Bundle
+ (|> /.empty
+ (/.install "syntax char case!" lux::syntax_char_case!)
+ (/.install "is" (binary (product.uncurry _.=)))
+ (/.install "try" (unary //runtime.lux//try))))
+
+(def: i64_procs
+ Bundle
+ (<| (/.prefix "i64")
+ (|> /.empty
+ (/.install "and" (binary (product.uncurry _.bit_and)))
+ (/.install "or" (binary (product.uncurry _.bit_or)))
+ (/.install "xor" (binary (product.uncurry _.bit_xor)))
+ (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift)))
+ (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift)))
+ (/.install "=" (binary (product.uncurry _.=)))
+ (/.install "+" (binary (product.uncurry _.+)))
+ (/.install "-" (binary (product.uncurry _.-)))
+ (/.install "<" (binary (product.uncurry _.<)))
+ (/.install "*" (binary (product.uncurry _.*)))
+ (/.install "/" (binary (product.uncurry //runtime.i64//division)))
+ (/.install "%" (binary (product.uncurry //runtime.i64//remainder)))
+ (/.install "f64" (unary (_./ (_.float +1.0))))
+ (/.install "char" (unary (_.apply/1 (_.var "utf8.char"))))
+ )))
+
+(def: f64//decode
+ (Unary Expression)
+ (|>> list _.apply/* (|> (_.var "tonumber")) _.return (_.closure (list)) //runtime.lux//try))
+
+(def: f64_procs
+ Bundle
+ (<| (/.prefix "f64")
+ (|> /.empty
+ (/.install "+" (binary (product.uncurry _.+)))
+ (/.install "-" (binary (product.uncurry _.-)))
+ (/.install "*" (binary (product.uncurry _.*)))
+ (/.install "/" (binary (product.uncurry _./)))
+ (/.install "%" (binary (product.uncurry (function.flip (_.apply/2 (_.var "math.fmod"))))))
+ (/.install "=" (binary (product.uncurry _.=)))
+ (/.install "<" (binary (product.uncurry _.<)))
+ (/.install "i64" (unary (!unary "math.floor")))
+ (/.install "encode" (unary (_.apply/2 (_.var "string.format") (_.string "%.17g"))))
+ (/.install "decode" (unary ..f64//decode)))))
+
+(def: (text//char [paramO subjectO])
+ (Binary Expression)
+ (//runtime.text//char (_.+ (_.int +1) paramO) subjectO))
+
+(def: (text//clip [paramO extraO subjectO])
+ (Trinary Expression)
+ (//runtime.text//clip subjectO paramO extraO))
+
+(def: (text//index [startO partO textO])
+ (Trinary Expression)
+ (//runtime.text//index textO partO startO))
+
+(def: text_procs
+ Bundle
+ (<| (/.prefix "text")
+ (|> /.empty
+ (/.install "=" (binary (product.uncurry _.=)))
+ (/.install "<" (binary (product.uncurry _.<)))
+ (/.install "concat" (binary (product.uncurry (function.flip _.concat))))
+ (/.install "index" (trinary ..text//index))
+ (/.install "size" (unary //runtime.text//size))
+ ## TODO: Use version below once the Lua compiler becomes self-hosted.
+ ## (/.install "size" (unary (for {@.lua (!unary "utf8.len")}
+ ## (!unary "string.len"))))
+ (/.install "char" (binary ..text//char))
+ (/.install "clip" (trinary ..text//clip))
+ )))
+
+(def: (io//log! messageO)
+ (Unary Expression)
+ (|> (_.apply/* (list messageO) (_.var "print"))
+ (_.or //runtime.unit)))
+
+(def: io_procs
+ Bundle
+ (<| (/.prefix "io")
+ (|> /.empty
+ (/.install "log" (unary ..io//log!))
+ (/.install "error" (unary (!unary "error"))))))
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "lux")
+ (|> lux_procs
+ (dictionary.merge i64_procs)
+ (dictionary.merge f64_procs)
+ (dictionary.merge text_procs)
+ (dictionary.merge io_procs)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux
new file mode 100644
index 000000000..1bb7d771c
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux
@@ -0,0 +1,200 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ [collection
+ ["." dictionary]
+ ["." list]]
+ [text
+ ["%" format (#+ format)]]]
+ [target
+ ["_" lua (#+ Var Expression)]]]]
+ ["." // #_
+ ["#." common (#+ custom)]
+ ["//#" /// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["." reference]
+ ["//" lua #_
+ ["#." runtime (#+ Operation Phase Handler Bundle
+ with_vars)]]]
+ ["/#" // #_
+ ["." generation]
+ ["//#" /// #_
+ ["#." phase]]]]]])
+
+(def: array::new
+ (Unary Expression)
+ (|>> ["n"] list _.table))
+
+(def: array::length
+ (Unary Expression)
+ (_.the "n"))
+
+(def: (array::read [indexG arrayG])
+ (Binary Expression)
+ (_.nth (_.+ (_.int +1) indexG) arrayG))
+
+(def: (array::write [indexG valueG arrayG])
+ (Trinary Expression)
+ (//runtime.array//write indexG valueG arrayG))
+
+(def: (array::delete [indexG arrayG])
+ (Binary Expression)
+ (//runtime.array//write indexG _.nil arrayG))
+
+(def: array
+ Bundle
+ (<| (/.prefix "array")
+ (|> /.empty
+ (/.install "new" (unary array::new))
+ (/.install "length" (unary array::length))
+ (/.install "read" (binary array::read))
+ (/.install "write" (trinary array::write))
+ (/.install "delete" (binary array::delete))
+ )))
+
+(def: object::get
+ Handler
+ (custom
+ [($_ <>.and <s>.text <s>.any)
+ (function (_ extension phase archive [fieldS objectS])
+ (do ////////phase.monad
+ [objectG (phase archive objectS)]
+ (wrap (_.the fieldS objectG))))]))
+
+(def: object::do
+ Handler
+ (custom
+ [($_ <>.and <s>.text <s>.any (<>.some <s>.any))
+ (function (_ extension phase archive [methodS objectS inputsS])
+ (do {! ////////phase.monad}
+ [objectG (phase archive objectS)
+ inputsG (monad.map ! (phase archive) inputsS)]
+ (wrap (_.do methodS inputsG objectG))))]))
+
+(template [<!> <?> <unit>]
+ [(def: <!> (Nullary Expression) (function.constant <unit>))
+ (def: <?> (Unary Expression) (_.= <unit>))]
+
+ [object::nil object::nil? _.nil]
+ )
+
+(def: object
+ Bundle
+ (<| (/.prefix "object")
+ (|> /.empty
+ (/.install "get" object::get)
+ (/.install "do" object::do)
+ (/.install "nil" (nullary object::nil))
+ (/.install "nil?" (unary object::nil?))
+ )))
+
+(def: $input
+ (_.var "input"))
+
+(def: utf8::encode
+ (custom
+ [<s>.any
+ (function (_ extension phase archive inputS)
+ (do {! ////////phase.monad}
+ [inputG (phase archive inputS)]
+ (wrap (_.apply/1 (<| (_.closure (list $input))
+ (_.return (|> (_.var "string.byte")
+ (_.apply/* (list $input (_.int +1) (_.length $input)))
+ (_.apply/1 (_.var "table.pack")))))
+ inputG))))]))
+
+(def: utf8::decode
+ (custom
+ [<s>.any
+ (function (_ extension phase archive inputS)
+ (do {! ////////phase.monad}
+ [inputG (phase archive inputS)]
+ (wrap (|> inputG
+ (_.apply/1 (_.var "table.unpack"))
+ (_.apply/1 (_.var "string.char"))))))]))
+
+(def: utf8
+ Bundle
+ (<| (/.prefix "utf8")
+ (|> /.empty
+ (/.install "encode" utf8::encode)
+ (/.install "decode" utf8::decode)
+ )))
+
+(def: lua::constant
+ (custom
+ [<s>.text
+ (function (_ extension phase archive name)
+ (\ ////////phase.monad wrap (_.var name)))]))
+
+(def: lua::apply
+ (custom
+ [($_ <>.and <s>.any (<>.some <s>.any))
+ (function (_ extension phase archive [abstractionS inputsS])
+ (do {! ////////phase.monad}
+ [abstractionG (phase archive abstractionS)
+ inputsG (monad.map ! (phase archive) inputsS)]
+ (wrap (_.apply/* inputsG abstractionG))))]))
+
+(def: lua::power
+ (custom
+ [($_ <>.and <s>.any <s>.any)
+ (function (_ extension phase archive [powerS baseS])
+ (do {! ////////phase.monad}
+ [powerG (phase archive powerS)
+ baseG (phase archive baseS)]
+ (wrap (_.^ powerG baseG))))]))
+
+(def: lua::import
+ (custom
+ [<s>.text
+ (function (_ extension phase archive module)
+ (\ ////////phase.monad wrap
+ (_.require/1 (_.string module))))]))
+
+(def: lua::function
+ (custom
+ [($_ <>.and <s>.i64 <s>.any)
+ (function (_ extension phase archive [arity abstractionS])
+ (do {! ////////phase.monad}
+ [abstractionG (phase archive abstractionS)
+ #let [variable (: (-> Text (Operation Var))
+ (|>> generation.gensym
+ (\ ! map _.var)))]
+ g!inputs (monad.map ! (function (_ _)
+ (variable "input"))
+ (list.repeat (.nat arity) []))]
+ (wrap (<| (_.closure g!inputs)
+ _.statement
+ (case (.nat arity)
+ 0 (_.apply/1 abstractionG //runtime.unit)
+ 1 (_.apply/* g!inputs abstractionG)
+ _ (_.apply/1 abstractionG (_.array g!inputs)))))))]))
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "lua")
+ (|> /.empty
+ (dictionary.merge ..array)
+ (dictionary.merge ..object)
+ (dictionary.merge ..utf8)
+
+ (/.install "constant" lua::constant)
+ (/.install "apply" lua::apply)
+ (/.install "power" lua::power)
+ (/.install "import" lua::import)
+ (/.install "function" lua::function)
+ (/.install "script universe" (nullary (function.constant (_.bool reference.universe))))
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php.lux
new file mode 100644
index 000000000..751e67a85
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php.lux
@@ -0,0 +1,18 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]]
+ ["." / #_
+ ["#." common]
+ ["#." host]
+ [////
+ [generation
+ [php
+ [runtime (#+ Bundle)]]]]])
+
+(def: #export bundle
+ Bundle
+ (dictionary.merge /common.bundle
+ /host.bundle))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux
new file mode 100644
index 000000000..2d31a6b71
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux
@@ -0,0 +1,192 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary]
+ ["." set]
+ ["." list ("#\." functor fold)]]]
+ [math
+ [number
+ ["f" frac]]]
+ ["@" target
+ ["_" php (#+ Expression)]]]]
+ ["." //// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["." reference]
+ ["//" php #_
+ ["#." runtime (#+ Operation Phase Handler Bundle Generator)]
+ ["#." case]]]
+ [//
+ ["." synthesis (#+ %synthesis)]
+ ["." generation]
+ [///
+ ["#" phase]]]]])
+
+(def: #export (custom [parser handler])
+ (All [s]
+ (-> [(Parser s)
+ (-> Text (Generator s))]
+ Handler))
+ (function (_ extension_name phase archive input)
+ (case (<s>.run parser input)
+ (#try.Success input')
+ (handler extension_name phase archive input')
+
+ (#try.Failure error)
+ (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
+
+(template: (!unary function)
+ (|>> list _.apply/* (|> (_.constant function))))
+
+## TODO: Get rid of this ASAP
+(def: lux::syntax_char_case!
+ (..custom [($_ <>.and
+ <s>.any
+ <s>.any
+ (<>.some (<s>.tuple ($_ <>.and
+ (<s>.tuple (<>.many <s>.i64))
+ <s>.any))))
+ (function (_ extension_name phase archive [input else conditionals])
+ (do {! /////.monad}
+ [inputG (phase archive input)
+ [[context_module context_artifact] elseG] (generation.with_new_context archive
+ (phase archive else))
+ @input (\ ! map _.var (generation.gensym "input"))
+ conditionalsG (: (Operation (List [Expression Expression]))
+ (monad.map ! (function (_ [chars branch])
+ (do !
+ [branchG (phase archive branch)]
+ (wrap [(|> chars
+ (list\map (|>> .int _.int (_.=== @input)))
+ (list\fold (function (_ clause total)
+ (if (is? _.null total)
+ clause
+ (_.or clause total)))
+ _.null))
+ branchG])))
+ conditionals))
+ #let [foreigns (|> conditionals
+ (list\map (|>> product.right synthesis.path/then //case.dependencies))
+ (list& (//case.dependencies (synthesis.path/then else)))
+ list.concat
+ (set.from_list _.hash)
+ set.to_list)
+ @expression (_.constant (reference.artifact [context_module context_artifact]))
+ directive (_.define_function @expression (list& (_.parameter @input) (list\map _.reference foreigns))
+ (list\fold (function (_ [test then] else)
+ (_.if test (_.return then) else))
+ (_.return elseG)
+ conditionalsG))]
+ _ (generation.execute! directive)
+ _ (generation.save! context_artifact directive)]
+ (wrap (_.apply/* (list& inputG foreigns) @expression))))]))
+
+(def: lux_procs
+ Bundle
+ (|> /.empty
+ (/.install "syntax char case!" lux::syntax_char_case!)
+ (/.install "is" (binary (product.uncurry _.===)))
+ (/.install "try" (unary //runtime.lux//try))
+ ))
+
+(def: (left_shift [parameter subject])
+ (Binary Expression)
+ (_.bit_shl (_.% (_.int +64) parameter) subject))
+
+(def: i64_procs
+ Bundle
+ (<| (/.prefix "i64")
+ (|> /.empty
+ (/.install "and" (binary (product.uncurry _.bit_and)))
+ (/.install "or" (binary (product.uncurry _.bit_or)))
+ (/.install "xor" (binary (product.uncurry _.bit_xor)))
+ (/.install "left-shift" (binary ..left_shift))
+ (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift)))
+ (/.install "=" (binary (product.uncurry _.==)))
+ (/.install "<" (binary (product.uncurry _.<)))
+ (/.install "+" (binary (product.uncurry //runtime.i64//+)))
+ (/.install "-" (binary (product.uncurry //runtime.i64//-)))
+ (/.install "*" (binary (product.uncurry //runtime.i64//*)))
+ (/.install "/" (binary (function (_ [parameter subject])
+ (_.intdiv/2 [subject parameter]))))
+ (/.install "%" (binary (product.uncurry _.%)))
+ (/.install "f64" (unary (_./ (_.float +1.0))))
+ (/.install "char" (unary //runtime.i64//char))
+ )))
+
+(def: (f64//% [parameter subject])
+ (Binary Expression)
+ (_.fmod/2 [subject parameter]))
+
+(def: (f64//encode subject)
+ (Unary Expression)
+ (_.number_format/2 [subject (_.int +17)]))
+
+(def: f64_procs
+ Bundle
+ (<| (/.prefix "f64")
+ (|> /.empty
+ (/.install "=" (binary (product.uncurry _.==)))
+ (/.install "<" (binary (product.uncurry _.<)))
+ (/.install "+" (binary (product.uncurry _.+)))
+ (/.install "-" (binary (product.uncurry _.-)))
+ (/.install "*" (binary (product.uncurry _.*)))
+ (/.install "/" (binary (product.uncurry _./)))
+ (/.install "%" (binary ..f64//%))
+ (/.install "i64" (unary _.intval/1))
+ (/.install "encode" (unary ..f64//encode))
+ (/.install "decode" (unary //runtime.f64//decode)))))
+
+(def: (text//clip [paramO extraO subjectO])
+ (Trinary Expression)
+ (//runtime.text//clip paramO extraO subjectO))
+
+(def: (text//index [startO partO textO])
+ (Trinary Expression)
+ (//runtime.text//index textO partO startO))
+
+(def: text_procs
+ Bundle
+ (<| (/.prefix "text")
+ (|> /.empty
+ (/.install "=" (binary (product.uncurry _.==)))
+ (/.install "<" (binary (product.uncurry _.<)))
+ (/.install "concat" (binary (product.uncurry (function.flip _.concat))))
+ (/.install "index" (trinary ..text//index))
+ (/.install "size" (unary //runtime.text//size))
+ (/.install "char" (binary (product.uncurry //runtime.text//char)))
+ (/.install "clip" (trinary ..text//clip))
+ )))
+
+(def: io_procs
+ Bundle
+ (<| (/.prefix "io")
+ (|> /.empty
+ (/.install "log" (unary //runtime.io//log!))
+ (/.install "error" (unary //runtime.io//throw!)))))
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "lux")
+ (|> /.empty
+ (dictionary.merge lux_procs)
+ (dictionary.merge i64_procs)
+ (dictionary.merge f64_procs)
+ (dictionary.merge text_procs)
+ (dictionary.merge io_procs))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux
new file mode 100644
index 000000000..ab01b5938
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux
@@ -0,0 +1,143 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ [collection
+ ["." dictionary]
+ ["." list]]
+ [text
+ ["%" format (#+ format)]]]
+ [target
+ ["_" php (#+ Var Expression)]]]]
+ ["." // #_
+ ["#." common (#+ custom)]
+ ["//#" /// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["." reference]
+ ["//" php #_
+ ["#." runtime (#+ Operation Phase Handler Bundle
+ with_vars)]]]
+ ["/#" // #_
+ ["." generation]
+ ["//#" /// #_
+ ["#." phase]]]]]])
+
+(def: (array::new size)
+ (Unary Expression)
+ (//runtime.tuple//make size (_.array_fill/3 [(_.int +0) size _.null])))
+
+(def: (array::read [indexG arrayG])
+ (Binary Expression)
+ (_.nth indexG arrayG))
+
+(def: (array::write [indexG valueG arrayG])
+ (Trinary Expression)
+ (//runtime.array//write indexG valueG arrayG))
+
+(def: (array::delete [indexG arrayG])
+ (Binary Expression)
+ (//runtime.array//write indexG _.null arrayG))
+
+(def: array
+ Bundle
+ (<| (/.prefix "array")
+ (|> /.empty
+ (/.install "new" (unary array::new))
+ (/.install "length" (unary //runtime.array//length))
+ (/.install "read" (binary array::read))
+ (/.install "write" (trinary array::write))
+ (/.install "delete" (binary array::delete))
+ )))
+
+(def: object::new
+ (custom
+ [($_ <>.and <s>.text (<>.some <s>.any))
+ (function (_ extension phase archive [constructor inputsS])
+ (do {! ////////phase.monad}
+ [inputsG (monad.map ! (phase archive) inputsS)]
+ (wrap (_.new (_.constant constructor) inputsG))))]))
+
+(def: object::get
+ Handler
+ (custom
+ [($_ <>.and <s>.text <s>.any)
+ (function (_ extension phase archive [fieldS objectS])
+ (do ////////phase.monad
+ [objectG (phase archive objectS)]
+ (wrap (_.the fieldS objectG))))]))
+
+(def: object::do
+ Handler
+ (custom
+ [($_ <>.and <s>.text <s>.any (<>.some <s>.any))
+ (function (_ extension phase archive [methodS objectS inputsS])
+ (do {! ////////phase.monad}
+ [objectG (phase archive objectS)
+ inputsG (monad.map ! (phase archive) inputsS)]
+ (wrap (_.do methodS inputsG objectG))))]))
+
+(template [<!> <?> <unit>]
+ [(def: <!> (Nullary Expression) (function.constant <unit>))
+ (def: <?> (Unary Expression) (_.=== <unit>))]
+
+ [object::null object::null? _.null]
+ )
+
+(def: object
+ Bundle
+ (<| (/.prefix "object")
+ (|> /.empty
+ (/.install "new" object::new)
+ (/.install "get" object::get)
+ (/.install "do" object::do)
+ (/.install "null" (nullary object::null))
+ (/.install "null?" (unary object::null?))
+ )))
+
+(def: php::constant
+ (custom
+ [<s>.text
+ (function (_ extension phase archive name)
+ (\ ////////phase.monad wrap (_.constant name)))]))
+
+(def: php::apply
+ (custom
+ [($_ <>.and <s>.any (<>.some <s>.any))
+ (function (_ extension phase archive [abstractionS inputsS])
+ (do {! ////////phase.monad}
+ [abstractionG (phase archive abstractionS)
+ inputsG (monad.map ! (phase archive) inputsS)]
+ (wrap (_.apply/* inputsG abstractionG))))]))
+
+(def: php::pack
+ (custom
+ [($_ <>.and <s>.any <s>.any)
+ (function (_ extension phase archive [formatS dataS])
+ (do {! ////////phase.monad}
+ [formatG (phase archive formatS)
+ dataG (phase archive dataS)]
+ (wrap (_.pack/2 [formatG (_.splat dataG)]))))]))
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "php")
+ (|> /.empty
+ (dictionary.merge ..array)
+ (dictionary.merge ..object)
+
+ (/.install "constant" php::constant)
+ (/.install "apply" php::apply)
+ (/.install "pack" php::pack)
+ (/.install "script universe" (nullary (function.constant (_.bool reference.universe))))
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python.lux
new file mode 100644
index 000000000..2309732f3
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python.lux
@@ -0,0 +1,18 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]]
+ ["." / #_
+ ["#." common]
+ ["#." host]
+ [////
+ [generation
+ [python
+ [runtime (#+ Bundle)]]]]])
+
+(def: #export bundle
+ Bundle
+ (dictionary.merge /common.bundle
+ /host.bundle))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux
new file mode 100644
index 000000000..da9ab4a4b
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux
@@ -0,0 +1,171 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary]
+ ["." list ("#\." functor fold)]]]
+ [math
+ [number
+ ["f" frac]]]
+ [target
+ ["_" python (#+ Expression)]]]]
+ ["." //// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["//" python #_
+ ["#." runtime (#+ Operation Phase Handler Bundle Generator)]]]
+ [//
+ [synthesis (#+ %synthesis)]
+ ["." generation]
+ [///
+ ["#" phase]]]]])
+
+(def: #export (custom [parser handler])
+ (All [s]
+ (-> [(Parser s)
+ (-> Text (Generator s))]
+ Handler))
+ (function (_ extension_name phase archive input)
+ (case (<s>.run parser input)
+ (#try.Success input')
+ (handler extension_name phase archive input')
+
+ (#try.Failure error)
+ (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
+
+## TODO: Get rid of this ASAP
+(def: lux::syntax_char_case!
+ (..custom [($_ <>.and
+ <s>.any
+ <s>.any
+ (<>.some (<s>.tuple ($_ <>.and
+ (<s>.tuple (<>.many <s>.i64))
+ <s>.any))))
+ (function (_ extension_name phase archive [input else conditionals])
+ (do {! /////.monad}
+ [inputG (phase archive input)
+ elseG (phase archive else)
+ @input (\ ! map _.var (generation.gensym "input"))
+ conditionalsG (: (Operation (List [(Expression Any)
+ (Expression Any)]))
+ (monad.map ! (function (_ [chars branch])
+ (do !
+ [branchG (phase archive branch)]
+ (wrap [(|> chars
+ (list\map (|>> .int _.int (_.= @input)))
+ (list\fold (function (_ clause total)
+ (if (is? _.none total)
+ clause
+ (_.or clause total)))
+ _.none))
+ branchG])))
+ conditionals))
+ #let [closure (_.lambda (list @input)
+ (list\fold (function (_ [test then] else)
+ (_.? test then else))
+ elseG
+ conditionalsG))]]
+ (wrap (_.apply/* closure (list inputG)))))]))
+
+(def: lux_procs
+ Bundle
+ (|> /.empty
+ (/.install "syntax char case!" lux::syntax_char_case!)
+ (/.install "is" (binary (product.uncurry _.is)))
+ (/.install "try" (unary //runtime.lux::try))))
+
+(def: (capped operation parameter subject)
+ (-> (-> (Expression Any) (Expression Any) (Expression Any))
+ (-> (Expression Any) (Expression Any) (Expression Any)))
+ (//runtime.i64::64 (operation parameter subject)))
+
+(def: i64_procs
+ Bundle
+ (<| (/.prefix "i64")
+ (|> /.empty
+ (/.install "and" (binary (product.uncurry //runtime.i64::and)))
+ (/.install "or" (binary (product.uncurry //runtime.i64::or)))
+ (/.install "xor" (binary (product.uncurry //runtime.i64::xor)))
+ (/.install "left-shift" (binary (product.uncurry //runtime.i64::left_shift)))
+ (/.install "right-shift" (binary (product.uncurry //runtime.i64::right_shift)))
+
+ (/.install "<" (binary (product.uncurry _.<)))
+ (/.install "=" (binary (product.uncurry _.=)))
+ (/.install "+" (binary (product.uncurry (..capped _.+))))
+ (/.install "-" (binary (product.uncurry (..capped _.-))))
+ (/.install "*" (binary (product.uncurry (..capped _.*))))
+ (/.install "/" (binary (product.uncurry //runtime.i64::division)))
+ (/.install "%" (binary (product.uncurry //runtime.i64::remainder)))
+ (/.install "f64" (unary _.float/1))
+ (/.install "char" (unary //runtime.i64::char))
+ )))
+
+(def: f64_procs
+ Bundle
+ (<| (/.prefix "f64")
+ (|> /.empty
+ (/.install "+" (binary (product.uncurry _.+)))
+ (/.install "-" (binary (product.uncurry _.-)))
+ (/.install "*" (binary (product.uncurry _.*)))
+ (/.install "/" (binary (product.uncurry //runtime.f64::/)))
+ (/.install "%" (binary (function (_ [parameter subject])
+ (|> (_.__import__/1 (_.unicode "math"))
+ (_.do "fmod" (list subject parameter))))))
+ (/.install "=" (binary (product.uncurry _.=)))
+ (/.install "<" (binary (product.uncurry _.<)))
+ (/.install "i64" (unary _.int/1))
+ (/.install "encode" (unary _.repr/1))
+ (/.install "decode" (unary //runtime.f64::decode)))))
+
+(def: (text::clip [paramO extraO subjectO])
+ (Trinary (Expression Any))
+ (//runtime.text::clip paramO extraO subjectO))
+
+(def: (text::index [startO partO textO])
+ (Trinary (Expression Any))
+ (//runtime.text::index startO partO textO))
+
+(def: text_procs
+ Bundle
+ (<| (/.prefix "text")
+ (|> /.empty
+ (/.install "=" (binary (product.uncurry _.=)))
+ (/.install "<" (binary (product.uncurry _.<)))
+ (/.install "concat" (binary (product.uncurry (function.flip _.+))))
+ (/.install "index" (trinary ..text::index))
+ (/.install "size" (unary _.len/1))
+ (/.install "char" (binary (product.uncurry //runtime.text::char)))
+ (/.install "clip" (trinary ..text::clip))
+ )))
+
+(def: io_procs
+ Bundle
+ (<| (/.prefix "io")
+ (|> /.empty
+ (/.install "log" (unary //runtime.io::log!))
+ (/.install "error" (unary //runtime.io::throw!)))))
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "lux")
+ (|> lux_procs
+ (dictionary.merge i64_procs)
+ (dictionary.merge f64_procs)
+ (dictionary.merge text_procs)
+ (dictionary.merge io_procs)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux
new file mode 100644
index 000000000..6612cda07
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux
@@ -0,0 +1,165 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ [collection
+ ["." dictionary]
+ ["." list]]]
+ [target
+ ["_" python (#+ Expression SVar)]]]]
+ ["." // #_
+ ["#." common (#+ custom)]
+ ["//#" /// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["//" python #_
+ ["#." runtime (#+ Operation Phase Handler Bundle
+ with_vars)]]]
+ ["/#" // #_
+ ["." generation]
+ ["//#" /// #_
+ ["#." phase]]]]]])
+
+(def: (array::new size)
+ (Unary (Expression Any))
+ (|> (list _.none)
+ _.list
+ (_.* size)))
+
+(def: array::length
+ (Unary (Expression Any))
+ (|>> _.len/1 //runtime.i64::64))
+
+(def: (array::read [indexG arrayG])
+ (Binary (Expression Any))
+ (_.nth indexG arrayG))
+
+(def: (array::write [indexG valueG arrayG])
+ (Trinary (Expression Any))
+ (//runtime.array::write indexG valueG arrayG))
+
+(def: (array::delete [indexG arrayG])
+ (Binary (Expression Any))
+ (//runtime.array::write indexG _.none arrayG))
+
+(def: array
+ Bundle
+ (<| (/.prefix "array")
+ (|> /.empty
+ (/.install "new" (unary array::new))
+ (/.install "length" (unary array::length))
+ (/.install "read" (binary array::read))
+ (/.install "write" (trinary array::write))
+ (/.install "delete" (binary array::delete))
+ )))
+
+(def: object::get
+ Handler
+ (custom
+ [($_ <>.and <s>.text <s>.any)
+ (function (_ extension phase archive [fieldS objectS])
+ (do ////////phase.monad
+ [objectG (phase archive objectS)]
+ (wrap (_.the fieldS objectG))))]))
+
+(def: object::do
+ Handler
+ (custom
+ [($_ <>.and <s>.text <s>.any (<>.some <s>.any))
+ (function (_ extension phase archive [methodS objectS inputsS])
+ (do {! ////////phase.monad}
+ [objectG (phase archive objectS)
+ inputsG (monad.map ! (phase archive) inputsS)]
+ (wrap (_.do methodS inputsG objectG))))]))
+
+(template [<!> <?> <unit>]
+ [(def: <!> (Nullary (Expression Any)) (function.constant <unit>))
+ (def: <?> (Unary (Expression Any)) (_.= <unit>))]
+
+ [object::none object::none? _.none]
+ )
+
+(def: object
+ Bundle
+ (<| (/.prefix "object")
+ (|> /.empty
+ (/.install "get" object::get)
+ (/.install "do" object::do)
+ (/.install "none" (nullary object::none))
+ (/.install "none?" (unary object::none?))
+ )))
+
+(def: python::constant
+ (custom
+ [<s>.text
+ (function (_ extension phase archive name)
+ (do ////////phase.monad
+ []
+ (wrap (_.var name))))]))
+
+(def: python::import
+ (custom
+ [<s>.text
+ (function (_ extension phase archive module)
+ (do ////////phase.monad
+ []
+ (wrap (_.apply/* (_.var "__import__") (list (_.string module))))))]))
+
+(def: python::apply
+ (custom
+ [($_ <>.and <s>.any (<>.some <s>.any))
+ (function (_ extension phase archive [abstractionS inputsS])
+ (do {! ////////phase.monad}
+ [abstractionG (phase archive abstractionS)
+ inputsG (monad.map ! (phase archive) inputsS)]
+ (wrap (_.apply/* abstractionG inputsG))))]))
+
+(def: python::function
+ (custom
+ [($_ <>.and <s>.i64 <s>.any)
+ (function (_ extension phase archive [arity abstractionS])
+ (do {! ////////phase.monad}
+ [abstractionG (phase archive abstractionS)
+ #let [variable (: (-> Text (Operation SVar))
+ (|>> generation.gensym
+ (\ ! map _.var)))]
+ g!inputs (monad.map ! (function (_ _) (variable "input"))
+ (list.repeat (.nat arity) []))]
+ (wrap (_.lambda g!inputs
+ (case (.nat arity)
+ 0 (_.apply/1 abstractionG //runtime.unit)
+ 1 (_.apply/* abstractionG g!inputs)
+ _ (_.apply/1 abstractionG (_.list g!inputs)))))))]))
+
+(def: python::exec
+ (custom
+ [($_ <>.and <s>.any <s>.any)
+ (function (_ extension phase archive [codeS globalsS])
+ (do {! ////////phase.monad}
+ [codeG (phase archive codeS)
+ globalsG (phase archive globalsS)]
+ (wrap (//runtime.lux::exec codeG globalsG))))]))
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "python")
+ (|> /.empty
+ (dictionary.merge ..array)
+ (dictionary.merge ..object)
+
+ (/.install "constant" python::constant)
+ (/.install "import" python::import)
+ (/.install "apply" python::apply)
+ (/.install "function" python::function)
+ (/.install "exec" python::exec)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r.lux
new file mode 100644
index 000000000..7ca8195f7
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r.lux
@@ -0,0 +1,18 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]]
+ ["." / #_
+ ["#." common]
+ ["#." host]
+ [////
+ [generation
+ [r
+ [runtime (#+ Bundle)]]]]])
+
+(def: #export bundle
+ Bundle
+ (dictionary.merge /common.bundle
+ /host.bundle))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux
new file mode 100644
index 000000000..36238f9e3
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux
@@ -0,0 +1,179 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary]
+ ["." set]
+ ["." list ("#\." functor fold)]]]
+ [math
+ [number
+ ["f" frac]]]
+ ["@" target
+ ["_" r (#+ Expression)]]]]
+ ["." //// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["." reference]
+ ["//" r #_
+ ["#." runtime (#+ Operation Phase Handler Bundle Generator)]
+ ["#." case]]]
+ [//
+ ["." synthesis (#+ %synthesis)]
+ ["." generation]
+ [///
+ ["#" phase]]]]])
+
+(def: #export (custom [parser handler])
+ (All [s]
+ (-> [(Parser s)
+ (-> Text (Generator s))]
+ Handler))
+ (function (_ extension_name phase archive input)
+ (case (<s>.run parser input)
+ (#try.Success input')
+ (handler extension_name phase archive input')
+
+ (#try.Failure error)
+ (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
+
+## (template: (!unary function)
+## (|>> list _.apply/* (|> (_.constant function))))
+
+## ## ## TODO: Get rid of this ASAP
+## ## (def: lux::syntax_char_case!
+## ## (..custom [($_ <>.and
+## ## <s>.any
+## ## <s>.any
+## ## (<>.some (<s>.tuple ($_ <>.and
+## ## (<s>.tuple (<>.many <s>.i64))
+## ## <s>.any))))
+## ## (function (_ extension_name phase archive [input else conditionals])
+## ## (do {! /////.monad}
+## ## [@input (\ ! map _.var (generation.gensym "input"))
+## ## inputG (phase archive input)
+## ## elseG (phase archive else)
+## ## conditionalsG (: (Operation (List [Expression Expression]))
+## ## (monad.map ! (function (_ [chars branch])
+## ## (do !
+## ## [branchG (phase archive branch)]
+## ## (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or)
+## ## branchG])))
+## ## conditionals))]
+## ## (wrap (_.let (list [@input inputG])
+## ## (list (list\fold (function (_ [test then] else)
+## ## (_.if test then else))
+## ## elseG
+## ## conditionalsG))))))]))
+
+## (def: lux_procs
+## Bundle
+## (|> /.empty
+## ## (/.install "syntax char case!" lux::syntax_char_case!)
+## (/.install "is" (binary _.eq/2))
+## ## (/.install "try" (unary //runtime.lux//try))
+## ))
+
+## ## (def: (capped operation parameter subject)
+## ## (-> (-> Expression Expression Expression)
+## ## (-> Expression Expression Expression))
+## ## (//runtime.i64//64 (operation parameter subject)))
+
+(def: i64_procs
+ Bundle
+ (<| (/.prefix "i64")
+ (|> /.empty
+ ## (/.install "and" (binary _.logand/2))
+ ## (/.install "or" (binary _.logior/2))
+ ## (/.install "xor" (binary _.logxor/2))
+ ## (/.install "left-shift" (binary _.ash/2))
+ ## (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift)))
+ ## (/.install "=" (binary _.=/2))
+ ## (/.install "<" (binary _.</2))
+ ## (/.install "+" (binary _.+/2))
+ ## (/.install "-" (binary _.-/2))
+ ## (/.install "*" (binary _.*/2))
+ ## (/.install "/" (binary _.floor/2))
+ ## (/.install "%" (binary _.rem/2))
+ ## (/.install "f64" (unary (_.//2 (_.float +1.0))))
+ (/.install "char" (unary (|>> //runtime.i64_low _.intToUtf8/1)))
+ )))
+
+## (def: f64_procs
+## Bundle
+## (<| (/.prefix "f64")
+## (|> /.empty
+## ## (/.install "=" (binary (product.uncurry _.=/2)))
+## ## (/.install "<" (binary (product.uncurry _.</2)))
+## ## (/.install "+" (binary (product.uncurry _.+/2)))
+## ## (/.install "-" (binary (product.uncurry _.-/2)))
+## ## (/.install "*" (binary (product.uncurry _.*/2)))
+## ## (/.install "/" (binary (product.uncurry _.//2)))
+## ## (/.install "%" (binary (product.uncurry _.rem/2)))
+## ## (/.install "i64" (unary _.truncate/1))
+## (/.install "encode" (unary _.write-to-string/1))
+## ## (/.install "decode" (unary //runtime.f64//decode))
+## )))
+
+## (def: (text//index [offset sub text])
+## (Trinary (Expression Any))
+## (//runtime.text//index offset sub text))
+
+## (def: (text//clip [offset length text])
+## (Trinary (Expression Any))
+## (//runtime.text//clip offset length text))
+
+## (def: (text//char [index text])
+## (Binary (Expression Any))
+## (_.char-code/1 (_.char/2 [text index])))
+
+(def: text_procs
+ Bundle
+ (<| (/.prefix "text")
+ (|> /.empty
+ ## (/.install "=" (binary _.string=/2))
+ ## (/.install "<" (binary (product.uncurry _.string<?/2)))
+ (/.install "concat" (binary _.paste/2))
+ ## (/.install "index" (trinary ..text//index))
+ ## (/.install "size" (unary _.length/1))
+ ## (/.install "char" (binary ..text//char))
+ ## (/.install "clip" (trinary ..text//clip))
+ )))
+
+## (def: (io//log! message)
+## (Unary (Expression Any))
+## (_.progn (list (_.write-line/1 message)
+## //runtime.unit)))
+
+## (def: io_procs
+## Bundle
+## (<| (/.prefix "io")
+## (|> /.empty
+## (/.install "log" (unary ..io//log!))
+## (/.install "error" (unary _.error/1))
+## )))
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "lux")
+ (|> /.empty
+ ## (dictionary.merge lux_procs)
+ (dictionary.merge i64_procs)
+ ## (dictionary.merge f64_procs)
+ (dictionary.merge text_procs)
+ ## (dictionary.merge io_procs)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux
new file mode 100644
index 000000000..37390f799
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux
@@ -0,0 +1,40 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ [collection
+ ["." dictionary]
+ ["." list]]
+ [text
+ ["%" format (#+ format)]]]
+ [target
+ ["_" r (#+ Var Expression)]]]]
+ ["." // #_
+ ["#." common (#+ custom)]
+ ["//#" /// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["." reference]
+ ["//" r #_
+ ["#." runtime (#+ Operation Phase Handler Bundle
+ with_vars)]]]
+ ["/#" // #_
+ ["." generation]
+ ["//#" /// #_
+ ["#." phase]]]]]])
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "r")
+ (|> /.empty
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux
new file mode 100644
index 000000000..417ccf847
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux
@@ -0,0 +1,18 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]]
+ ["." / #_
+ ["#." common]
+ ["#." host]
+ [////
+ [generation
+ [ruby
+ [runtime (#+ Bundle)]]]]])
+
+(def: #export bundle
+ Bundle
+ (dictionary.merge /common.bundle
+ /host.bundle))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux
new file mode 100644
index 000000000..4f2cd3291
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux
@@ -0,0 +1,186 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary]
+ ["." list ("#\." functor fold)]]]
+ [math
+ [number
+ ["f" frac]]]
+ [target
+ ["_" ruby (#+ Expression)]]]]
+ ["." //// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["//" ruby #_
+ ["#." runtime (#+ Operation Phase Handler Bundle Generator)]]]
+ [//
+ [synthesis (#+ %synthesis)]
+ ["." generation]
+ [///
+ ["#" phase]]]]])
+
+(def: #export (custom [parser handler])
+ (All [s]
+ (-> [(Parser s)
+ (-> Text (Generator s))]
+ Handler))
+ (function (_ extension_name phase archive input)
+ (case (<s>.run parser input)
+ (#try.Success input')
+ (handler extension_name phase archive input')
+
+ (#try.Failure error)
+ (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
+
+## TODO: Get rid of this ASAP
+(def: lux::syntax_char_case!
+ (..custom [($_ <>.and
+ <s>.any
+ <s>.any
+ (<>.some (<s>.tuple ($_ <>.and
+ (<s>.tuple (<>.many <s>.i64))
+ <s>.any))))
+ (function (_ extension_name phase archive [input else conditionals])
+ (do {! /////.monad}
+ [inputG (phase archive input)
+ elseG (phase archive else)
+ @input (\ ! map _.local (generation.gensym "input"))
+ conditionalsG (: (Operation (List [Expression Expression]))
+ (monad.map ! (function (_ [chars branch])
+ (do !
+ [branchG (phase archive branch)]
+ (wrap [(|> chars
+ (list\map (|>> .int _.int (_.= @input)))
+ (list\fold (function (_ clause total)
+ (if (is? _.nil total)
+ clause
+ (_.or clause total)))
+ _.nil))
+ branchG])))
+ conditionals))
+ #let [closure (_.lambda #.None (list @input)
+ (list\fold (function (_ [test then] else)
+ (_.if test (_.return then) else))
+ (_.return elseG)
+ conditionalsG))]]
+ (wrap (_.apply_lambda/* (list inputG) closure))))]))
+
+(def: lux_procs
+ Bundle
+ (|> /.empty
+ (/.install "syntax char case!" lux::syntax_char_case!)
+ (/.install "is" (binary (function (_ [reference subject])
+ (_.do "equal?" (list reference) subject))))
+ (/.install "try" (unary //runtime.lux//try))))
+
+(def: (capped operation parameter subject)
+ (-> (-> Expression Expression Expression)
+ (-> Expression Expression Expression))
+ (//runtime.i64//64 (operation parameter subject)))
+
+(def: i64_procs
+ Bundle
+ (<| (/.prefix "i64")
+ (|> /.empty
+ (/.install "and" (binary (product.uncurry //runtime.i64//and)))
+ (/.install "or" (binary (product.uncurry //runtime.i64//or)))
+ (/.install "xor" (binary (product.uncurry //runtime.i64//xor)))
+ (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift)))
+ (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift)))
+
+ (/.install "<" (binary (product.uncurry _.<)))
+ (/.install "=" (binary (product.uncurry _.=)))
+ (/.install "+" (binary (product.uncurry (..capped _.+))))
+ (/.install "-" (binary (product.uncurry (..capped _.-))))
+ (/.install "*" (binary (product.uncurry (..capped _.*))))
+ (/.install "/" (binary (product.uncurry //runtime.i64//division)))
+ (/.install "%" (binary (function (_ [parameter subject])
+ (_.do "remainder" (list parameter) subject))))
+
+ (/.install "f64" (unary (_./ (_.float +1.0))))
+ (/.install "char" (unary (_.do "chr" (list (_.string "UTF-8")))))
+ )))
+
+(def: f64_procs
+ Bundle
+ (<| (/.prefix "f64")
+ (|> /.empty
+ (/.install "+" (binary (product.uncurry _.+)))
+ (/.install "-" (binary (product.uncurry _.-)))
+ (/.install "*" (binary (product.uncurry _.*)))
+ (/.install "/" (binary (product.uncurry _./)))
+ (/.install "%" (binary (function (_ [parameter subject])
+ (_.do "remainder" (list parameter) subject))))
+ (/.install "=" (binary (product.uncurry _.=)))
+ (/.install "<" (binary (product.uncurry _.<)))
+ (/.install "i64" (unary (_.do "floor" (list))))
+ (/.install "encode" (unary (_.do "to_s" (list))))
+ (/.install "decode" (unary //runtime.f64//decode)))))
+
+(def: (text//char [subjectO paramO])
+ (Binary Expression)
+ (//runtime.text//char subjectO paramO))
+
+(def: (text//clip [paramO extraO subjectO])
+ (Trinary Expression)
+ (//runtime.text//clip paramO extraO subjectO))
+
+(def: (text//index [startO partO textO])
+ (Trinary Expression)
+ (//runtime.text//index textO partO startO))
+
+(def: text_procs
+ Bundle
+ (<| (/.prefix "text")
+ (|> /.empty
+ (/.install "=" (binary (product.uncurry _.=)))
+ (/.install "<" (binary (product.uncurry _.<)))
+ (/.install "concat" (binary (product.uncurry (function.flip _.+))))
+ (/.install "index" (trinary text//index))
+ (/.install "size" (unary (_.the "length")))
+ (/.install "char" (binary (product.uncurry //runtime.text//char)))
+ (/.install "clip" (trinary text//clip))
+ )))
+
+(def: (io//log! messageG)
+ (Unary Expression)
+ (|> (_.print/2 messageG (_.string text.new_line))
+ (_.or //runtime.unit)))
+
+(def: io//error!
+ (Unary Expression)
+ _.raise)
+
+(def: io_procs
+ Bundle
+ (<| (/.prefix "io")
+ (|> /.empty
+ (/.install "log" (unary ..io//log!))
+ (/.install "error" (unary ..io//error!))
+ )))
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "lux")
+ (|> lux_procs
+ (dictionary.merge ..i64_procs)
+ (dictionary.merge ..f64_procs)
+ (dictionary.merge ..text_procs)
+ (dictionary.merge ..io_procs)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux
new file mode 100644
index 000000000..6f538b8dd
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux
@@ -0,0 +1,136 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ [collection
+ ["." dictionary]
+ ["." list]]
+ [text
+ ["%" format (#+ format)]]]
+ [target
+ ["_" ruby (#+ Var Expression)]]]]
+ ["." // #_
+ ["#." common (#+ custom)]
+ ["//#" /// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["." reference]
+ ["//" ruby #_
+ ["#." runtime (#+ Operation Phase Handler Bundle
+ with_vars)]]]
+ ["/#" // #_
+ ["." generation]
+ ["//#" /// #_
+ ["#." phase]]]]]])
+
+(def: (array::new [size])
+ (Unary Expression)
+ (_.do "new" (list size) (_.local "Array")))
+
+(def: array::length
+ (Unary Expression)
+ (_.the "size"))
+
+(def: (array::read [indexG arrayG])
+ (Binary Expression)
+ (_.nth indexG arrayG))
+
+(def: (array::write [indexG valueG arrayG])
+ (Trinary Expression)
+ (//runtime.array//write indexG valueG arrayG))
+
+(def: (array::delete [indexG arrayG])
+ (Binary Expression)
+ (//runtime.array//write indexG _.nil arrayG))
+
+(def: array
+ Bundle
+ (<| (/.prefix "array")
+ (|> /.empty
+ (/.install "new" (unary array::new))
+ (/.install "length" (unary array::length))
+ (/.install "read" (binary array::read))
+ (/.install "write" (trinary array::write))
+ (/.install "delete" (binary array::delete))
+ )))
+
+(def: object::get
+ Handler
+ (custom
+ [($_ <>.and <s>.text <s>.any)
+ (function (_ extension phase archive [fieldS objectS])
+ (do ////////phase.monad
+ [objectG (phase archive objectS)]
+ (wrap (_.the fieldS objectG))))]))
+
+(def: object::do
+ Handler
+ (custom
+ [($_ <>.and <s>.text <s>.any (<>.some <s>.any))
+ (function (_ extension phase archive [methodS objectS inputsS])
+ (do {! ////////phase.monad}
+ [objectG (phase archive objectS)
+ inputsG (monad.map ! (phase archive) inputsS)]
+ (wrap (_.do methodS inputsG objectG))))]))
+
+(template [<!> <?> <unit>]
+ [(def: <!> (Nullary Expression) (function.constant <unit>))
+ (def: <?> (Unary Expression) (_.= <unit>))]
+
+ [object::nil object::nil? _.nil]
+ )
+
+(def: object
+ Bundle
+ (<| (/.prefix "object")
+ (|> /.empty
+ (/.install "get" object::get)
+ (/.install "do" object::do)
+ (/.install "nil" (nullary object::nil))
+ (/.install "nil?" (unary object::nil?))
+ )))
+
+(def: ruby::constant
+ (custom
+ [<s>.text
+ (function (_ extension phase archive name)
+ (\ ////////phase.monad wrap (_.local name)))]))
+
+(def: ruby::apply
+ (custom
+ [($_ <>.and <s>.any (<>.some <s>.any))
+ (function (_ extension phase archive [abstractionS inputsS])
+ (do {! ////////phase.monad}
+ [abstractionG (phase archive abstractionS)
+ inputsG (monad.map ! (phase archive) inputsS)]
+ (wrap (_.apply/* inputsG abstractionG))))]))
+
+(def: ruby::import
+ (custom
+ [<s>.text
+ (function (_ extension phase archive module)
+ (\ ////////phase.monad wrap
+ (_.require/1 (_.string module))))]))
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "ruby")
+ (|> /.empty
+ (dictionary.merge ..array)
+ (dictionary.merge ..object)
+
+ (/.install "constant" ruby::constant)
+ (/.install "apply" ruby::apply)
+ (/.install "import" ruby::import)
+ (/.install "script universe" (nullary (function.constant (_.bool reference.universe))))
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux
new file mode 100644
index 000000000..7245ac4f6
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux
@@ -0,0 +1,18 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]]
+ ["." / #_
+ ["#." common]
+ ["#." host]
+ [////
+ [generation
+ [scheme
+ [runtime (#+ Bundle)]]]]])
+
+(def: #export bundle
+ Bundle
+ (dictionary.merge /common.bundle
+ /host.bundle))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux
new file mode 100644
index 000000000..17df72ac2
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux
@@ -0,0 +1,175 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary]
+ ["." set]
+ ["." list ("#\." functor fold)]]]
+ [math
+ [number
+ ["f" frac]]]
+ ["@" target
+ ["_" scheme (#+ Expression)]]]]
+ ["." //// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["." reference]
+ ["//" scheme #_
+ ["#." runtime (#+ Operation Phase Handler Bundle Generator)]
+ ["#." case]]]
+ [//
+ ["." synthesis (#+ %synthesis)]
+ ["." generation]
+ [///
+ ["#" phase]]]]])
+
+(def: #export (custom [parser handler])
+ (All [s]
+ (-> [(Parser s)
+ (-> Text (Generator s))]
+ Handler))
+ (function (_ extension_name phase archive input)
+ (case (<s>.run parser input)
+ (#try.Success input')
+ (handler extension_name phase archive input')
+
+ (#try.Failure error)
+ (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
+
+(template: (!unary function)
+ (|>> list _.apply/* (|> (_.constant function))))
+
+## TODO: Get rid of this ASAP
+(def: lux::syntax_char_case!
+ (..custom [($_ <>.and
+ <s>.any
+ <s>.any
+ (<>.some (<s>.tuple ($_ <>.and
+ (<s>.tuple (<>.many <s>.i64))
+ <s>.any))))
+ (function (_ extension_name phase archive [input else conditionals])
+ (do {! /////.monad}
+ [@input (\ ! map _.var (generation.gensym "input"))
+ inputG (phase archive input)
+ elseG (phase archive else)
+ conditionalsG (: (Operation (List [Expression Expression]))
+ (monad.map ! (function (_ [chars branch])
+ (do !
+ [branchG (phase archive branch)]
+ (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or)
+ branchG])))
+ conditionals))]
+ (wrap (_.let (list [@input inputG])
+ (list\fold (function (_ [test then] else)
+ (_.if test then else))
+ elseG
+ conditionalsG)))))]))
+
+(def: lux_procs
+ Bundle
+ (|> /.empty
+ (/.install "syntax char case!" lux::syntax_char_case!)
+ (/.install "is" (binary (product.uncurry _.eq?/2)))
+ (/.install "try" (unary //runtime.lux//try))
+ ))
+
+(def: (capped operation parameter subject)
+ (-> (-> Expression Expression Expression)
+ (-> Expression Expression Expression))
+ (//runtime.i64//64 (operation parameter subject)))
+
+(def: i64_procs
+ Bundle
+ (<| (/.prefix "i64")
+ (|> /.empty
+ (/.install "and" (binary (product.uncurry //runtime.i64//and)))
+ (/.install "or" (binary (product.uncurry //runtime.i64//or)))
+ (/.install "xor" (binary (product.uncurry //runtime.i64//xor)))
+ (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift)))
+ (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift)))
+ (/.install "=" (binary (product.uncurry _.=/2)))
+ (/.install "<" (binary (product.uncurry _.</2)))
+ (/.install "+" (binary (product.uncurry (..capped _.+/2))))
+ (/.install "-" (binary (product.uncurry (..capped _.-/2))))
+ (/.install "*" (binary (product.uncurry (..capped _.*/2))))
+ (/.install "/" (binary (product.uncurry //runtime.i64//division)))
+ (/.install "%" (binary (product.uncurry _.remainder/2)))
+ (/.install "f64" (unary (_.//2 (_.float +1.0))))
+ (/.install "char" (unary (|>> _.integer->char/1 (_.make-string/2 (_.int +1)))))
+ )))
+
+(def: f64_procs
+ Bundle
+ (<| (/.prefix "f64")
+ (|> /.empty
+ (/.install "=" (binary (product.uncurry _.=/2)))
+ (/.install "<" (binary (product.uncurry _.</2)))
+ (/.install "+" (binary (product.uncurry _.+/2)))
+ (/.install "-" (binary (product.uncurry _.-/2)))
+ (/.install "*" (binary (product.uncurry _.*/2)))
+ (/.install "/" (binary (product.uncurry _.//2)))
+ (/.install "%" (binary (product.uncurry _.remainder/2)))
+ (/.install "i64" (unary _.truncate/1))
+ (/.install "encode" (unary _.number->string/1))
+ (/.install "decode" (unary //runtime.f64//decode)))))
+
+(def: (text//index [offset sub text])
+ (Trinary Expression)
+ (//runtime.text//index offset sub text))
+
+(def: (text//clip [paramO extraO subjectO])
+ (Trinary Expression)
+ (//runtime.text//clip paramO extraO subjectO))
+
+(def: text_procs
+ Bundle
+ (<| (/.prefix "text")
+ (|> /.empty
+ (/.install "=" (binary (product.uncurry _.string=?/2)))
+ (/.install "<" (binary (product.uncurry _.string<?/2)))
+ (/.install "concat" (binary (product.uncurry _.string-append/2)))
+ (/.install "index" (trinary ..text//index))
+ (/.install "size" (unary _.string-length/1))
+ (/.install "char" (binary (product.uncurry //runtime.text//char)))
+ (/.install "clip" (trinary ..text//clip))
+ )))
+
+(def: (io//log! message)
+ (Unary Expression)
+ (_.begin (list (_.display/1 message)
+ (_.display/1 (_.string text.new_line))
+ //runtime.unit)))
+
+(def: io_procs
+ Bundle
+ (<| (/.prefix "io")
+ (|> /.empty
+ (/.install "log" (unary ..io//log!))
+ (/.install "error" (unary _.raise/1))
+ )))
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "lux")
+ (|> /.empty
+ (dictionary.merge lux_procs)
+ (dictionary.merge i64_procs)
+ (dictionary.merge f64_procs)
+ (dictionary.merge text_procs)
+ (dictionary.merge io_procs)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux
new file mode 100644
index 000000000..e67e05db4
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux
@@ -0,0 +1,109 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ [collection
+ ["." dictionary]
+ ["." list]]
+ [text
+ ["%" format (#+ format)]]]
+ [target
+ ["_" scheme (#+ Var Expression)]]]]
+ ["." // #_
+ ["#." common (#+ custom)]
+ ["//#" /// #_
+ ["/" bundle]
+ ["/#" // #_
+ ["." extension]
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ ["." reference]
+ ["//" scheme #_
+ ["#." runtime (#+ Operation Phase Handler Bundle
+ with_vars)]]]
+ ["/#" // #_
+ ["." generation]
+ ["//#" /// #_
+ ["#." phase]]]]]])
+
+(def: (array::new size)
+ (Unary Expression)
+ (_.make-vector/2 size _.nil))
+
+(def: array::length
+ (Unary Expression)
+ _.vector-length/1)
+
+(def: (array::read [indexG arrayG])
+ (Binary Expression)
+ (_.vector-ref/2 arrayG indexG))
+
+(def: (array::write [indexG valueG arrayG])
+ (Trinary Expression)
+ (//runtime.array//write indexG valueG arrayG))
+
+(def: (array::delete [indexG arrayG])
+ (Binary Expression)
+ (//runtime.array//write indexG _.nil arrayG))
+
+(def: array
+ Bundle
+ (<| (/.prefix "array")
+ (|> /.empty
+ (/.install "new" (unary array::new))
+ (/.install "length" (unary array::length))
+ (/.install "read" (binary array::read))
+ (/.install "write" (trinary array::write))
+ (/.install "delete" (binary array::delete))
+ )))
+
+(template [<!> <?> <unit>]
+ [(def: <!> (Nullary Expression) (function.constant <unit>))
+ (def: <?> (Unary Expression) (_.eq?/2 <unit>))]
+
+ [object::nil object::nil? _.nil]
+ )
+
+(def: object
+ Bundle
+ (<| (/.prefix "object")
+ (|> /.empty
+ (/.install "nil" (nullary object::nil))
+ (/.install "nil?" (unary object::nil?))
+ )))
+
+(def: scheme::constant
+ (custom
+ [<s>.text
+ (function (_ extension phase archive name)
+ (do ////////phase.monad
+ []
+ (wrap (_.var name))))]))
+
+(def: scheme::apply
+ (custom
+ [($_ <>.and <s>.any (<>.some <s>.any))
+ (function (_ extension phase archive [abstractionS inputsS])
+ (do {! ////////phase.monad}
+ [abstractionG (phase archive abstractionS)
+ inputsG (monad.map ! (phase archive) inputsS)]
+ (wrap (_.apply/* inputsG abstractionG))))]))
+
+(def: #export bundle
+ Bundle
+ (<| (/.prefix "scheme")
+ (|> /.empty
+ (dictionary.merge ..array)
+ (dictionary.merge ..object)
+
+ (/.install "constant" scheme::constant)
+ (/.install "apply" scheme::apply)
+ (/.install "script universe" (nullary (function.constant (_.bool reference.universe))))
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/synthesis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/synthesis.lux
new file mode 100644
index 000000000..7e9e85d6e
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/synthesis.lux
@@ -0,0 +1,11 @@
+(.module:
+ [library
+ [lux #*]]
+ [//
+ ["." bundle]
+ [///
+ [synthesis (#+ Bundle)]]])
+
+(def: #export bundle
+ Bundle
+ bundle.empty)
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux
new file mode 100644
index 000000000..972e318c2
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux
@@ -0,0 +1,57 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]]]
+ ["." / #_
+ [runtime (#+ Phase)]
+ ["#." primitive]
+ ["#." structure]
+ ["#." reference]
+ ["#." case]
+ ["#." loop]
+ ["#." function]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." extension]
+ ["/#" // #_
+ [analysis (#+)]
+ ["#." synthesis]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]
+ [reference (#+)
+ [variable (#+)]]]]]]])
+
+(def: #export (generate archive synthesis)
+ Phase
+ (case synthesis
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (//////phase\wrap (<generator> value))])
+ ([////synthesis.bit /primitive.bit]
+ [////synthesis.i64 /primitive.i64]
+ [////synthesis.f64 /primitive.f64]
+ [////synthesis.text /primitive.text])
+
+ (#////synthesis.Reference value)
+ (//reference.reference /reference.system archive value)
+
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (<generator> generate archive value)])
+ ([////synthesis.variant /structure.variant]
+ [////synthesis.tuple /structure.tuple]
+ [////synthesis.branch/let /case.let]
+ [////synthesis.branch/if /case.if]
+ [////synthesis.branch/get /case.get]
+ [////synthesis.function/apply /function.apply]
+
+ [////synthesis.branch/case /case.case]
+ [////synthesis.loop/scope /loop.scope]
+ [////synthesis.loop/recur /loop.recur]
+ [////synthesis.function/abstraction /function.function])
+
+ (#////synthesis.Extension extension)
+ (///extension.apply archive generate extension)
+ ))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux
new file mode 100644
index 000000000..2425e2cb4
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux
@@ -0,0 +1,262 @@
+(.module:
+ [library
+ [lux (#- case let if)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold monoid)]
+ ["." set]]]
+ [math
+ [number
+ ["n" nat]]]
+ [target
+ ["_" common_lisp (#+ Expression Var/1)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." reference]
+ ["#." primitive]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." synthesis #_
+ ["#/." case]]
+ ["/#" // #_
+ ["#." synthesis (#+ Member Synthesis Path)]
+ ["#." generation]
+ ["//#" /// #_
+ [reference
+ ["#." variable (#+ Register)]]
+ ["#." phase ("#\." monad)]
+ [meta
+ [archive (#+ Archive)]]]]]]])
+
+(def: #export register
+ (-> Register Var/1)
+ (|>> (///reference.local //reference.system) :assume))
+
+(def: #export capture
+ (-> Register Var/1)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: #export (let expression archive [valueS register bodyS])
+ (Generator [Synthesis Register Synthesis])
+ (do ///////phase.monad
+ [valueG (expression archive valueS)
+ bodyG (expression archive bodyS)]
+ (wrap (_.let (list [(..register register) valueG])
+ (list bodyG)))))
+
+(def: #export (if expression archive [testS thenS elseS])
+ (Generator [Synthesis Synthesis Synthesis])
+ (do ///////phase.monad
+ [testG (expression archive testS)
+ thenG (expression archive thenS)
+ elseG (expression archive elseS)]
+ (wrap (_.if testG thenG elseG))))
+
+(def: #export (get expression archive [pathP valueS])
+ (Generator [(List Member) Synthesis])
+ (do ///////phase.monad
+ [valueG (expression archive valueS)]
+ (wrap (list\fold (function (_ side source)
+ (.let [method (.case side
+ (^template [<side> <accessor>]
+ [(<side> lefts)
+ (<accessor> (_.int (.int lefts)))])
+ ([#.Left //runtime.tuple//left]
+ [#.Right //runtime.tuple//right]))]
+ (method source)))
+ valueG
+ pathP))))
+
+(def: @savepoint (_.var "lux_pm_savepoint"))
+(def: @cursor (_.var "lux_pm_cursor"))
+(def: @temp (_.var "lux_pm_temp"))
+(def: @variant (_.var "lux_pm_variant"))
+
+(def: (push! value)
+ (-> (Expression Any) (Expression Any))
+ (_.setq @cursor (_.cons/2 [value @cursor])))
+
+(def: pop!
+ (Expression Any)
+ (_.setq @cursor (_.cdr/1 @cursor)))
+
+(def: peek
+ (Expression Any)
+ (_.car/1 @cursor))
+
+(def: save!
+ (Expression Any)
+ (_.setq @savepoint (_.cons/2 [@cursor @savepoint])))
+
+(def: restore!
+ (List (Expression Any))
+ (list (_.setq @cursor (_.car/1 @savepoint))
+ (_.setq @savepoint (_.cdr/1 @savepoint))))
+
+(def: (multi_pop! pops)
+ (-> Nat (Expression Any))
+ (_.setq @cursor (_.nthcdr/2 [(_.int (.int pops)) @cursor])))
+
+(template [<name> <flag> <prep>]
+ [(def: (<name> @fail simple? idx next!)
+ (-> _.Tag Bit Nat (Maybe (Expression Any)) (Expression Any))
+ (.let [<failure_condition> (_.eq/2 [@variant @temp])]
+ (_.let (list [@variant ..peek])
+ (list& (_.setq @temp (|> idx <prep> .int _.int (//runtime.sum//get @variant <flag>)))
+ (.if simple?
+ (_.when <failure_condition>
+ (_.go @fail))
+ (_.if <failure_condition>
+ (_.go @fail)
+ (..push! @temp)))
+ (.case next!
+ (#.Some next!)
+ (list next!)
+
+ #.None
+ (list))))))]
+
+ [left_choice _.nil (<|)]
+ [right_choice (_.string "") inc]
+ )
+
+(def: (alternation @otherwise pre! post!)
+ (-> _.Tag (Expression Any) (Expression Any) (Expression Any))
+ (_.tagbody ($_ list\compose
+ (list ..save!
+ pre!
+ @otherwise)
+ ..restore!
+ (list post!))))
+
+(def: (pattern_matching' expression archive)
+ (Generator [Var/1 _.Tag _.Tag Path])
+ (function (recur [$output @done @fail pathP])
+ (.case pathP
+ (^ (/////synthesis.path/then bodyS))
+ (\ ///////phase.monad map
+ (function (_ outputV)
+ (_.progn (list (_.setq $output outputV)
+ (_.go @done))))
+ (expression archive bodyS))
+
+ #/////synthesis.Pop
+ (///////phase\wrap ..pop!)
+
+ (#/////synthesis.Bind register)
+ (///////phase\wrap (_.setq (..register register) ..peek))
+
+ (#/////synthesis.Bit_Fork when thenP elseP)
+ (do {! ///////phase.monad}
+ [then! (recur [$output @done @fail thenP])
+ else! (.case elseP
+ (#.Some elseP)
+ (recur [$output @done @fail elseP])
+
+ #.None
+ (wrap (_.go @fail)))]
+ (wrap (.if when
+ (_.if ..peek
+ then!
+ else!)
+ (_.if ..peek
+ else!
+ then!))))
+
+ (^template [<tag> <format> <=>]
+ [(<tag> cons)
+ (do {! ///////phase.monad}
+ [clauses (monad.map ! (function (_ [match then])
+ (do !
+ [then! (recur [$output @done @fail then])]
+ (wrap [(<=> [(|> match <format>)
+ ..peek])
+ then!])))
+ (#.Cons cons))]
+ (wrap (list\fold (function (_ [when then] else)
+ (_.if when then else))
+ (_.go @fail)
+ clauses)))])
+ ([#/////synthesis.I64_Fork //primitive.i64 _.=/2]
+ [#/////synthesis.F64_Fork //primitive.f64 _.=/2]
+ [#/////synthesis.Text_Fork //primitive.text _.string=/2])
+
+ (^template [<complex> <simple> <choice>]
+ [(^ (<complex> idx))
+ (///////phase\wrap (<choice> @fail false idx #.None))
+
+ (^ (<simple> idx nextP))
+ (|> nextP
+ [$output @done @fail] recur
+ (\ ///////phase.monad map (|>> #.Some (<choice> @fail true idx))))])
+ ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice]
+ [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice])
+
+ (^ (/////synthesis.member/left 0))
+ (///////phase\wrap (..push! (_.elt/2 [..peek (_.int +0)])))
+
+ (^template [<pm> <getter>]
+ [(^ (<pm> lefts))
+ (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))])
+ ([/////synthesis.member/left //runtime.tuple//left]
+ [/////synthesis.member/right //runtime.tuple//right])
+
+ (^ (/////synthesis.!multi_pop nextP))
+ (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)]
+ (do ///////phase.monad
+ [next! (recur [$output @done @fail nextP'])]
+ (///////phase\wrap (_.progn (list (..multi_pop! (n.+ 2 extra_pops))
+ next!)))))
+
+ (^ (/////synthesis.path/alt preP postP))
+ (do {! ///////phase.monad}
+ [@otherwise (\ ! map (|>> %.nat (format "lux_case_otherwise") _.tag) /////generation.next)
+ pre! (recur [$output @done @otherwise preP])
+ post! (recur [$output @done @fail postP])]
+ (wrap (..alternation @otherwise pre! post!)))
+
+ (^ (/////synthesis.path/seq preP postP))
+ (do ///////phase.monad
+ [pre! (recur [$output @done @fail preP])
+ post! (recur [$output @done @fail postP])]
+ (wrap (_.progn (list pre! post!)))))))
+
+(def: (pattern_matching $output expression archive pathP)
+ (-> Var/1 (Generator Path))
+ (do {! ///////phase.monad}
+ [@done (\ ! map (|>> %.nat (format "lux_case_done") _.tag) /////generation.next)
+ @fail (\ ! map (|>> %.nat (format "lux_case_fail") _.tag) /////generation.next)
+ pattern_matching! (pattern_matching' expression archive [$output @done @fail pathP])]
+ (wrap (_.tagbody
+ (list pattern_matching!
+ @fail
+ (_.error/1 (_.string ////synthesis/case.pattern_matching_error))
+ @done)))))
+
+(def: #export (case expression archive [valueS pathP])
+ (Generator [Synthesis Path])
+ (do {! ///////phase.monad}
+ [initG (expression archive valueS)
+ $output (\ ! map (|>> %.nat (format "lux_case_output") _.var) /////generation.next)
+ pattern_matching! (pattern_matching $output expression archive pathP)
+ #let [storage (|> pathP
+ ////synthesis/case.storage
+ (get@ #////synthesis/case.bindings)
+ set.to_list
+ (list\map (function (_ register)
+ [(..register register)
+ _.nil])))]]
+ (wrap (_.let (list& [@cursor (_.list/* (list initG))]
+ [@savepoint (_.list/* (list))]
+ [@temp _.nil]
+ [$output _.nil]
+ storage)
+ (list pattern_matching!
+ $output)))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux
new file mode 100644
index 000000000..1880d7700
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux
@@ -0,0 +1,14 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]]
+ [//
+ [runtime (#+ Bundle)]]
+ [/
+ ["." common]])
+
+(def: #export bundle
+ Bundle
+ common.bundle)
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux
new file mode 100644
index 000000000..baac3e891
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux
@@ -0,0 +1,137 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]]
+ [data
+ ["." product]
+ [number
+ ["f" frac]]
+ [collection
+ ["." dictionary]]]
+ [target
+ ["_" common-lisp (#+ Expression)]]]]
+ ["." /// #_
+ ["#." runtime (#+ Operation Phase Handler Bundle)]
+ ["#." primitive]
+ [//
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ [//
+ [extension
+ ["." bundle]]]]])
+
+(def: lux-procs
+ Bundle
+ (|> bundle.empty
+ (bundle.install "is" (binary (product.uncurry _.eq)))
+ (bundle.install "try" (unary ///runtime.lux//try))))
+
+(def: (i64//left-shift [paramG subjectG])
+ (Binary (Expression Any))
+ (_.ash (_.rem (_.int +64) paramG) subjectG))
+
+(def: (i64//arithmetic-right-shift [paramG subjectG])
+ (Binary (Expression Any))
+ (_.ash (|> paramG (_.rem (_.int +64)) (_.* (_.int -1)))
+ subjectG))
+
+(def: (i64//logic-right-shift [paramG subjectG])
+ (Binary (Expression Any))
+ (///runtime.i64//logic-right-shift (_.rem (_.int +64) paramG) subjectG))
+
+(def: i64-procs
+ Bundle
+ (<| (bundle.prefix "i64")
+ (|> bundle.empty
+ (bundle.install "and" (binary (product.uncurry _.logand)))
+ (bundle.install "or" (binary (product.uncurry _.logior)))
+ (bundle.install "xor" (binary (product.uncurry _.logxor)))
+ (bundle.install "left-shift" (binary i64//left-shift))
+ (bundle.install "logical-right-shift" (binary i64//logic-right-shift))
+ (bundle.install "arithmetic-right-shift" (binary i64//arithmetic-right-shift))
+ (bundle.install "=" (binary (product.uncurry _.=)))
+ (bundle.install "<" (binary (product.uncurry _.<)))
+ (bundle.install "+" (binary (product.uncurry _.+)))
+ (bundle.install "-" (binary (product.uncurry _.-)))
+ (bundle.install "*" (binary (product.uncurry _.*)))
+ (bundle.install "/" (binary (product.uncurry _.floor)))
+ (bundle.install "%" (binary (product.uncurry _.rem)))
+ (bundle.install "f64" (unary (function (_ value)
+ (_.coerce/2 [value (_.symbol "double-float")]))))
+ (bundle.install "char" (unary (|>> _.code-char/1 _.string/1)))
+ )))
+
+(def: f64-procs
+ Bundle
+ (<| (bundle.prefix "f64")
+ (|> bundle.empty
+ (bundle.install "+" (binary (product.uncurry _.+)))
+ (bundle.install "-" (binary (product.uncurry _.-)))
+ (bundle.install "*" (binary (product.uncurry _.*)))
+ (bundle.install "/" (binary (product.uncurry _./)))
+ (bundle.install "%" (binary (product.uncurry _.mod)))
+ (bundle.install "=" (binary (product.uncurry _.=)))
+ (bundle.install "<" (binary (product.uncurry _.<)))
+ (bundle.install "i64" (unary _.floor/1))
+ (bundle.install "encode" (unary _.write-to-string/1))
+ (bundle.install "decode" (unary (let [@temp (_.var "temp")]
+ (function (_ input)
+ (_.let (list [@temp (_.read-from-string/1 input)])
+ (_.if (_.equal (_.symbol "DOUBLE-FLOAT")
+ (_.type-of/1 @temp))
+ (///runtime.some @temp)
+ ///runtime.none)))))))))
+
+(def: (text//< [paramG subjectG])
+ (Binary (Expression Any))
+ (|> (_.string< paramG subjectG)
+ _.null/1
+ _.not/1))
+
+(def: (text//clip [paramO extraO subjectO])
+ (Trinary (Expression Any))
+ (///runtime.text//clip subjectO paramO extraO))
+
+(def: (text//index [startO partO textO])
+ (Trinary (Expression Any))
+ (///runtime.text//index textO partO startO))
+
+(def: text-procs
+ Bundle
+ (<| (bundle.prefix "text")
+ (|> bundle.empty
+ (bundle.install "=" (binary (product.uncurry _.string=)))
+ (bundle.install "<" (binary text//<))
+ (bundle.install "concat" (binary _.concatenate/2|string))
+ (bundle.install "index" (trinary text//index))
+ (bundle.install "size" (unary _.length/1))
+ (bundle.install "char" (binary (|>> _.char/2 _.char-int/1)))
+ (bundle.install "clip" (trinary text//clip))
+ )))
+
+(def: (void code)
+ (-> (Expression Any) (Expression Any))
+ ($_ _.progn
+ code
+ ///runtime.unit))
+
+(def: io-procs
+ Bundle
+ (<| (bundle.prefix "io")
+ (|> bundle.empty
+ (bundle.install "log" (unary (|>> _.print/1 ..void)))
+ (bundle.install "error" (unary _.error/1))
+ )))
+
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "lux")
+ (|> lux-procs
+ (dictionary.merge i64-procs)
+ (dictionary.merge f64-procs)
+ (dictionary.merge text-procs)
+ (dictionary.merge io-procs)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux
new file mode 100644
index 000000000..6adc2d747
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux
@@ -0,0 +1,103 @@
+(.module:
+ [library
+ [lux (#- function)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ pipe]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [target
+ ["_" common_lisp (#+ Expression Var/1)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." reference]
+ ["#." case]
+ ["/#" // #_
+ ["#." reference]
+ ["//#" /// #_
+ [analysis (#+ Variant Tuple Abstraction Application Analysis)]
+ [synthesis (#+ Synthesis)]
+ ["#." generation (#+ Context)]
+ ["//#" /// #_
+ [arity (#+ Arity)]
+ ["#." phase ("#\." monad)]
+ [reference
+ [variable (#+ Register Variable)]]]]]])
+
+(def: #export (apply expression archive [functionS argsS+])
+ (Generator (Application Synthesis))
+ (do {! ///////phase.monad}
+ [functionG (expression archive functionS)
+ argsG+ (monad.map ! (expression archive) argsS+)]
+ (wrap (_.funcall/+ [functionG argsG+]))))
+
+(def: capture
+ (-> Register Var/1)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: (with_closure inits function_definition)
+ (-> (List (Expression Any)) (Expression Any) (Operation (Expression Any)))
+ (case inits
+ #.Nil
+ (\ ///////phase.monad wrap function_definition)
+
+ _
+ (do {! ///////phase.monad}
+ [@closure (\ ! map _.var (/////generation.gensym "closure"))]
+ (wrap (_.labels (list [@closure [(|> (list.enumeration inits)
+ (list\map (|>> product.left ..capture))
+ _.args)
+ function_definition]])
+ (_.funcall/+ [(_.function/1 @closure) inits]))))))
+
+(def: input
+ (|>> inc //case.register))
+
+(def: #export (function expression archive [environment arity bodyS])
+ (Generator (Abstraction Synthesis))
+ (do {! ///////phase.monad}
+ [@scope (\ ! map (|>> %.nat (format "function_scope") _.tag) /////generation.next)
+ @output (\ ! map (|>> %.nat (format "loop_output") _.var) /////generation.next)
+ [function_name bodyG] (/////generation.with_new_context archive
+ (/////generation.with_anchor [@scope 1]
+ (expression archive bodyS)))
+ closureG+ (monad.map ! (expression archive) environment)
+ #let [@curried (_.var "curried")
+ @missing (_.var "missing")
+ arityG (|> arity .int _.int)
+ @num_args (_.var "num_args")
+ @self (_.var (///reference.artifact function_name))
+ initialize_self! [(//case.register 0) (_.function/1 @self)]
+ initialize! [(|> (list.indices arity)
+ (list\map ..input)
+ _.args)
+ @curried]]]
+ (with_closure closureG+
+ (_.labels (list [@self [(_.args& (list) @curried)
+ (_.let (list [@num_args (_.length/1 @curried)])
+ (list (_.cond (list [(_.=/2 [arityG @num_args])
+ (_.let (list [@output _.nil]
+ initialize_self!)
+ (list (_.destructuring-bind initialize!
+ (list (_.tagbody
+ (list @scope
+ (_.setq @output bodyG)))
+ @output))))]
+
+ [(_.>/2 [arityG @num_args])
+ (let [arity_inputs (_.subseq/3 [@curried (_.int +0) arityG])
+ extra_inputs (_.subseq/3 [@curried arityG @num_args])]
+ (_.apply/2 [(_.apply/2 [(_.function/1 @self)
+ arity_inputs])
+ extra_inputs]))])
+ ## (|> @num_args (_.< arityG))
+ (_.lambda (_.args& (list) @missing)
+ (_.apply/2 [(_.function/1 @self)
+ (_.append/2 [@curried @missing])])))))]])
+ (_.function/1 @self)))
+ ))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux
new file mode 100644
index 000000000..bfe5e2787
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux
@@ -0,0 +1,70 @@
+(.module:
+ [library
+ [lux (#- Scope)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [target
+ ["_" common_lisp (#+ Expression)]]]]
+ ["." // #_
+ [runtime (#+ Operation Phase Generator)]
+ ["#." case]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ [synthesis
+ ["." case]]
+ ["/#" // #_
+ ["."synthesis (#+ Scope Synthesis)]
+ ["#." generation]
+ ["//#" /// #_
+ ["#." phase]
+ [meta
+ [archive (#+ Archive)]]
+ [reference
+ [variable (#+ Register)]]]]]]])
+
+(def: #export (scope expression archive [start initsS+ bodyS])
+ (Generator (Scope Synthesis))
+ (case initsS+
+ ## function/false/non-independent loop
+ #.Nil
+ (expression archive bodyS)
+
+ ## true loop
+ _
+ (do {! ///////phase.monad}
+ [@scope (\ ! map (|>> %.nat (format "loop_scope") _.tag) /////generation.next)
+ @output (\ ! map (|>> %.nat (format "loop_output") _.var) /////generation.next)
+ initsG+ (monad.map ! (expression archive) initsS+)
+ bodyG (/////generation.with_anchor [@scope start]
+ (expression archive bodyS))]
+ (wrap (_.let (|> initsG+
+ list.enumeration
+ (list\map (function (_ [idx init])
+ [(|> idx (n.+ start) //case.register)
+ init]))
+ (list& [@output _.nil]))
+ (list (_.tagbody (list @scope
+ (_.setq @output bodyG)))
+ @output))))))
+
+(def: #export (recur expression archive argsS+)
+ (Generator (List Synthesis))
+ (do {! ///////phase.monad}
+ [[tag offset] /////generation.anchor
+ argsO+ (monad.map ! (expression archive) argsS+)
+ #let [bindings (|> argsO+
+ list.enumeration
+ (list\map (|>> product.left (n.+ offset) //case.register))
+ _.args)]]
+ (wrap (_.progn (list (_.multiple-value-setq bindings (_.values/* argsO+))
+ (_.go tag))))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux
new file mode 100644
index 000000000..82ab68128
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux
@@ -0,0 +1,21 @@
+(.module:
+ [library
+ [lux (#- i64)
+ [target
+ ["_" common_lisp (#+ Expression)]]]])
+
+(def: #export bit
+ (-> Bit (Expression Any))
+ _.bool)
+
+(def: #export i64
+ (-> (I64 Any) (Expression Any))
+ (|>> .int _.int))
+
+(def: #export f64
+ (-> Frac (Expression Any))
+ _.double)
+
+(def: #export text
+ (-> Text (Expression Any))
+ _.string)
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux
new file mode 100644
index 000000000..83bbc6a95
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux
@@ -0,0 +1,13 @@
+(.module:
+ [library
+ [lux #*
+ [target
+ ["_" common_lisp (#+ Expression)]]]]
+ [///
+ [reference (#+ System)]])
+
+(implementation: #export system
+ (System (Expression Any))
+
+ (def: constant _.var)
+ (def: variable _.var))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux
new file mode 100644
index 000000000..41e7cda43
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux
@@ -0,0 +1,293 @@
+(.module:
+ [library
+ [lux (#- Location inc)
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<.>" code]]]
+ [data
+ ["." product]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]
+ ["." encoding]]
+ [collection
+ ["." list ("#\." functor monoid)]
+ ["." row]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number (#+ hex)
+ ["." i64]]]
+ ["@" target
+ ["_" common_lisp (#+ Expression Computation Literal)]]]]
+ ["." /// #_
+ ["#." reference]
+ ["//#" /// #_
+ [analysis (#+ Variant)]
+ ["#." synthesis (#+ Synthesis)]
+ ["#." generation]
+ ["//#" ///
+ ["#." phase]
+ [reference
+ [variable (#+ Register)]]
+ [meta
+ [archive (#+ Output Archive)
+ ["." artifact (#+ Registry)]]]]]])
+
+(def: module_id
+ 0)
+
+(template [<name> <base>]
+ [(type: #export <name>
+ (<base> [_.Tag Register] (Expression Any) (Expression Any)))]
+
+ [Operation /////generation.Operation]
+ [Phase /////generation.Phase]
+ [Handler /////generation.Handler]
+ [Bundle /////generation.Bundle]
+ )
+
+(type: #export (Generator i)
+ (-> Phase Archive i (Operation (Expression Any))))
+
+(def: #export unit
+ (_.string /////synthesis.unit))
+
+(def: (flag value)
+ (-> Bit Literal)
+ (if value
+ (_.string "")
+ _.nil))
+
+(def: (variant' tag last? value)
+ (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any))
+ (_.list/* (list tag last? value)))
+
+(def: #export (variant [lefts right? value])
+ (-> (Variant (Expression Any)) (Computation Any))
+ (variant' (_.int (.int lefts)) (flag right?) value))
+
+(def: #export none
+ (Computation Any)
+ (|> ..unit [0 #0] ..variant))
+
+(def: #export some
+ (-> (Expression Any) (Computation Any))
+ (|>> [1 #1] ..variant))
+
+(def: #export left
+ (-> (Expression Any) (Computation Any))
+ (|>> [0 #0] ..variant))
+
+(def: #export right
+ (-> (Expression Any) (Computation Any))
+ (|>> [1 #1] ..variant))
+
+(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
+ body)
+ (do {! meta.monad}
+ [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
+ (wrap (list (` (let [(~+ (|> vars
+ (list.zip/2 ids)
+ (list\map (function (_ [id var])
+ (list (code.local_identifier var)
+ (` (_.var (~ (code.text (format "v" (%.nat id)))))))))
+ list.concat))]
+ (~ body)))))))
+
+(syntax: (runtime: {declaration (<>.or <code>.local_identifier
+ (<code>.form (<>.and <code>.local_identifier
+ (<>.some <code>.local_identifier))))}
+ code)
+ (do meta.monad
+ [runtime_id meta.count]
+ (macro.with_gensyms [g!_]
+ (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id]))
+ runtime_name (` (_.var (~ (code.text (%.code runtime)))))]
+ (case declaration
+ (#.Left name)
+ (let [g!name (code.local_identifier name)
+ code_nameC (code.local_identifier (format "@" name))]
+ (wrap (list (` (def: #export (~ g!name)
+ _.Var/1
+ (~ runtime_name)))
+
+ (` (def: (~ code_nameC)
+ (_.Expression Any)
+ (_.defparameter (~ runtime_name) (~ code)))))))
+
+ (#.Right [name inputs])
+ (let [g!name (code.local_identifier name)
+ code_nameC (code.local_identifier (format "@" name))
+
+ inputsC (list\map code.local_identifier inputs)
+ inputs_typesC (list\map (function.constant (` (_.Expression Any)))
+ inputs)]
+ (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
+ (-> (~+ inputs_typesC) (_.Computation Any))
+ (_.call/* (~ runtime_name) (list (~+ inputsC)))))
+
+ (` (def: (~ code_nameC)
+ (_.Expression Any)
+ (..with_vars [(~+ inputsC)]
+ (_.defun (~ runtime_name) (_.args (list (~+ inputsC)))
+ (~ code)))))))))))))
+
+(runtime: (lux//try op)
+ (with_vars [error]
+ (_.handler-case
+ (list [(_.bool true) error
+ (..left (_.format/3 [_.nil (_.string "~A") error]))])
+ (..right (_.funcall/+ [op (list ..unit)])))))
+
+## TODO: Use Common Lisp's swiss-army loop macro instead.
+(runtime: (lux//program_args inputs)
+ (with_vars [loop input tail]
+ (_.labels (list [loop [(_.args (list input tail))
+ (_.if (_.null/1 input)
+ tail
+ (_.funcall/+ [(_.function/1 loop)
+ (list (_.cdr/1 input)
+ (..some (_.vector/* (list (_.car/1 input) tail))))]))]])
+ (_.funcall/+ [(_.function/1 loop)
+ (list (_.reverse/1 inputs)
+ ..none)]))))
+
+(def: runtime//lux
+ (List (Expression Any))
+ (list @lux//try
+ @lux//program_args))
+
+(def: last_index
+ (|>> _.length/1 [(_.int +1)] _.-/2))
+
+(with_expansions [<recur> (as_is ($_ _.then
+ (_.; (_.set lefts (_.-/2 [last_index_right lefts])))
+ (_.; (_.set tuple (_.nth last_index_right tuple)))))]
+ (template: (!recur <side>)
+ (<side> (_.-/2 [last_index_right lefts])
+ (_.elt/2 [tuple last_index_right])))
+
+ (runtime: (tuple//left lefts tuple)
+ (with_vars [last_index_right]
+ (_.let (list [last_index_right (..last_index tuple)])
+ (list (_.if (_.>/2 [lefts last_index_right])
+ ## No need for recursion
+ (_.elt/2 [tuple lefts])
+ ## Needs recursion
+ (!recur tuple//left))))))
+
+ (runtime: (tuple//right lefts tuple)
+ (with_vars [last_index_right right_index]
+ (_.let (list [last_index_right (..last_index tuple)]
+ [right_index (_.+/2 [(_.int +1) lefts])])
+ (list (_.cond (list [(_.=/2 [last_index_right right_index])
+ (_.elt/2 [tuple right_index])]
+ [(_.>/2 [last_index_right right_index])
+ ## Needs recursion.
+ (!recur tuple//right)])
+ (_.subseq/3 [tuple right_index (_.length/1 tuple)])))))))
+
+## TODO: Find a way to extract parts of the sum without "nth", which
+## does a linear search, and is thus expensive.
+(runtime: (sum//get sum wantsLast wantedTag)
+ (with_vars [sum_tag sum_flag]
+ (let [no_match! (_.return sum)
+ sum_value (_.nth/2 [(_.int +2) sum])
+ test_recursion! (_.if sum_flag
+ ## Must iterate.
+ (_.progn (list (_.setq wantedTag (_.-/2 [sum_tag wantedTag]))
+ (_.setq sum sum_value)))
+ no_match!)]
+ (_.while (_.bool true)
+ (_.let (list [sum_tag (_.nth/2 [(_.int +0) sum])]
+ [sum_flag (_.nth/2 [(_.int +1) sum])])
+ (list (_.cond (list [(_.=/2 [sum_tag wantedTag])
+ (_.if (_.equal/2 [wantsLast sum_flag])
+ (_.return sum_value)
+ test_recursion!)]
+
+ [(_.>/2 [sum_tag wantedTag])
+ test_recursion!]
+
+ [(_.and (_.</2 [sum_tag wantedTag])
+ wantsLast)
+ (_.return (variant' (_.-/2 [wantedTag sum_tag]) sum_flag sum_value))])
+
+ no_match!)))))))
+
+(def: runtime//adt
+ (List (Expression Any))
+ (list @tuple//left
+ @tuple//right
+ @sum//get))
+
+(runtime: (i64//right_shift shift input)
+ (_.if (_.=/2 [(_.int +0) shift])
+ input
+ (let [anti_shift (_.-/2 [shift (_.int +64)])
+ mask (|> (_.int +1)
+ [anti_shift] _.ash/2
+ [(_.int +1)] _.-/2)]
+ (|> input
+ [(_.*/2 [(_.int -1) shift])] _.ash/2
+ [mask] _.logand/2))))
+
+(def: runtime//i64
+ (List (Expression Any))
+ (list @i64//right_shift))
+
+(runtime: (text//clip offset length text)
+ (_.subseq/3 [text offset (_.+/2 [offset length])]))
+
+(runtime: (text//index offset sub text)
+ (with_vars [index]
+ (_.let (list [index (_.search/3 [sub text offset])])
+ (list (_.if index
+ (..some index)
+ ..none)))))
+
+(def: runtime//text
+ (List (Expression Any))
+ (list @text//index
+ @text//clip))
+
+(runtime: (io//exit code)
+ (_.progn (list (_.conditional+ (list "sbcl")
+ (_.call/* (_.var "sb-ext:quit") (list code)))
+ (_.conditional+ (list "clisp")
+ (_.call/* (_.var "ext:exit") (list code)))
+ (_.conditional+ (list "ccl")
+ (_.call/* (_.var "ccl:quit") (list code)))
+ (_.conditional+ (list "allegro")
+ (_.call/* (_.var "excl:exit") (list code)))
+ (_.call/* (_.var "cl-user::quit") (list code)))))
+
+(def: runtime//io
+ (List (Expression Any))
+ (list @io//exit))
+
+(def: runtime
+ (_.progn ($_ list\compose
+ runtime//adt
+ runtime//lux
+ runtime//i64
+ runtime//text
+ runtime//io)))
+
+(def: #export generate
+ (Operation [Registry Output])
+ (do ///////phase.monad
+ [_ (/////generation.execute! ..runtime)
+ _ (/////generation.save! (%.nat ..module_id) ..runtime)]
+ (wrap [(|> artifact.empty
+ artifact.resource
+ product.right)
+ (row.row [(%.nat ..module_id)
+ (|> ..runtime
+ _.code
+ (\ encoding.utf8 encode))])])))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux
new file mode 100644
index 000000000..44bd542f6
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux
@@ -0,0 +1,37 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [target
+ ["_" common_lisp (#+ Expression)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." primitive]
+ ["///#" //// #_
+ [analysis (#+ Variant Tuple)]
+ ["#." synthesis (#+ Synthesis)]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]]]])
+
+(def: #export (tuple expression archive elemsS+)
+ (Generator (Tuple Synthesis))
+ (case elemsS+
+ #.Nil
+ (///////phase\wrap (//primitive.text /////synthesis.unit))
+
+ (#.Cons singletonS #.Nil)
+ (expression archive singletonS)
+
+ _
+ (|> elemsS+
+ (monad.map ///////phase.monad (expression archive))
+ (///////phase\map _.vector/*))))
+
+(def: #export (variant expression archive [lefts right? valueS])
+ (Generator (Variant Synthesis))
+ (let [tag (if right?
+ (inc lefts)
+ lefts)]
+ (///////phase\map (|>> [tag right?] //runtime.variant)
+ (expression archive valueS))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/extension.lux
new file mode 100644
index 000000000..5196c6e33
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/extension.lux
@@ -0,0 +1,66 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ [parser
+ ["s" code]]]
+ [data
+ [collection
+ ["." list ("#\." functor)]]]
+ ["." meta]
+ ["." macro (#+ with_gensyms)
+ ["." code]
+ [syntax (#+ syntax:)]]]]
+ ["." /// #_
+ ["#." extension]
+ [//
+ [synthesis (#+ Synthesis)]
+ ["." generation]
+ [///
+ ["#" phase]]]])
+
+(syntax: (Vector {size s.nat} elemT)
+ (wrap (list (` [(~+ (list.repeat size elemT))]))))
+
+(type: #export (Nullary of) (-> (Vector 0 of) of))
+(type: #export (Unary of) (-> (Vector 1 of) of))
+(type: #export (Binary of) (-> (Vector 2 of) of))
+(type: #export (Trinary of) (-> (Vector 3 of) of))
+(type: #export (Variadic of) (-> (List of) of))
+
+(syntax: (arity: {arity s.nat} {name s.local_identifier} type)
+ (with_gensyms [g!_ g!extension g!name g!phase g!archive g!inputs g!of g!anchor g!expression g!directive]
+ (do {! meta.monad}
+ [g!input+ (monad.seq ! (list.repeat arity (macro.gensym "input")))]
+ (wrap (list (` (def: #export ((~ (code.local_identifier name)) (~ g!extension))
+ (All [(~ g!anchor) (~ g!expression) (~ g!directive)]
+ (-> ((~ type) (~ g!expression))
+ (generation.Handler (~ g!anchor) (~ g!expression) (~ g!directive))))
+ (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!archive) (~ g!inputs))
+ (case (~ g!inputs)
+ (^ (list (~+ g!input+)))
+ (do ///.monad
+ [(~+ (|> g!input+
+ (list\map (function (_ g!input)
+ (list g!input (` ((~ g!phase) (~ g!archive) (~ g!input))))))
+ list.concat))]
+ ((~' wrap) ((~ g!extension) [(~+ g!input+)])))
+
+ (~' _)
+ (///.throw ///extension.incorrect_arity [(~ g!name) 1 (list.size (~ g!inputs))]))))))))))
+
+(arity: 0 nullary ..Nullary)
+(arity: 1 unary ..Unary)
+(arity: 2 binary ..Binary)
+(arity: 3 trinary ..Trinary)
+
+(def: #export (variadic extension)
+ (All [anchor expression directive]
+ (-> (Variadic expression) (generation.Handler anchor expression directive)))
+ (function (_ extension_name)
+ (function (_ phase archive inputsS)
+ (do {! ///.monad}
+ [inputsI (monad.map ! (phase archive) inputsS)]
+ (wrap (extension inputsI))))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js.lux
new file mode 100644
index 000000000..18319d0a2
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js.lux
@@ -0,0 +1,117 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]]
+ [target
+ ["_" js]]]]
+ ["." / #_
+ [runtime (#+ Phase Phase!)]
+ ["#." primitive]
+ ["#." structure]
+ ["#." reference]
+ ["#." case]
+ ["#." loop]
+ ["#." function]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." extension]
+ ["/#" // #_
+ [analysis (#+)]
+ ["." synthesis]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]
+ [reference (#+)
+ [variable (#+)]]]]]]])
+
+(def: (statement expression archive synthesis)
+ Phase!
+ (case synthesis
+ (^template [<tag>]
+ [(^ (<tag> value))
+ (//////phase\map _.return (expression archive synthesis))])
+ ([synthesis.bit]
+ [synthesis.i64]
+ [synthesis.f64]
+ [synthesis.text]
+ [synthesis.variant]
+ [synthesis.tuple]
+ [#synthesis.Reference]
+ [synthesis.branch/get]
+ [synthesis.function/apply]
+ [#synthesis.Extension])
+
+ (^ (synthesis.branch/case case))
+ (/case.case! statement expression archive case)
+
+ (^ (synthesis.branch/let let))
+ (/case.let! statement expression archive let)
+
+ (^ (synthesis.branch/if if))
+ (/case.if! statement expression archive if)
+
+ (^ (synthesis.loop/scope scope))
+ (/loop.scope! statement expression archive scope)
+
+ (^ (synthesis.loop/recur updates))
+ (/loop.recur! statement expression archive updates)
+
+ (^ (synthesis.function/abstraction abstraction))
+ (//////phase\map _.return (/function.function statement expression archive abstraction))
+ ))
+
+(exception: #export cannot-recur-as-an-expression)
+
+(def: (expression archive synthesis)
+ Phase
+ (case synthesis
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (//////phase\wrap (<generator> value))])
+ ([synthesis.bit /primitive.bit]
+ [synthesis.i64 /primitive.i64]
+ [synthesis.f64 /primitive.f64]
+ [synthesis.text /primitive.text])
+
+ (^ (synthesis.variant variantS))
+ (/structure.variant expression archive variantS)
+
+ (^ (synthesis.tuple members))
+ (/structure.tuple expression archive members)
+
+ (#synthesis.Reference value)
+ (//reference.reference /reference.system archive value)
+
+ (^ (synthesis.branch/case case))
+ (/case.case ..statement expression archive case)
+
+ (^ (synthesis.branch/let let))
+ (/case.let expression archive let)
+
+ (^ (synthesis.branch/if if))
+ (/case.if expression archive if)
+
+ (^ (synthesis.branch/get get))
+ (/case.get expression archive get)
+
+ (^ (synthesis.loop/scope scope))
+ (/loop.scope ..statement expression archive scope)
+
+ (^ (synthesis.loop/recur updates))
+ (//////phase.throw ..cannot-recur-as-an-expression [])
+
+ (^ (synthesis.function/abstraction abstraction))
+ (/function.function ..statement expression archive abstraction)
+
+ (^ (synthesis.function/apply application))
+ (/function.apply expression archive application)
+
+ (#synthesis.Extension extension)
+ (///extension.apply archive expression extension)))
+
+(def: #export generate
+ Phase
+ ..expression)
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/case.lux
new file mode 100644
index 000000000..76da7c8f1
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/case.lux
@@ -0,0 +1,322 @@
+(.module:
+ [library
+ [lux (#- case let if)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." maybe]
+ ["." text]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [target
+ ["_" js (#+ Expression Computation Var Statement)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Phase! Generator Generator!)]
+ ["#." reference]
+ ["#." primitive]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." synthesis #_
+ ["#/." case]]
+ ["/#" // #_
+ ["#." synthesis (#+ Member Synthesis Path)]
+ ["//#" /// #_
+ [reference
+ [variable (#+ Register)]]
+ ["#." phase ("#\." monad)]
+ [meta
+ [archive (#+ Archive)]]]]]]])
+
+(def: #export register
+ (-> Register Var)
+ (|>> (///reference.local //reference.system) :assume))
+
+(def: #export (let expression archive [valueS register bodyS])
+ (Generator [Synthesis Register Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)
+ bodyO (expression archive bodyS)]
+ ## TODO: Find some way to do 'let' without paying the price of the closure.
+ (wrap (_.apply/* (_.closure (list (..register register))
+ (_.return bodyO))
+ (list valueO)))))
+
+(def: #export (let! statement expression archive [valueS register bodyS])
+ (Generator! [Synthesis Register Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)
+ bodyO (statement expression archive bodyS)]
+ (wrap ($_ _.then
+ (_.define (..register register) valueO)
+ bodyO))))
+
+(def: #export (if expression archive [testS thenS elseS])
+ (Generator [Synthesis Synthesis Synthesis])
+ (do ///////phase.monad
+ [testO (expression archive testS)
+ thenO (expression archive thenS)
+ elseO (expression archive elseS)]
+ (wrap (_.? testO thenO elseO))))
+
+(def: #export (if! statement expression archive [testS thenS elseS])
+ (Generator! [Synthesis Synthesis Synthesis])
+ (do ///////phase.monad
+ [testO (expression archive testS)
+ thenO (statement expression archive thenS)
+ elseO (statement expression archive elseS)]
+ (wrap (_.if testO
+ thenO
+ elseO))))
+
+(def: #export (get expression archive [pathP valueS])
+ (Generator [(List Member) Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)]
+ (wrap (list\fold (function (_ side source)
+ (.let [method (.case side
+ (^template [<side> <accessor>]
+ [(<side> lefts)
+ (<accessor> (_.i32 (.int lefts)))])
+ ([#.Left //runtime.tuple//left]
+ [#.Right //runtime.tuple//right]))]
+ (method source)))
+ valueO
+ (list.reverse pathP)))))
+
+(def: @savepoint (_.var "lux_pm_cursor_savepoint"))
+(def: @cursor (_.var "lux_pm_cursor"))
+(def: @temp (_.var "lux_pm_temp"))
+
+(def: (push_cursor! value)
+ (-> Expression Statement)
+ (_.statement (|> @cursor (_.do "push" (list value)))))
+
+(def: peek_and_pop_cursor
+ Expression
+ (|> @cursor (_.do "pop" (list))))
+
+(def: pop_cursor!
+ Statement
+ (_.statement ..peek_and_pop_cursor))
+
+(def: length
+ (|>> (_.the "length")))
+
+(def: last_index
+ (|>> ..length (_.- (_.i32 +1))))
+
+(def: peek_cursor
+ Expression
+ (|> @cursor (_.at (last_index @cursor))))
+
+(def: save_cursor!
+ Statement
+ (.let [cursor (|> @cursor (_.do "slice" (list)))]
+ (_.statement (|> @savepoint (_.do "push" (list cursor))))))
+
+(def: restore_cursor!
+ Statement
+ (_.set @cursor (|> @savepoint (_.do "pop" (list)))))
+
+(def: fail_pm! _.break)
+
+(def: (multi_pop_cursor! pops)
+ (-> Nat Statement)
+ (.let [popsJS (_.i32 (.int pops))]
+ (_.statement (|> @cursor (_.do "splice" (list (|> @cursor ..length (_.- popsJS))
+ popsJS))))))
+
+(template [<name> <flag> <prep>]
+ [(def: (<name> simple? idx)
+ (-> Bit Nat Statement)
+ ($_ _.then
+ (_.set @temp (|> idx <prep> .int _.i32 (//runtime.sum//get ..peek_cursor <flag>)))
+ (.if simple?
+ (_.when (_.= _.null @temp)
+ ..fail_pm!)
+ (_.if (_.= _.null @temp)
+ ..fail_pm!
+ (push_cursor! @temp)))))]
+
+ [left_choice _.null (<|)]
+ [right_choice (_.string "") inc]
+ )
+
+(def: (alternation pre! post!)
+ (-> Statement Statement Statement)
+ ($_ _.then
+ (_.do_while (_.boolean false)
+ ($_ _.then
+ ..save_cursor!
+ pre!))
+ ($_ _.then
+ ..restore_cursor!
+ post!)))
+
+(def: (optimized_pattern_matching recur pathP)
+ (-> (-> Path (Operation Statement))
+ (-> Path (Operation (Maybe Statement))))
+ (.case pathP
+ (^template [<simple> <choice>]
+ [(^ (<simple> idx nextP))
+ (|> nextP
+ recur
+ (\ ///////phase.monad map (|>> (_.then (<choice> true idx)) #.Some)))])
+ ([/////synthesis.simple_left_side ..left_choice]
+ [/////synthesis.simple_right_side ..right_choice])
+
+ (^ (/////synthesis.member/left 0))
+ (///////phase\wrap (#.Some (push_cursor! (_.at (_.i32 +0) ..peek_cursor))))
+
+ ## Extra optimization
+ (^ (/////synthesis.path/seq
+ (/////synthesis.member/left 0)
+ (/////synthesis.!bind_top register thenP)))
+ (do ///////phase.monad
+ [then! (recur thenP)]
+ (wrap (#.Some ($_ _.then
+ (_.define (..register register) (_.at (_.i32 +0) ..peek_cursor))
+ then!))))
+
+ ## Extra optimization
+ (^template [<pm> <getter>]
+ [(^ (/////synthesis.path/seq
+ (<pm> lefts)
+ (/////synthesis.!bind_top register thenP)))
+ (do ///////phase.monad
+ [then! (recur thenP)]
+ (wrap (#.Some ($_ _.then
+ (_.define (..register register) (<getter> (_.i32 (.int lefts)) ..peek_cursor))
+ then!))))])
+ ([/////synthesis.member/left //runtime.tuple//left]
+ [/////synthesis.member/right //runtime.tuple//right])
+
+ (^ (/////synthesis.!bind_top register thenP))
+ (do ///////phase.monad
+ [then! (recur thenP)]
+ (wrap (#.Some ($_ _.then
+ (_.define (..register register) ..peek_and_pop_cursor)
+ then!))))
+
+ (^ (/////synthesis.!multi_pop nextP))
+ (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)]
+ (do ///////phase.monad
+ [next! (recur nextP')]
+ (wrap (#.Some ($_ _.then
+ (multi_pop_cursor! (n.+ 2 extra_pops))
+ next!)))))
+
+ _
+ (///////phase\wrap #.None)))
+
+(def: (pattern_matching' statement expression archive)
+ (-> Phase! Phase Archive
+ (-> Path (Operation Statement)))
+ (function (recur pathP)
+ (do ///////phase.monad
+ [outcome (optimized_pattern_matching recur pathP)]
+ (.case outcome
+ (#.Some outcome)
+ (wrap outcome)
+
+ #.None
+ (.case pathP
+ (#/////synthesis.Then bodyS)
+ (statement expression archive bodyS)
+
+ #/////synthesis.Pop
+ (///////phase\wrap pop_cursor!)
+
+ (#/////synthesis.Bind register)
+ (///////phase\wrap (_.define (..register register) ..peek_cursor))
+
+ (#/////synthesis.Bit_Fork when thenP elseP)
+ (do {! ///////phase.monad}
+ [then! (recur thenP)
+ else! (.case elseP
+ (#.Some elseP)
+ (recur elseP)
+
+ #.None
+ (wrap ..fail_pm!))]
+ (wrap (.if when
+ (_.if ..peek_cursor
+ then!
+ else!)
+ (_.if ..peek_cursor
+ else!
+ then!))))
+
+ (#/////synthesis.I64_Fork cons)
+ (do {! ///////phase.monad}
+ [clauses (monad.map ! (function (_ [match then])
+ (do !
+ [then! (recur then)]
+ (wrap [(//runtime.i64//= (//primitive.i64 (.int match))
+ ..peek_cursor)
+ then!])))
+ (#.Cons cons))]
+ (wrap (_.cond clauses ..fail_pm!)))
+
+ (^template [<tag> <format>]
+ [(<tag> cons)
+ (do {! ///////phase.monad}
+ [cases (monad.map ! (function (_ [match then])
+ (\ ! map (|>> [(list (<format> match))]) (recur then)))
+ (#.Cons cons))]
+ (wrap (_.switch ..peek_cursor
+ cases
+ (#.Some ..fail_pm!))))])
+ ([#/////synthesis.F64_Fork //primitive.f64]
+ [#/////synthesis.Text_Fork //primitive.text])
+
+ (^template [<complex> <choice>]
+ [(^ (<complex> idx))
+ (///////phase\wrap (<choice> false idx))])
+ ([/////synthesis.side/left ..left_choice]
+ [/////synthesis.side/right ..right_choice])
+
+ (^template [<pm> <getter>]
+ [(^ (<pm> lefts))
+ (///////phase\wrap (push_cursor! (<getter> (_.i32 (.int lefts)) ..peek_cursor)))])
+ ([/////synthesis.member/left //runtime.tuple//left]
+ [/////synthesis.member/right //runtime.tuple//right])
+
+ (^template [<tag> <combinator>]
+ [(^ (<tag> leftP rightP))
+ (do ///////phase.monad
+ [left! (recur leftP)
+ right! (recur rightP)]
+ (wrap (<combinator> left! right!)))])
+ ([/////synthesis.path/seq _.then]
+ [/////synthesis.path/alt ..alternation]))))))
+
+(def: (pattern_matching statement expression archive pathP)
+ (-> Phase! Phase Archive Path (Operation Statement))
+ (do ///////phase.monad
+ [pattern_matching! (pattern_matching' statement expression archive pathP)]
+ (wrap ($_ _.then
+ (_.do_while (_.boolean false)
+ pattern_matching!)
+ (_.throw (_.string ////synthesis/case.pattern_matching_error))))))
+
+(def: #export (case! statement expression archive [valueS pathP])
+ (Generator! [Synthesis Path])
+ (do ///////phase.monad
+ [stack_init (expression archive valueS)
+ pattern_matching! (pattern_matching statement expression archive pathP)]
+ (wrap ($_ _.then
+ (_.declare @temp)
+ (_.define @cursor (_.array (list stack_init)))
+ (_.define @savepoint (_.array (list)))
+ pattern_matching!))))
+
+(def: #export (case statement expression archive [valueS pathP])
+ (-> Phase! (Generator [Synthesis Path]))
+ (do ///////phase.monad
+ [pattern_matching! (..case! statement expression archive [valueS pathP])]
+ (wrap (_.apply/* (_.closure (list) pattern_matching!) (list)))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/function.lux
new file mode 100644
index 000000000..df13919b0
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/function.lux
@@ -0,0 +1,123 @@
+(.module:
+ [library
+ [lux (#- function)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [target
+ ["_" js (#+ Expression Computation Var Statement)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Phase! Generator)]
+ ["#." reference]
+ ["#." case]
+ ["/#" // #_
+ ["#." reference]
+ ["//#" /// #_
+ [analysis (#+ Variant Tuple Abstraction Application Analysis)]
+ [synthesis (#+ Synthesis)]
+ ["#." generation (#+ Context)]
+ ["//#" /// #_
+ [arity (#+ Arity)]
+ ["#." phase ("#\." monad)]
+ [reference
+ [variable (#+ Register Variable)]]]]]])
+
+(def: #export (apply expression archive [functionS argsS+])
+ (Generator (Application Synthesis))
+ (do {! ///////phase.monad}
+ [functionO (expression archive functionS)
+ argsO+ (monad.map ! (expression archive) argsS+)]
+ (wrap (_.apply/* functionO argsO+))))
+
+(def: capture
+ (-> Register Var)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: (with_closure @self inits body!)
+ (-> Var (List Expression) Statement [Statement Expression])
+ (case inits
+ #.Nil
+ [(_.function! @self (list) body!)
+ @self]
+
+ _
+ [(_.function! @self
+ (|> (list.enumeration inits)
+ (list\map (|>> product.left ..capture)))
+ (_.return (_.function @self (list) body!)))
+ (_.apply/* @self inits)]))
+
+(def: @curried
+ (_.var "curried"))
+
+(def: input
+ (|>> inc //case.register))
+
+(def: @@arguments
+ (_.var "arguments"))
+
+(def: (@scope function_name)
+ (-> Context Text)
+ (format (///reference.artifact function_name) "_scope"))
+
+(def: #export (function statement expression archive [environment arity bodyS])
+ (-> Phase! (Generator (Abstraction Synthesis)))
+ (do {! ///////phase.monad}
+ [[function_name body!] (/////generation.with_new_context archive
+ (do !
+ [scope (\ ! map ..@scope
+ (/////generation.context archive))]
+ (/////generation.with_anchor [1 scope]
+ (statement expression archive bodyS))))
+ #let [arityO (|> arity .int _.i32)
+ @num_args (_.var "num_args")
+ @scope (..@scope function_name)
+ @self (_.var (///reference.artifact function_name))
+ apply_poly (.function (_ args func)
+ (|> func (_.do "apply" (list _.null args))))
+ initialize_self! (_.define (//case.register 0) @self)
+ initialize! (list\fold (.function (_ post pre!)
+ ($_ _.then
+ pre!
+ (_.define (..input post) (_.at (_.i32 (.int post)) @@arguments))))
+ initialize_self!
+ (list.indices arity))]
+ environment (monad.map ! (expression archive) environment)
+ #let [[definition instantiation] (with_closure @self environment
+ ($_ _.then
+ (_.define @num_args (_.the "length" @@arguments))
+ (_.cond (list [(|> @num_args (_.= arityO))
+ ($_ _.then
+ initialize!
+ (_.with_label (_.label @scope)
+ (_.do_while (_.boolean true)
+ body!)))]
+ [(|> @num_args (_.> arityO))
+ (let [arity_inputs (|> (_.array (list))
+ (_.the "slice")
+ (_.do "call" (list @@arguments (_.i32 +0) arityO)))
+ extra_inputs (|> (_.array (list))
+ (_.the "slice")
+ (_.do "call" (list @@arguments arityO)))]
+ (_.return (|> @self
+ (apply_poly arity_inputs)
+ (apply_poly extra_inputs))))])
+ ## (|> @num_args (_.< arityO))
+ (let [all_inputs (|> (_.array (list))
+ (_.the "slice")
+ (_.do "call" (list @@arguments)))]
+ ($_ _.then
+ (_.define @curried all_inputs)
+ (_.return (_.closure (list)
+ (let [@missing all_inputs]
+ (_.return (apply_poly (_.do "concat" (list @missing) @curried)
+ @self))))))))
+ ))]
+ _ (/////generation.execute! definition)
+ _ (/////generation.save! (product.right function_name) definition)]
+ (wrap instantiation)))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/loop.lux
new file mode 100644
index 000000000..720257105
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/loop.lux
@@ -0,0 +1,91 @@
+(.module:
+ [library
+ [lux (#- Scope)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [target
+ ["_" js (#+ Computation Var Expression Statement)]]]]
+ ["." // #_
+ [runtime (#+ Operation Phase Phase! Generator Generator!)]
+ ["#." case]
+ ["///#" //// #_
+ [synthesis (#+ Scope Synthesis)]
+ ["#." generation]
+ ["//#" /// #_
+ ["#." phase]
+ [reference
+ [variable (#+ Register)]]]]])
+
+(def: @scope
+ (-> Nat Text)
+ (|>> %.nat (format "scope")))
+
+(def: (setup initial? offset bindings body)
+ (-> Bit Register (List Expression) Statement Statement)
+ (|> bindings
+ list.enumeration
+ (list\map (function (_ [register value])
+ (let [variable (//case.register (n.+ offset register))]
+ (if initial?
+ (_.define variable value)
+ (_.set variable value)))))
+ list.reverse
+ (list\fold _.then body)))
+
+(def: #export (scope! statement expression archive [start initsS+ bodyS])
+ (Generator! (Scope Synthesis))
+ (case initsS+
+ ## function/false/non-independent loop
+ #.Nil
+ (statement expression archive bodyS)
+
+ ## true loop
+ _
+ (do {! ///////phase.monad}
+ [@scope (\ ! map ..@scope /////generation.next)
+ initsO+ (monad.map ! (expression archive) initsS+)
+ body! (/////generation.with_anchor [start @scope]
+ (statement expression archive bodyS))]
+ (wrap (..setup true start initsO+
+ (_.with_label (_.label @scope)
+ (_.do_while (_.boolean true)
+ body!)))))))
+
+(def: #export (scope statement expression archive [start initsS+ bodyS])
+ (-> Phase! (Generator (Scope Synthesis)))
+ (case initsS+
+ ## function/false/non-independent loop
+ #.Nil
+ (expression archive bodyS)
+
+ ## true loop
+ _
+ (do {! ///////phase.monad}
+ [loop! (scope! statement expression archive [start initsS+ bodyS])]
+ (wrap (_.apply/* (_.closure (list) loop!) (list))))))
+
+(def: @temp
+ (_.var "lux_recur_values"))
+
+(def: #export (recur! statement expression archive argsS+)
+ (Generator! (List Synthesis))
+ (do {! ///////phase.monad}
+ [[offset @scope] /////generation.anchor
+ argsO+ (monad.map ! (expression archive) argsS+)]
+ (wrap ($_ _.then
+ (_.define @temp (_.array argsO+))
+ (..setup false offset
+ (|> argsO+
+ list.enumeration
+ (list\map (function (_ [idx _])
+ (_.at (_.i32 (.int idx)) @temp))))
+ (_.continue_at (_.label @scope)))))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux
new file mode 100644
index 000000000..ede743c5d
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux
@@ -0,0 +1,21 @@
+(.module:
+ [library
+ [lux (#- i64)
+ [target
+ ["_" js (#+ Computation)]]]]
+ ["." // #_
+ ["#." runtime]])
+
+(def: #export bit
+ _.boolean)
+
+(def: #export (i64 value)
+ (-> (I64 Any) Computation)
+ (//runtime.i64 (|> value //runtime.high .int _.i32)
+ (|> value //runtime.low .int _.i32)))
+
+(def: #export f64
+ _.number)
+
+(def: #export text
+ _.string)
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/reference.lux
new file mode 100644
index 000000000..b21262192
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/reference.lux
@@ -0,0 +1,13 @@
+(.module:
+ [library
+ [lux #*
+ [target
+ ["_" js (#+ Expression)]]]]
+ [///
+ [reference (#+ System)]])
+
+(implementation: #export system
+ (System Expression)
+
+ (def: constant _.var)
+ (def: variable _.var))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux
new file mode 100644
index 000000000..2f6370418
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux
@@ -0,0 +1,785 @@
+(.module:
+ [library
+ [lux (#- i64)
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<.>" code]]]
+ [data
+ ["." product]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." row]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number (#+ hex)
+ ["." i64]]]
+ [target
+ ["_" js (#+ Expression Var Computation Statement)]]
+ [tool
+ [compiler
+ [language
+ [lux
+ ["$" version]]]]]]]
+ ["." /// #_
+ ["#." reference]
+ ["//#" /// #_
+ ["#." synthesis (#+ Synthesis)]
+ ["#." generation]
+ ["//#" ///
+ ["#." phase]
+ [reference
+ [variable (#+ Register)]]
+ [meta
+ [archive (#+ Output Archive)
+ ["." artifact (#+ Registry)]]]]]])
+
+(template [<name> <base>]
+ [(type: #export <name>
+ (<base> [Register Text] Expression Statement))]
+
+ [Operation /////generation.Operation]
+ [Phase /////generation.Phase]
+ [Handler /////generation.Handler]
+ [Bundle /////generation.Bundle]
+ )
+
+(type: #export (Generator i)
+ (-> Phase Archive i (Operation Expression)))
+
+(type: #export Phase!
+ (-> Phase Archive Synthesis (Operation Statement)))
+
+(type: #export (Generator! i)
+ (-> Phase! Phase Archive i (Operation Statement)))
+
+(def: #export high
+ (-> (I64 Any) (I64 Any))
+ (i64.right_shift 32))
+
+(def: #export low
+ (-> (I64 Any) (I64 Any))
+ (let [mask (dec (i64.left_shift 32 1))]
+ (|>> (i64.and mask))))
+
+(def: #export unit
+ Computation
+ (_.string /////synthesis.unit))
+
+(def: #export (flag value)
+ (-> Bit Computation)
+ (if value
+ (_.string "")
+ _.null))
+
+(def: (feature name definition)
+ (-> Var (-> Var Expression) Statement)
+ (_.define name (definition name)))
+
+(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
+ body)
+ (do {! meta.monad}
+ [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
+ (wrap (list (` (let [(~+ (|> vars
+ (list.zip/2 ids)
+ (list\map (function (_ [id var])
+ (list (code.local_identifier var)
+ (` (_.var (~ (code.text (format "v" (%.nat id)))))))))
+ list.concat))]
+ (~ body)))))))
+
+(syntax: (runtime: {declaration (<>.or <code>.local_identifier
+ (<code>.form (<>.and <code>.local_identifier
+ (<>.some <code>.local_identifier))))}
+ code)
+ (macro.with_gensyms [g!_ runtime]
+ (let [runtime_name (` (_.var (~ (code.text (%.code runtime)))))]
+ (case declaration
+ (#.Left name)
+ (let [g!name (code.local_identifier name)]
+ (wrap (list (` (def: #export (~ g!name)
+ Var
+ (~ runtime_name)))
+
+ (` (def: (~ (code.local_identifier (format "@" name)))
+ Statement
+ (..feature (~ runtime_name)
+ (function ((~ g!_) (~ g!name))
+ (~ code))))))))
+
+ (#.Right [name inputs])
+ (let [g!name (code.local_identifier name)
+ inputsC (list\map code.local_identifier inputs)
+ inputs_typesC (list\map (function.constant (` _.Expression)) inputs)]
+ (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
+ (-> (~+ inputs_typesC) Computation)
+ (_.apply/* (~ runtime_name) (list (~+ inputsC)))))
+
+ (` (def: (~ (code.local_identifier (format "@" name)))
+ Statement
+ (..feature (~ runtime_name)
+ (function ((~ g!_) (~ g!_))
+ (..with_vars [(~+ inputsC)]
+ (_.function (~ g!_) (list (~+ inputsC))
+ (~ code))))))))))))))
+
+(def: length
+ (-> Expression Computation)
+ (_.the "length"))
+
+(def: last_index
+ (-> Expression Computation)
+ (|>> ..length (_.- (_.i32 +1))))
+
+(def: (last_element tuple)
+ (_.at (..last_index tuple)
+ tuple))
+
+(with_expansions [<recur> (as_is ($_ _.then
+ (_.set lefts (_.- last_index_right lefts))
+ (_.set tuple (_.at last_index_right tuple))))]
+ (runtime: (tuple//left lefts tuple)
+ (with_vars [last_index_right]
+ (<| (_.while (_.boolean true))
+ ($_ _.then
+ (_.define last_index_right (..last_index tuple))
+ (_.if (_.> lefts last_index_right)
+ ## No need for recursion
+ (_.return (_.at lefts tuple))
+ ## Needs recursion
+ <recur>)))))
+
+ (runtime: (tuple//right lefts tuple)
+ (with_vars [last_index_right right_index]
+ (<| (_.while (_.boolean true))
+ ($_ _.then
+ (_.define last_index_right (..last_index tuple))
+ (_.define right_index (_.+ (_.i32 +1) lefts))
+ (_.cond (list [(_.= last_index_right right_index)
+ (_.return (_.at right_index tuple))]
+ [(_.> last_index_right right_index)
+ ## Needs recursion.
+ <recur>])
+ (_.return (_.do "slice" (list right_index) tuple)))
+ )))))
+
+(def: #export variant_tag_field "_lux_tag")
+(def: #export variant_flag_field "_lux_flag")
+(def: #export variant_value_field "_lux_value")
+
+(runtime: variant//new
+ (let [@this (_.var "this")]
+ (with_vars [tag is_last value]
+ (_.closure (list tag is_last value)
+ ($_ _.then
+ (_.set (_.the ..variant_tag_field @this) tag)
+ (_.set (_.the ..variant_flag_field @this) is_last)
+ (_.set (_.the ..variant_value_field @this) value)
+ )))))
+
+(def: #export (variant tag last? value)
+ (-> Expression Expression Expression Computation)
+ (_.new ..variant//new (list tag last? value)))
+
+(runtime: (sum//get sum wants_last wanted_tag)
+ (let [no_match! (_.return _.null)
+ sum_tag (|> sum (_.the ..variant_tag_field))
+ sum_flag (|> sum (_.the ..variant_flag_field))
+ sum_value (|> sum (_.the ..variant_value_field))
+ is_last? (_.= ..unit sum_flag)
+ extact_match! (_.return sum_value)
+ test_recursion! (_.if is_last?
+ ## Must recurse.
+ ($_ _.then
+ (_.set wanted_tag (_.- sum_tag wanted_tag))
+ (_.set sum sum_value))
+ no_match!)
+ extrac_sub_variant! (_.return (..variant (_.- wanted_tag sum_tag) sum_flag sum_value))]
+ (<| (_.while (_.boolean true))
+ (_.cond (list [(_.= wanted_tag sum_tag)
+ (_.if (_.= wants_last sum_flag)
+ extact_match!
+ test_recursion!)]
+ [(_.< wanted_tag sum_tag)
+ test_recursion!]
+ [(_.= ..unit wants_last)
+ extrac_sub_variant!])
+ no_match!))))
+
+(def: none
+ Computation
+ (..variant (_.i32 +0) (flag #0) unit))
+
+(def: some
+ (-> Expression Computation)
+ (..variant (_.i32 +1) (flag #1)))
+
+(def: left
+ (-> Expression Computation)
+ (..variant (_.i32 +0) (flag #0)))
+
+(def: right
+ (-> Expression Computation)
+ (..variant (_.i32 +1) (flag #1)))
+
+(def: runtime//structure
+ Statement
+ ($_ _.then
+ @tuple//left
+ @tuple//right
+ @variant//new
+ @sum//get
+ ))
+
+(runtime: (lux//try op)
+ (with_vars [ex]
+ (_.try (_.return (..right (_.apply/1 op ..unit)))
+ [ex (_.return (..left (|> ex (_.do "toString" (list)))))])))
+
+(runtime: (lux//program_args inputs)
+ (with_vars [output idx]
+ ($_ _.then
+ (_.define output ..none)
+ (_.for idx
+ (..last_index inputs)
+ (_.>= (_.i32 +0) idx)
+ (_.-- idx)
+ (_.set output (..some (_.array (list (_.at idx inputs)
+ output)))))
+ (_.return output))))
+
+(def: runtime//lux
+ Statement
+ ($_ _.then
+ @lux//try
+ @lux//program_args
+ ))
+
+(def: #export i64_low_field Text "_lux_low")
+(def: #export i64_high_field Text "_lux_high")
+
+(runtime: i64//new
+ (let [@this (_.var "this")]
+ (with_vars [high low]
+ (_.closure (list high low)
+ ($_ _.then
+ (_.set (_.the ..i64_high_field @this) high)
+ (_.set (_.the ..i64_low_field @this) low)
+ )))))
+
+(def: #export (i64 high low)
+ (-> Expression Expression Computation)
+ (_.new ..i64//new (list high low)))
+
+(runtime: i64//2^16
+ (_.left_shift (_.i32 +16) (_.i32 +1)))
+
+(runtime: i64//2^32
+ (_.* i64//2^16 i64//2^16))
+
+(runtime: i64//2^64
+ (_.* i64//2^32 i64//2^32))
+
+(runtime: i64//2^63
+ (|> i64//2^64 (_./ (_.i32 +2))))
+
+(runtime: (i64//unsigned_low i64)
+ (_.return (_.? (|> i64 (_.the ..i64_low_field) (_.>= (_.i32 +0)))
+ (|> i64 (_.the ..i64_low_field))
+ (|> i64 (_.the ..i64_low_field) (_.+ i64//2^32)))))
+
+(runtime: (i64//to_number i64)
+ (_.return (|> i64
+ (_.the ..i64_high_field)
+ (_.* i64//2^32)
+ (_.+ (i64//unsigned_low i64)))))
+
+(runtime: i64//zero
+ (..i64 (_.i32 +0) (_.i32 +0)))
+
+(runtime: i64//min
+ (..i64 (_.i32 (.int (hex "80,00,00,00")))
+ (_.i32 +0)))
+
+(runtime: i64//max
+ (..i64 (_.i32 (.int (hex "7F,FF,FF,FF")))
+ (_.i32 (.int (hex "FF,FF,FF,FF")))))
+
+(runtime: i64//one
+ (..i64 (_.i32 +0) (_.i32 +1)))
+
+(runtime: (i64//= reference sample)
+ (_.return (_.and (_.= (_.the ..i64_high_field reference)
+ (_.the ..i64_high_field sample))
+ (_.= (_.the ..i64_low_field reference)
+ (_.the ..i64_low_field sample)))))
+
+(runtime: (i64//+ parameter subject)
+ (let [up_16 (_.left_shift (_.i32 +16))
+ high_16 (_.logic_right_shift (_.i32 +16))
+ low_16 (_.bit_and (_.i32 (.int (hex "FFFF"))))
+ hh (|>> (_.the ..i64_high_field) high_16)
+ hl (|>> (_.the ..i64_high_field) low_16)
+ lh (|>> (_.the ..i64_low_field) high_16)
+ ll (|>> (_.the ..i64_low_field) low_16)]
+ (with_vars [l48 l32 l16 l00
+ r48 r32 r16 r00
+ x48 x32 x16 x00]
+ ($_ _.then
+ (_.define l48 (hh subject))
+ (_.define l32 (hl subject))
+ (_.define l16 (lh subject))
+ (_.define l00 (ll subject))
+
+ (_.define r48 (hh parameter))
+ (_.define r32 (hl parameter))
+ (_.define r16 (lh parameter))
+ (_.define r00 (ll parameter))
+
+ (_.define x00 (_.+ l00 r00))
+
+ (_.define x16 (|> (high_16 x00)
+ (_.+ l16)
+ (_.+ r16)))
+ (_.set x00 (low_16 x00))
+
+ (_.define x32 (|> (high_16 x16)
+ (_.+ l32)
+ (_.+ r32)))
+ (_.set x16 (low_16 x16))
+
+ (_.define x48 (|> (high_16 x32)
+ (_.+ l48)
+ (_.+ r48)
+ low_16))
+ (_.set x32 (low_16 x32))
+
+ (_.return (..i64 (_.bit_or (up_16 x48) x32)
+ (_.bit_or (up_16 x16) x00)))
+ ))))
+
+(template [<name> <op>]
+ [(runtime: (<name> subject parameter)
+ (_.return (..i64 (<op> (_.the ..i64_high_field subject)
+ (_.the ..i64_high_field parameter))
+ (<op> (_.the ..i64_low_field subject)
+ (_.the ..i64_low_field parameter)))))]
+
+ [i64//xor _.bit_xor]
+ [i64//or _.bit_or]
+ [i64//and _.bit_and]
+ )
+
+(runtime: (i64//not value)
+ (_.return (..i64 (_.bit_not (_.the ..i64_high_field value))
+ (_.bit_not (_.the ..i64_low_field value)))))
+
+(runtime: (i64//negate value)
+ (_.return (_.? (i64//= i64//min value)
+ i64//min
+ (i64//+ i64//one (i64//not value)))))
+
+(runtime: i64//-one
+ (i64//negate i64//one))
+
+(runtime: (i64//from_number value)
+ (_.return (<| (_.? (_.not_a_number? value)
+ i64//zero)
+ (_.? (_.<= (_.negate i64//2^63) value)
+ i64//min)
+ (_.? (|> value (_.+ (_.i32 +1)) (_.>= i64//2^63))
+ i64//max)
+ (_.? (|> value (_.< (_.i32 +0)))
+ (|> value _.negate i64//from_number i64//negate))
+ (..i64 (|> value (_./ i64//2^32) _.to_i32)
+ (|> value (_.% i64//2^32) _.to_i32)))))
+
+(def: (cap_shift! shift)
+ (-> Var Statement)
+ (_.set shift (|> shift (_.bit_and (_.i32 +63)))))
+
+(def: (no_shift! shift input)
+ (-> Var Var (-> Expression Expression))
+ (_.? (|> shift (_.= (_.i32 +0)))
+ input))
+
+(def: small_shift?
+ (-> Var Expression)
+ (|>> (_.< (_.i32 +32))))
+
+(runtime: (i64//left_shift input shift)
+ ($_ _.then
+ (..cap_shift! shift)
+ (_.return (<| (..no_shift! shift input)
+ (_.? (..small_shift? shift)
+ (let [high (_.bit_or (|> input (_.the ..i64_high_field) (_.left_shift shift))
+ (|> input (_.the ..i64_low_field) (_.logic_right_shift (_.- shift (_.i32 +32)))))
+ low (|> input (_.the ..i64_low_field) (_.left_shift shift))]
+ (..i64 high low)))
+ (let [high (|> input (_.the ..i64_low_field) (_.left_shift (_.- (_.i32 +32) shift)))]
+ (..i64 high (_.i32 +0)))))
+ ))
+
+(runtime: (i64//arithmetic_right_shift input shift)
+ ($_ _.then
+ (..cap_shift! shift)
+ (_.return (<| (..no_shift! shift input)
+ (_.? (..small_shift? shift)
+ (let [high (|> input (_.the ..i64_high_field) (_.arithmetic_right_shift shift))
+ low (|> input (_.the ..i64_low_field) (_.logic_right_shift shift)
+ (_.bit_or (|> input (_.the ..i64_high_field) (_.left_shift (_.- shift (_.i32 +32))))))]
+ (..i64 high low)))
+ (let [high (_.? (|> input (_.the ..i64_high_field) (_.>= (_.i32 +0)))
+ (_.i32 +0)
+ (_.i32 -1))
+ low (|> input (_.the ..i64_high_field) (_.arithmetic_right_shift (_.- (_.i32 +32) shift)))]
+ (..i64 high low))))))
+
+(runtime: (i64//right_shift input shift)
+ ($_ _.then
+ (..cap_shift! shift)
+ (_.return (<| (..no_shift! shift input)
+ (_.? (..small_shift? shift)
+ (let [high (|> input (_.the ..i64_high_field) (_.logic_right_shift shift))
+ low (|> input (_.the ..i64_low_field) (_.logic_right_shift shift)
+ (_.bit_or (|> input (_.the ..i64_high_field) (_.left_shift (_.- shift (_.i32 +32))))))]
+ (..i64 high low)))
+ (_.? (|> shift (_.= (_.i32 +32)))
+ (..i64 (_.i32 +0) (|> input (_.the ..i64_high_field))))
+ (..i64 (_.i32 +0)
+ (|> input (_.the ..i64_high_field) (_.logic_right_shift (_.- (_.i32 +32) shift))))))))
+
+(def: runtime//bit
+ Statement
+ ($_ _.then
+ @i64//and
+ @i64//or
+ @i64//xor
+ @i64//not
+ @i64//left_shift
+ @i64//arithmetic_right_shift
+ @i64//right_shift
+ ))
+
+(runtime: (i64//- parameter subject)
+ (_.return (i64//+ (i64//negate parameter) subject)))
+
+(runtime: (i64//* parameter subject)
+ (let [up_16 (_.left_shift (_.i32 +16))
+ high_16 (_.logic_right_shift (_.i32 +16))
+ low_16 (_.bit_and (_.i32 (.int (hex "FFFF"))))
+ hh (|>> (_.the ..i64_high_field) high_16)
+ hl (|>> (_.the ..i64_high_field) low_16)
+ lh (|>> (_.the ..i64_low_field) high_16)
+ ll (|>> (_.the ..i64_low_field) low_16)]
+ (with_vars [l48 l32 l16 l00
+ r48 r32 r16 r00
+ x48 x32 x16 x00]
+ ($_ _.then
+ (_.define l48 (hh subject))
+ (_.define l32 (hl subject))
+ (_.define l16 (lh subject))
+ (_.define l00 (ll subject))
+
+ (_.define r48 (hh parameter))
+ (_.define r32 (hl parameter))
+ (_.define r16 (lh parameter))
+ (_.define r00 (ll parameter))
+
+ (_.define x00 (_.* l00 r00))
+ (_.define x16 (high_16 x00))
+ (_.set x00 (low_16 x00))
+
+ (_.set x16 (|> x16 (_.+ (_.* l16 r00))))
+ (_.define x32 (high_16 x16)) (_.set x16 (low_16 x16))
+ (_.set x16 (|> x16 (_.+ (_.* l00 r16))))
+ (_.set x32 (|> x32 (_.+ (high_16 x16)))) (_.set x16 (low_16 x16))
+
+ (_.set x32 (|> x32 (_.+ (_.* l32 r00))))
+ (_.define x48 (high_16 x32)) (_.set x32 (low_16 x32))
+ (_.set x32 (|> x32 (_.+ (_.* l16 r16))))
+ (_.set x48 (|> x48 (_.+ (high_16 x32)))) (_.set x32 (low_16 x32))
+ (_.set x32 (|> x32 (_.+ (_.* l00 r32))))
+ (_.set x48 (|> x48 (_.+ (high_16 x32)))) (_.set x32 (low_16 x32))
+
+ (_.set x48 (|> x48
+ (_.+ (_.* l48 r00))
+ (_.+ (_.* l32 r16))
+ (_.+ (_.* l16 r32))
+ (_.+ (_.* l00 r48))
+ low_16))
+
+ (_.return (..i64 (_.bit_or (up_16 x48) x32)
+ (_.bit_or (up_16 x16) x00)))
+ ))))
+
+(runtime: (i64//< parameter subject)
+ (let [negative? (|>> (_.the ..i64_high_field) (_.< (_.i32 +0)))]
+ (with_vars [-subject? -parameter?]
+ ($_ _.then
+ (_.define -subject? (negative? subject))
+ (_.define -parameter? (negative? parameter))
+ (_.return (<| (_.? (_.and -subject? (_.not -parameter?))
+ (_.boolean true))
+ (_.? (_.and (_.not -subject?) -parameter?)
+ (_.boolean false))
+ (negative? (i64//- parameter subject))))
+ ))))
+
+(def: (i64//<= param subject)
+ (-> Expression Expression Expression)
+ (|> (i64//< param subject)
+ (_.or (i64//= param subject))))
+
+(runtime: (i64/// parameter subject)
+ (let [negative? (function (_ value)
+ (i64//< i64//zero value))
+ valid_division_check [(i64//= i64//zero parameter)
+ (_.throw (_.string "Cannot divide by zero!"))]
+ short_circuit_check [(i64//= i64//zero subject)
+ (_.return i64//zero)]]
+ (_.cond (list valid_division_check
+ short_circuit_check
+
+ [(i64//= i64//min subject)
+ (_.cond (list [(_.or (i64//= i64//one parameter)
+ (i64//= i64//-one parameter))
+ (_.return i64//min)]
+ [(i64//= i64//min parameter)
+ (_.return i64//one)])
+ (with_vars [approximation]
+ (let [subject/2 (..i64//arithmetic_right_shift subject (_.i32 +1))]
+ ($_ _.then
+ (_.define approximation (i64//left_shift (i64/// parameter
+ subject/2)
+ (_.i32 +1)))
+ (_.if (i64//= i64//zero approximation)
+ (_.return (_.? (negative? parameter)
+ i64//one
+ i64//-one))
+ (let [remainder (i64//- (i64//* approximation
+ parameter)
+ subject)]
+ (_.return (i64//+ (i64/// parameter
+ remainder)
+ approximation))))))))]
+ [(i64//= i64//min parameter)
+ (_.return i64//zero)]
+
+ [(negative? subject)
+ (_.return (_.? (negative? parameter)
+ (i64/// (i64//negate parameter)
+ (i64//negate subject))
+ (i64//negate (i64/// parameter
+ (i64//negate subject)))))]
+
+ [(negative? parameter)
+ (_.return (i64//negate (i64/// (i64//negate parameter) subject)))])
+ (with_vars [result remainder]
+ ($_ _.then
+ (_.define result i64//zero)
+ (_.define remainder subject)
+ (_.while (i64//<= remainder parameter)
+ (with_vars [approximate approximate_result approximate_remainder log2 delta]
+ (let [approximate_result' (i64//from_number approximate)
+ approx_remainder (i64//* parameter approximate_result)]
+ ($_ _.then
+ (_.define approximate (|> (i64//to_number remainder)
+ (_./ (i64//to_number parameter))
+ (_.apply/1 (_.var "Math.floor"))
+ (_.apply/2 (_.var "Math.max") (_.i32 +1))))
+ (_.define log2 (|> approximate
+ (_.apply/1 (_.var "Math.log"))
+ (_./ (_.var "Math.LN2"))
+ (_.apply/1 (_.var "Math.ceil"))))
+ (_.define delta (_.? (_.<= (_.i32 +48) log2)
+ (_.i32 +1)
+ (_.apply/2 (_.var "Math.pow")
+ (_.i32 +2)
+ (_.- (_.i32 +48)
+ log2))))
+ (_.define approximate_result approximate_result')
+ (_.define approximate_remainder approx_remainder)
+ (_.while (_.or (negative? approximate_remainder)
+ (i64//< approximate_remainder
+ remainder))
+ ($_ _.then
+ (_.set approximate (_.- delta approximate))
+ (_.set approximate_result approximate_result')
+ (_.set approximate_remainder approx_remainder)))
+ (_.set result (i64//+ (_.? (i64//= i64//zero approximate_result)
+ i64//one
+ approximate_result)
+ result))
+ (_.set remainder (i64//- approximate_remainder remainder))))))
+ (_.return result)))
+ )))
+
+(runtime: (i64//% parameter subject)
+ (let [flat (|> subject
+ (i64/// parameter)
+ (i64//* parameter))]
+ (_.return (i64//- flat subject))))
+
+(def: runtime//i64
+ Statement
+ ($_ _.then
+ @i64//2^16
+ @i64//2^32
+ @i64//2^64
+ @i64//2^63
+ @i64//unsigned_low
+ @i64//new
+ @i64//zero
+ @i64//min
+ @i64//max
+ @i64//one
+ @i64//=
+ @i64//+
+ @i64//negate
+ @i64//to_number
+ @i64//from_number
+ @i64//-
+ @i64//*
+ @i64//<
+ @i64///
+ @i64//%
+ runtime//bit
+ ))
+
+(runtime: (text//index start part text)
+ (with_vars [idx]
+ ($_ _.then
+ (_.define idx (|> text (_.do "indexOf" (list part (i64//to_number start)))))
+ (_.return (_.? (_.= (_.i32 -1) idx)
+ ..none
+ (..some (i64//from_number idx)))))))
+
+(runtime: (text//clip offset length text)
+ (_.return (|> text (_.do "substring" (list (_.the ..i64_low_field offset)
+ (_.+ (_.the ..i64_low_field offset)
+ (_.the ..i64_low_field length)))))))
+
+(runtime: (text//char idx text)
+ (with_vars [result]
+ ($_ _.then
+ (_.define result (|> text (_.do "charCodeAt" (list (_.the ..i64_low_field idx)))))
+ (_.if (_.not_a_number? result)
+ (_.throw (_.string "[Lux Error] Cannot get char from text."))
+ (_.return (i64//from_number result))))))
+
+(def: runtime//text
+ Statement
+ ($_ _.then
+ @text//index
+ @text//clip
+ @text//char
+ ))
+
+(runtime: (io//log message)
+ (let [console (_.var "console")
+ print (_.var "print")
+ end! (_.return ..unit)]
+ (_.cond (list [(|> console _.type_of (_.= (_.string "undefined")) _.not
+ (_.and (_.the "log" console)))
+ ($_ _.then
+ (_.statement (|> console (_.do "log" (list message))))
+ end!)]
+ [(|> print _.type_of (_.= (_.string "undefined")) _.not)
+ ($_ _.then
+ (_.statement (_.apply/1 print (_.? (_.= (_.string "string")
+ (_.type_of message))
+ message
+ (_.apply/1 (_.var "JSON.stringify") message))))
+ end!)])
+ end!)))
+
+(runtime: (io//error message)
+ (_.throw message))
+
+(def: runtime//io
+ Statement
+ ($_ _.then
+ @io//log
+ @io//error
+ ))
+
+(runtime: (js//get object field)
+ (with_vars [temp]
+ ($_ _.then
+ (_.define temp (_.at field object))
+ (_.return (_.? (_.= _.undefined temp)
+ ..none
+ (..some temp))))))
+
+(runtime: (js//set object field input)
+ ($_ _.then
+ (_.set (_.at field object) input)
+ (_.return object)))
+
+(runtime: (js//delete object field)
+ ($_ _.then
+ (_.delete (_.at field object))
+ (_.return object)))
+
+(def: runtime//js
+ Statement
+ ($_ _.then
+ @js//get
+ @js//set
+ @js//delete
+ ))
+
+(runtime: (array//write idx value array)
+ ($_ _.then
+ (_.set (_.at (_.the ..i64_low_field idx) array) value)
+ (_.return array)))
+
+(runtime: (array//delete idx array)
+ ($_ _.then
+ (_.delete (_.at (_.the ..i64_low_field idx) array))
+ (_.return array)))
+
+(def: runtime//array
+ Statement
+ ($_ _.then
+ @array//write
+ @array//delete
+ ))
+
+(def: runtime
+ Statement
+ ($_ _.then
+ runtime//structure
+ runtime//i64
+ runtime//text
+ runtime//io
+ runtime//js
+ runtime//array
+ runtime//lux
+ ))
+
+(def: module_id
+ 0)
+
+(def: #export generate
+ (Operation [Registry Output])
+ (do ///////phase.monad
+ [_ (/////generation.execute! ..runtime)
+ _ (/////generation.save! ..module_id ..runtime)]
+ (wrap [(|> artifact.empty
+ artifact.resource
+ product.right)
+ (row.row [..module_id
+ (|> ..runtime
+ _.code
+ (\ utf8.codec encode))])])))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/structure.lux
new file mode 100644
index 000000000..8c68d5b23
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/structure.lux
@@ -0,0 +1,38 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [target
+ ["_" js (#+ Expression)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." primitive]
+ ["///#" //// #_
+ [analysis (#+ Variant Tuple)]
+ ["#." synthesis (#+ Synthesis)]
+ ["//#" ///
+ ["#." phase ("#\." monad)]]]])
+
+(def: #export (tuple generate archive elemsS+)
+ (Generator (Tuple Synthesis))
+ (case elemsS+
+ #.Nil
+ (///////phase\wrap //runtime.unit)
+
+ (#.Cons singletonS #.Nil)
+ (generate archive singletonS)
+
+ _
+ (do {! ///////phase.monad}
+ [elemsT+ (monad.map ! (generate archive) elemsS+)]
+ (wrap (_.array elemsT+)))))
+
+(def: #export (variant generate archive [lefts right? valueS])
+ (Generator (Variant Synthesis))
+ (let [tag (if right?
+ (inc lefts)
+ lefts)]
+ (///////phase\map (//runtime.variant (_.i32 (.int tag))
+ (//runtime.flag right?))
+ (generate archive valueS))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm.lux
new file mode 100644
index 000000000..e8357027d
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm.lux
@@ -0,0 +1,73 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]]]
+ ["." / #_
+ [runtime (#+ Phase)]
+ ["#." primitive]
+ ["#." structure]
+ ["#." reference]
+ ["#." function]
+ ["#." case]
+ ["#." loop]
+ ["//#" /// #_
+ ["#." extension]
+ [//
+ ["." synthesis]
+ [///
+ ["." reference]
+ ["#" phase ("#\." monad)]]]]])
+
+(def: #export (generate archive synthesis)
+ Phase
+ (case synthesis
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (///\wrap (<generator> value))])
+ ([synthesis.bit /primitive.bit]
+ [synthesis.i64 /primitive.i64]
+ [synthesis.f64 /primitive.f64]
+ [synthesis.text /primitive.text])
+
+ (^ (synthesis.variant variantS))
+ (/structure.variant generate archive variantS)
+
+ (^ (synthesis.tuple members))
+ (/structure.tuple generate archive members)
+
+ (#synthesis.Reference reference)
+ (case reference
+ (#reference.Variable variable)
+ (/reference.variable archive variable)
+
+ (#reference.Constant constant)
+ (/reference.constant archive constant))
+
+ (^ (synthesis.branch/case [valueS pathS]))
+ (/case.case generate archive [valueS pathS])
+
+ (^ (synthesis.branch/let [inputS register bodyS]))
+ (/case.let generate archive [inputS register bodyS])
+
+ (^ (synthesis.branch/if [conditionS thenS elseS]))
+ (/case.if generate archive [conditionS thenS elseS])
+
+ (^ (synthesis.branch/get [path recordS]))
+ (/case.get generate archive [path recordS])
+
+ (^ (synthesis.loop/scope scope))
+ (/loop.scope generate archive scope)
+
+ (^ (synthesis.loop/recur updates))
+ (/loop.recur generate archive updates)
+
+ (^ (synthesis.function/abstraction abstraction))
+ (/function.abstraction generate archive abstraction)
+
+ (^ (synthesis.function/apply application))
+ (/function.apply generate archive application)
+
+ (#synthesis.Extension extension)
+ (///extension.apply archive generate extension)
+ ))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux
new file mode 100644
index 000000000..7d2416d67
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux
@@ -0,0 +1,266 @@
+(.module:
+ [library
+ [lux (#- Type if let case int)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]]
+ [data
+ [number
+ ["." i32]
+ ["n" nat]]
+ [collection
+ ["." list ("#\." fold)]]]
+ [target
+ [jvm
+ ["_" bytecode (#+ Label Bytecode) ("#\." monad)]
+ ["." type (#+ Type)
+ [category (#+ Method)]]]]]]
+ ["." // #_
+ ["#." type]
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." value]
+ ["#." structure]
+ [////
+ ["." synthesis (#+ Path Synthesis)]
+ ["." generation]
+ [///
+ ["." phase ("operation\." monad)]
+ [reference
+ [variable (#+ Register)]]]]])
+
+(def: equals-name
+ "equals")
+
+(def: equals-type
+ (type.method [(list //type.value) type.boolean (list)]))
+
+(def: (pop-alt stack-depth)
+ (-> Nat (Bytecode Any))
+ (.case stack-depth
+ 0 (_\wrap [])
+ 1 _.pop
+ 2 _.pop2
+ _ ## (n.> 2)
+ ($_ _.compose
+ _.pop2
+ (pop-alt (n.- 2 stack-depth)))))
+
+(def: int
+ (-> (I64 Any) (Bytecode Any))
+ (|>> .i64 i32.i32 _.int))
+
+(def: long
+ (-> (I64 Any) (Bytecode Any))
+ (|>> .int _.long))
+
+(def: double
+ (-> Frac (Bytecode Any))
+ (|>> _.double))
+
+(def: peek
+ (Bytecode Any)
+ ($_ _.compose
+ _.dup
+ (//runtime.get //runtime.stack-head)))
+
+(def: pop
+ (Bytecode Any)
+ ($_ _.compose
+ (//runtime.get //runtime.stack-tail)
+ (_.checkcast //type.stack)))
+
+(def: (left-projection lefts)
+ (-> Nat (Bytecode Any))
+ ($_ _.compose
+ (_.checkcast //type.tuple)
+ (..int lefts)
+ (.case lefts
+ 0
+ _.aaload
+
+ lefts
+ //runtime.left-projection)))
+
+(def: (right-projection lefts)
+ (-> Nat (Bytecode Any))
+ ($_ _.compose
+ (_.checkcast //type.tuple)
+ (..int lefts)
+ //runtime.right-projection))
+
+(def: (path' stack-depth @else @end phase archive path)
+ (-> Nat Label Label (Generator Path))
+ (.case path
+ #synthesis.Pop
+ (operation\wrap ..pop)
+
+ (#synthesis.Bind register)
+ (operation\wrap ($_ _.compose
+ ..peek
+ (_.astore register)))
+
+ (#synthesis.Then bodyS)
+ (do phase.monad
+ [bodyG (phase archive bodyS)]
+ (wrap ($_ _.compose
+ (..pop-alt stack-depth)
+ bodyG
+ (_.goto @end))))
+
+ (^template [<pattern> <right?>]
+ [(^ (<pattern> lefts))
+ (operation\wrap
+ (do _.monad
+ [@success _.new-label
+ @fail _.new-label]
+ ($_ _.compose
+ ..peek
+ (_.checkcast //type.variant)
+ (//structure.tag lefts <right?>)
+ (//structure.flag <right?>)
+ //runtime.case
+ _.dup
+ (_.ifnull @fail)
+ (_.goto @success)
+ (_.set-label @fail)
+ _.pop
+ (_.goto @else)
+ (_.set-label @success)
+ //runtime.push)))])
+ ([synthesis.side/left false]
+ [synthesis.side/right true])
+
+ (^template [<pattern> <projection>]
+ [(^ (<pattern> lefts))
+ (operation\wrap ($_ _.compose
+ ..peek
+ (<projection> lefts)
+ //runtime.push))])
+ ([synthesis.member/left ..left-projection]
+ [synthesis.member/right ..right-projection])
+
+ ## Extra optimization
+ (^ (synthesis.path/seq
+ (synthesis.member/left 0)
+ (synthesis.!bind-top register thenP)))
+ (do phase.monad
+ [thenG (path' stack-depth @else @end phase archive thenP)]
+ (wrap ($_ _.compose
+ ..peek
+ (_.checkcast //type.tuple)
+ _.iconst-0
+ _.aaload
+ (_.astore register)
+ thenG)))
+
+ ## Extra optimization
+ (^template [<pm> <projection>]
+ [(^ (synthesis.path/seq
+ (<pm> lefts)
+ (synthesis.!bind-top register thenP)))
+ (do phase.monad
+ [then! (path' stack-depth @else @end phase archive thenP)]
+ (wrap ($_ _.compose
+ ..peek
+ (_.checkcast //type.tuple)
+ (..int lefts)
+ <projection>
+ (_.astore register)
+ then!)))])
+ ([synthesis.member/left //runtime.left-projection]
+ [synthesis.member/right //runtime.right-projection])
+
+ (#synthesis.Alt leftP rightP)
+ (do phase.monad
+ [@alt-else //runtime.forge-label
+ left! (path' (inc stack-depth) @alt-else @end phase archive leftP)
+ right! (path' stack-depth @else @end phase archive rightP)]
+ (wrap ($_ _.compose
+ _.dup
+ left!
+ (_.set-label @alt-else)
+ _.pop
+ right!)))
+
+ (#synthesis.Seq leftP rightP)
+ (do phase.monad
+ [left! (path' stack-depth @else @end phase archive leftP)
+ right! (path' stack-depth @else @end phase archive rightP)]
+ (wrap ($_ _.compose
+ left!
+ right!)))
+
+ _
+ (undefined)
+ ))
+
+(def: (path @end phase archive path)
+ (-> Label (Generator Path))
+ (do phase.monad
+ [@else //runtime.forge-label
+ pathG (..path' 1 @else @end phase archive path)]
+ (wrap ($_ _.compose
+ pathG
+ (_.set-label @else)
+ _.pop
+ //runtime.pm-failure
+ _.aconst-null
+ (_.goto @end)))))
+
+(def: #export (if phase archive [conditionS thenS elseS])
+ (Generator [Synthesis Synthesis Synthesis])
+ (do phase.monad
+ [conditionG (phase archive conditionS)
+ thenG (phase archive thenS)
+ elseG (phase archive elseS)]
+ (wrap (do _.monad
+ [@else _.new-label
+ @end _.new-label]
+ ($_ _.compose
+ conditionG
+ (//value.unwrap type.boolean)
+ (_.ifeq @else)
+ thenG
+ (_.goto @end)
+ (_.set-label @else)
+ elseG
+ (_.set-label @end))))))
+
+(def: #export (let phase archive [inputS register bodyS])
+ (Generator [Synthesis Register Synthesis])
+ (do phase.monad
+ [inputG (phase archive inputS)
+ bodyG (phase archive bodyS)]
+ (wrap ($_ _.compose
+ inputG
+ (_.astore register)
+ bodyG))))
+
+(def: #export (get phase archive [path recordS])
+ (Generator [(List synthesis.Member) Synthesis])
+ (do phase.monad
+ [recordG (phase archive recordS)]
+ (wrap (list\fold (function (_ step so-far)
+ (.let [next (.case step
+ (#.Left lefts)
+ (..left-projection lefts)
+
+ (#.Right lefts)
+ (..right-projection lefts))]
+ (_.compose so-far next)))
+ recordG
+ (list.reverse path)))))
+
+(def: #export (case phase archive [valueS path])
+ (Generator [Synthesis Path])
+ (do phase.monad
+ [@end //runtime.forge-label
+ valueG (phase archive valueS)
+ pathG (..path @end phase archive path)]
+ (wrap ($_ _.compose
+ _.aconst-null
+ valueG
+ //runtime.push
+ pathG
+ (_.set-label @end)))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux
new file mode 100644
index 000000000..65c141283
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux
@@ -0,0 +1,31 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io (#+ IO)]
+ ["." try (#+ Try)]]
+ [data
+ [binary (#+ Binary)]
+ [text
+ ["%" format (#+ format)]]]
+ [world
+ ["." file (#+ File)]]]])
+
+(def: extension ".class")
+
+(def: #export (write-class! name bytecode)
+ (-> Text Binary (IO Text))
+ (let [file-path (format name ..extension)]
+ (do io.monad
+ [outcome (do (try.with @)
+ [file (: (IO (Try (File IO)))
+ (file.get-file io.monad file.default file-path))]
+ (\ file over-write bytecode))]
+ (wrap (case outcome
+ (#try.Success definition)
+ file-path
+
+ (#try.Failure error)
+ error)))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux
new file mode 100644
index 000000000..37cda09e1
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux
@@ -0,0 +1,135 @@
+(.module:
+ [library
+ [lux (#- Type)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ [number
+ ["." i32]
+ ["n" nat]]
+ [collection
+ ["." list ("#\." monoid functor)]
+ ["." row]]
+ ["." format #_
+ ["#" binary]]]
+ [target
+ [jvm
+ ["." version]
+ ["." modifier (#+ Modifier) ("#\." monoid)]
+ ["." field (#+ Field)]
+ ["." method (#+ Method)]
+ ["_" bytecode (#+ Label Bytecode) ("#\." monad)]
+ ["." class (#+ Class)]
+ ["." type (#+ Type)
+ [category (#+ Return' Value')]
+ ["." reflection]]
+ ["." constant
+ [pool (#+ Resource)]]
+ [encoding
+ ["." name (#+ External Internal)]
+ ["." unsigned]]]]
+ [tool
+ [compiler
+ [meta
+ ["." archive (#+ Archive)]]]]]]
+ ["." / #_
+ ["#." abstract]
+ [field
+ [constant
+ ["#." arity]]
+ [variable
+ ["#." foreign]
+ ["#." partial]]]
+ [method
+ ["#." init]
+ ["#." new]
+ ["#." implementation]
+ ["#." reset]
+ ["#." apply]]
+ ["/#" // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ [////
+ [analysis (#+ Environment)]
+ [synthesis (#+ Synthesis Abstraction Apply)]
+ ["." generation]
+ [///
+ ["." arity (#+ Arity)]
+ ["." phase]
+ [reference
+ [variable (#+ Register)]]]]]])
+
+(def: #export (with generate archive @begin class environment arity body)
+ (-> Phase Archive Label External (Environment Synthesis) Arity (Bytecode Any)
+ (Operation [(List (Resource Field))
+ (List (Resource Method))
+ (Bytecode Any)]))
+ (let [classT (type.class class (list))
+ fields (: (List (Resource Field))
+ (list& /arity.constant
+ (list\compose (/foreign.variables environment)
+ (/partial.variables arity))))
+ methods (: (List (Resource Method))
+ (list& (/init.method classT environment arity)
+ (/reset.method classT environment arity)
+ (if (arity.multiary? arity)
+ (|> (n.min arity /arity.maximum)
+ list.indices
+ (list\map (|>> inc (/apply.method classT environment arity @begin body)))
+ (list& (/implementation.method arity @begin body)))
+ (list (/implementation.method' //runtime.apply::name arity @begin body)))))]
+ (do phase.monad
+ [instance (/new.instance generate archive classT environment arity)]
+ (wrap [fields methods instance]))))
+
+(def: modifier
+ (Modifier Class)
+ ($_ modifier\compose
+ class.public
+ class.final))
+
+(def: this-offset 1)
+
+(def: internal
+ (All [category]
+ (-> (Type (<| Return' Value' category))
+ Internal))
+ (|>> type.reflection reflection.reflection name.internal))
+
+(def: #export (abstraction generate archive [environment arity bodyS])
+ (Generator Abstraction)
+ (do phase.monad
+ [@begin //runtime.forge-label
+ [function-context bodyG] (generation.with-new-context archive
+ (generation.with-anchor [@begin ..this-offset]
+ (generate archive bodyS)))
+ #let [function-class (//runtime.class-name function-context)]
+ [fields methods instance] (..with generate archive @begin function-class environment arity bodyG)
+ class (phase.lift (class.class version.v6_0
+ ..modifier
+ (name.internal function-class)
+ (..internal /abstract.class) (list)
+ fields
+ methods
+ (row.row)))
+ #let [bytecode (format.run class.writer class)]
+ _ (generation.execute! [function-class bytecode])
+ _ (generation.save! function-class [function-class bytecode])]
+ (wrap instance)))
+
+(def: #export (apply generate archive [abstractionS inputsS])
+ (Generator Apply)
+ (do {! phase.monad}
+ [abstractionG (generate archive abstractionS)
+ inputsG (monad.map ! (generate archive) inputsS)]
+ (wrap ($_ _.compose
+ abstractionG
+ (|> inputsG
+ (list.chunk /arity.maximum)
+ (monad.map _.monad
+ (function (_ batchG)
+ ($_ _.compose
+ (_.checkcast /abstract.class)
+ (monad.seq _.monad batchG)
+ (_.invokevirtual /abstract.class //runtime.apply::name (//runtime.apply::type (list.size batchG)))
+ ))))
+ ))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux
new file mode 100644
index 000000000..fea8a985e
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux
@@ -0,0 +1,24 @@
+(.module:
+ [library
+ [lux (#- Type)
+ [data
+ [text
+ ["%" format]]]
+ [target
+ [jvm
+ ["." type (#+ Type)
+ [category (#+ Method)]]]]]]
+ [//
+ [field
+ [constant
+ ["." arity]]]])
+
+(def: #export artifact_id
+ 1)
+
+(def: #export class
+ (type.class (%.nat artifact_id) (list)))
+
+(def: #export init
+ (Type Method)
+ (type.method [(list arity.type) type.void (list)]))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux
new file mode 100644
index 000000000..d6bb70600
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux
@@ -0,0 +1,26 @@
+(.module:
+ [library
+ [lux (#- Type type)
+ [data
+ [collection
+ ["." row]]]
+ [target
+ [jvm
+ ["." field (#+ Field)]
+ ["." modifier (#+ Modifier) ("#\." monoid)]
+ [type (#+ Type)
+ [category (#+ Value)]]
+ [constant
+ [pool (#+ Resource)]]]]]])
+
+(def: modifier
+ (Modifier Field)
+ ($_ modifier\compose
+ field.public
+ field.static
+ field.final
+ ))
+
+(def: #export (constant name type)
+ (-> Text (Type Value) (Resource Field))
+ (field.field ..modifier name type (row.row)))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux
new file mode 100644
index 000000000..a1e0a589d
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux
@@ -0,0 +1,22 @@
+(.module:
+ [library
+ [lux (#- type)
+ [target
+ [jvm
+ ["." type]
+ ["." field (#+ Field)]
+ [constant
+ [pool (#+ Resource)]]]]]]
+ ["." //
+ [/////////
+ [arity (#+ Arity)]]])
+
+(def: #export name "arity")
+(def: #export type type.int)
+
+(def: #export minimum Arity 1)
+(def: #export maximum Arity 8)
+
+(def: #export constant
+ (Resource Field)
+ (//.constant ..name ..type))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux
new file mode 100644
index 000000000..aa200182d
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux
@@ -0,0 +1,56 @@
+(.module:
+ [library
+ [lux (#- Type type)
+ [data
+ [collection
+ ["." list ("#\." functor)]
+ ["." row]]]
+ [target
+ [jvm
+ ["." modifier (#+ Modifier) ("#\." monoid)]
+ ["." field (#+ Field)]
+ ["_" bytecode (#+ Bytecode)]
+ [type (#+ Type)
+ [category (#+ Value Class)]]
+ [constant
+ [pool (#+ Resource)]]]]]]
+ ["." //// #_
+ ["#." type]
+ ["#." reference]
+ [//////
+ [reference
+ [variable (#+ Register)]]]])
+
+(def: #export type ////type.value)
+
+(def: #export (get class name)
+ (-> (Type Class) Text (Bytecode Any))
+ ($_ _.compose
+ ////reference.this
+ (_.getfield class name ..type)
+ ))
+
+(def: #export (put naming class register value)
+ (-> (-> Register Text) (Type Class) Register (Bytecode Any) (Bytecode Any))
+ ($_ _.compose
+ ////reference.this
+ value
+ (_.putfield class (naming register) ..type)))
+
+(def: modifier
+ (Modifier Field)
+ ($_ modifier\compose
+ field.private
+ field.final
+ ))
+
+(def: #export (variable name type)
+ (-> Text (Type Value) (Resource Field))
+ (field.field ..modifier name type (row.row)))
+
+(def: #export (variables naming amount)
+ (-> (-> Register Text) Nat (List (Resource Field)))
+ (|> amount
+ list.indices
+ (list\map (function (_ register)
+ (..variable (naming register) ..type)))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux
new file mode 100644
index 000000000..4506bb2f8
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux
@@ -0,0 +1,40 @@
+(.module:
+ [library
+ [lux (#- Type)
+ [data
+ [collection
+ ["." list]
+ ["." row]]]
+ [target
+ [jvm
+ ["_" bytecode (#+ Bytecode)]
+ ["." field (#+ Field)]
+ [constant
+ [pool (#+ Resource)]]
+ [type (#+ Type)
+ [category (#+ Value Class)]]]]]]
+ ["." //
+ ["///#" //// #_
+ ["#." reference]
+ [////
+ [analysis (#+ Environment)]
+ [synthesis (#+ Synthesis)]
+ [///
+ [reference
+ [variable (#+ Register)]]]]]])
+
+(def: #export (closure environment)
+ (-> (Environment Synthesis) (List (Type Value)))
+ (list.repeat (list.size environment) //.type))
+
+(def: #export (get class register)
+ (-> (Type Class) Register (Bytecode Any))
+ (//.get class (/////reference.foreign-name register)))
+
+(def: #export (put class register value)
+ (-> (Type Class) Register (Bytecode Any) (Bytecode Any))
+ (//.put /////reference.foreign-name class register value))
+
+(def: #export variables
+ (-> (Environment Synthesis) (List (Resource Field)))
+ (|>> list.size (//.variables /////reference.foreign-name)))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux
new file mode 100644
index 000000000..0a2e25b3d
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux
@@ -0,0 +1,59 @@
+(.module:
+ [library
+ [lux (#- Type)
+ [abstract
+ ["." monad]]
+ [data
+ [number
+ ["n" nat]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." row]]]
+ [target
+ [jvm
+ ["." field (#+ Field)]
+ ["_" bytecode (#+ Label Bytecode) ("#\." monad)]
+ [type (#+ Type)
+ [category (#+ Class)]]
+ [constant
+ [pool (#+ Resource)]]]]]]
+ ["." / #_
+ ["#." count]
+ ["/#" //
+ ["/#" // #_
+ [constant
+ ["#." arity]]
+ ["//#" /// #_
+ ["#." reference]
+ [//////
+ ["." arity (#+ Arity)]
+ [reference
+ [variable (#+ Register)]]]]]]])
+
+(def: #export (initial amount)
+ (-> Nat (Bytecode Any))
+ ($_ _.compose
+ (|> _.aconst-null
+ (list.repeat amount)
+ (monad.seq _.monad))
+ (_\wrap [])))
+
+(def: #export (get class register)
+ (-> (Type Class) Register (Bytecode Any))
+ (//.get class (/////reference.partial-name register)))
+
+(def: #export (put class register value)
+ (-> (Type Class) Register (Bytecode Any) (Bytecode Any))
+ (//.put /////reference.partial-name class register value))
+
+(def: #export variables
+ (-> Arity (List (Resource Field)))
+ (|>> (n.- ///arity.minimum) (//.variables /////reference.partial-name)))
+
+(def: #export (new arity)
+ (-> Arity (Bytecode Any))
+ (if (arity.multiary? arity)
+ ($_ _.compose
+ /count.initial
+ (initial (n.- ///arity.minimum arity)))
+ (_\wrap [])))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux
new file mode 100644
index 000000000..5497cc094
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux
@@ -0,0 +1,31 @@
+(.module:
+ [library
+ [lux (#- type)
+ [control
+ ["." try]]
+ [target
+ [jvm
+ ["_" bytecode (#+ Bytecode)]
+ [encoding
+ [name (#+ External)]
+ ["." signed]]
+ ["." type]]]]]
+ ["." ///// #_
+ ["#." abstract]])
+
+(def: #export field "partials")
+(def: #export type type.int)
+
+(def: #export initial
+ (Bytecode Any)
+ (|> +0 signed.s1 try.assume _.bipush))
+
+(def: this
+ _.aload_0)
+
+(def: #export value
+ (Bytecode Any)
+ ($_ _.compose
+ ..this
+ (_.getfield /////abstract.class ..field ..type)
+ ))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux
new file mode 100644
index 000000000..9cbde4b63
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux
@@ -0,0 +1,14 @@
+(.module:
+ [library
+ [lux #*
+ [target
+ [jvm
+ ["." modifier (#+ Modifier) ("#\." monoid)]
+ ["." method (#+ Method)]]]]])
+
+(def: #export modifier
+ (Modifier Method)
+ ($_ modifier\compose
+ method.public
+ method.strict
+ ))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux
new file mode 100644
index 000000000..e42804d63
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux
@@ -0,0 +1,157 @@
+(.module:
+ [library
+ [lux (#- Type type)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]]
+ [data
+ [number
+ ["n" nat]
+ ["i" int]
+ ["." i32]]
+ [collection
+ ["." list ("#\." monoid functor)]]]
+ [target
+ [jvm
+ ["_" bytecode (#+ Label Bytecode) ("#\." monad)]
+ ["." method (#+ Method)]
+ [constant
+ [pool (#+ Resource)]]
+ [encoding
+ ["." signed]]
+ ["." type (#+ Type)
+ ["." category (#+ Class)]]]]]]
+ ["." //
+ ["#." reset]
+ ["#." implementation]
+ ["#." init]
+ ["/#" // #_
+ ["#." abstract]
+ [field
+ [constant
+ ["#." arity]]
+ [variable
+ ["#." partial
+ ["#/." count]]
+ ["#." foreign]]]
+ ["/#" // #_
+ ["#." runtime]
+ ["#." value]
+ ["#." reference]
+ [////
+ [analysis (#+ Environment)]
+ [synthesis (#+ Synthesis)]
+ [///
+ [arity (#+ Arity)]
+ [reference
+ [variable (#+ Register)]]]]]]])
+
+(def: (increment by)
+ (-> Nat (Bytecode Any))
+ ($_ _.compose
+ (<| _.int .i64 by)
+ _.iadd))
+
+(def: (inputs offset amount)
+ (-> Register Nat (Bytecode Any))
+ ($_ _.compose
+ (|> amount
+ list.indices
+ (monad.map _.monad (|>> (n.+ offset) _.aload)))
+ (_\wrap [])
+ ))
+
+(def: (apply offset amount)
+ (-> Register Nat (Bytecode Any))
+ (let [arity (n.min amount ///arity.maximum)]
+ ($_ _.compose
+ (_.checkcast ///abstract.class)
+ (..inputs offset arity)
+ (_.invokevirtual ///abstract.class ////runtime.apply::name (////runtime.apply::type arity))
+ (if (n.> ///arity.maximum amount)
+ (apply (n.+ ///arity.maximum offset)
+ (n.- ///arity.maximum amount))
+ (_\wrap []))
+ )))
+
+(def: this-offset 1)
+
+(def: #export (method class environment function-arity @begin body apply-arity)
+ (-> (Type Class) (Environment Synthesis) Arity Label (Bytecode Any) Arity (Resource Method))
+ (let [num-partials (dec function-arity)
+ over-extent (i.- (.int apply-arity)
+ (.int function-arity))]
+ (method.method //.modifier ////runtime.apply::name
+ (////runtime.apply::type apply-arity)
+ (list)
+ (#.Some (case num-partials
+ 0 ($_ _.compose
+ ////reference.this
+ (..inputs ..this-offset apply-arity)
+ (_.invokevirtual class //implementation.name (//implementation.type function-arity))
+ _.areturn)
+ _ (do _.monad
+ [@default _.new-label
+ @labelsH _.new-label
+ @labelsT (|> _.new-label
+ (list.repeat (dec num-partials))
+ (monad.seq _.monad))
+ #let [cases (|> (list\compose (#.Cons [@labelsH @labelsT])
+ (list @default))
+ list.enumeration
+ (list\map (function (_ [stage @case])
+ (let [current-partials (|> (list.indices stage)
+ (list\map (///partial.get class))
+ (monad.seq _.monad))
+ already-partial? (n.> 0 stage)
+ exact-match? (i.= over-extent (.int stage))
+ has-more-than-necessary? (i.> over-extent (.int stage))]
+ ($_ _.compose
+ (_.set-label @case)
+ (cond exact-match?
+ ($_ _.compose
+ ////reference.this
+ (if already-partial?
+ (_.invokevirtual class //reset.name (//reset.type class))
+ (_\wrap []))
+ current-partials
+ (..inputs ..this-offset apply-arity)
+ (_.invokevirtual class //implementation.name (//implementation.type function-arity))
+ _.areturn)
+
+ has-more-than-necessary?
+ (let [inputs-to-completion (|> function-arity (n.- stage))
+ inputs-left (|> apply-arity (n.- inputs-to-completion))]
+ ($_ _.compose
+ ////reference.this
+ (_.invokevirtual class //reset.name (//reset.type class))
+ current-partials
+ (..inputs ..this-offset inputs-to-completion)
+ (_.invokevirtual class //implementation.name (//implementation.type function-arity))
+ (apply (n.+ ..this-offset inputs-to-completion) inputs-left)
+ _.areturn))
+
+ ## (i.< over-extent (.int stage))
+ (let [current-environment (|> (list.indices (list.size environment))
+ (list\map (///foreign.get class))
+ (monad.seq _.monad))
+ missing-partials (|> _.aconst-null
+ (list.repeat (|> num-partials (n.- apply-arity) (n.- stage)))
+ (monad.seq _.monad))]
+ ($_ _.compose
+ (_.new class)
+ _.dup
+ current-environment
+ ///partial/count.value
+ (..increment apply-arity)
+ current-partials
+ (..inputs ..this-offset apply-arity)
+ missing-partials
+ (_.invokevirtual class //init.name (//init.type environment function-arity))
+ _.areturn)))))))
+ (monad.seq _.monad))]]
+ ($_ _.compose
+ ///partial/count.value
+ (_.tableswitch (try.assume (signed.s4 +0)) @default [@labelsH @labelsT])
+ cases)))))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux
new file mode 100644
index 000000000..14cde40a2
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux
@@ -0,0 +1,42 @@
+(.module:
+ [library
+ [lux (#- Type type)
+ [data
+ [collection
+ ["." list]]]
+ [target
+ [jvm
+ ["." method (#+ Method)]
+ ["_" bytecode (#+ Label Bytecode)]
+ [constant
+ [pool (#+ Resource)]]
+ ["." type (#+ Type)
+ ["." category]]]]]]
+ ["." //
+ ["//#" /// #_
+ ["#." type]
+ [//////
+ [arity (#+ Arity)]]]])
+
+(def: #export name "impl")
+
+(def: #export (type arity)
+ (-> Arity (Type category.Method))
+ (type.method [(list.repeat arity ////type.value)
+ ////type.value
+ (list)]))
+
+(def: #export (method' name arity @begin body)
+ (-> Text Arity Label (Bytecode Any) (Resource Method))
+ (method.method //.modifier name
+ (..type arity)
+ (list)
+ (#.Some ($_ _.compose
+ (_.set-label @begin)
+ body
+ _.areturn
+ ))))
+
+(def: #export method
+ (-> Arity Label (Bytecode Any) (Resource Method))
+ (method' ..name))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux
new file mode 100644
index 000000000..3785f9a40
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux
@@ -0,0 +1,98 @@
+(.module:
+ [library
+ [lux (#- Type type)
+ [abstract
+ ["." monad]]
+ [control
+ ["." try]]
+ [data
+ [number
+ ["n" nat]]
+ [collection
+ ["." list ("#\." monoid functor)]]]
+ [target
+ [jvm
+ ["_" bytecode (#+ Bytecode)]
+ ["." method (#+ Method)]
+ [encoding
+ ["." unsigned]]
+ [constant
+ [pool (#+ Resource)]]
+ ["." type (#+ Type)
+ ["." category (#+ Class Value)]]]]]]
+ ["." //
+ ["#." implementation]
+ ["/#" // #_
+ ["#." abstract]
+ [field
+ [constant
+ ["#." arity]]
+ [variable
+ ["#." foreign]
+ ["#." partial]]]
+ ["/#" // #_
+ ["#." type]
+ ["#." reference]
+ [////
+ [analysis (#+ Environment)]
+ [synthesis (#+ Synthesis)]
+ [///
+ ["." arity (#+ Arity)]
+ [reference
+ [variable (#+ Register)]]]]]]])
+
+(def: #export name "<init>")
+
+(def: (partials arity)
+ (-> Arity (List (Type Value)))
+ (list.repeat (dec arity) ////type.value))
+
+(def: #export (type environment arity)
+ (-> (Environment Synthesis) Arity (Type category.Method))
+ (type.method [(list\compose (///foreign.closure environment)
+ (if (arity.multiary? arity)
+ (list& ///arity.type (..partials arity))
+ (list)))
+ type.void
+ (list)]))
+
+(def: no-partials (|> 0 unsigned.u1 try.assume _.bipush))
+
+(def: #export (super environment-size arity)
+ (-> Nat Arity (Bytecode Any))
+ (let [arity-register (inc environment-size)]
+ ($_ _.compose
+ (if (arity.unary? arity)
+ ..no-partials
+ (_.iload arity-register))
+ (_.invokespecial ///abstract.class ..name ///abstract.init))))
+
+(def: (store-all amount put offset)
+ (-> Nat
+ (-> Register (Bytecode Any) (Bytecode Any))
+ (-> Register Register)
+ (Bytecode Any))
+ (|> (list.indices amount)
+ (list\map (function (_ register)
+ (put register
+ (_.aload (offset register)))))
+ (monad.seq _.monad)))
+
+(def: #export (method class environment arity)
+ (-> (Type Class) (Environment Synthesis) Arity (Resource Method))
+ (let [environment-size (list.size environment)
+ offset-foreign (: (-> Register Register)
+ (n.+ 1))
+ offset-arity (: (-> Register Register)
+ (|>> offset-foreign (n.+ environment-size)))
+ offset-partial (: (-> Register Register)
+ (|>> offset-arity (n.+ 1)))]
+ (method.method //.modifier ..name
+ (..type environment arity)
+ (list)
+ (#.Some ($_ _.compose
+ ////reference.this
+ (..super environment-size arity)
+ (store-all environment-size (///foreign.put class) offset-foreign)
+ (store-all (dec arity) (///partial.put class) offset-partial)
+ _.return)))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux
new file mode 100644
index 000000000..f6bfa0278
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux
@@ -0,0 +1,81 @@
+(.module:
+ [library
+ [lux (#- Type type)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ [number
+ ["n" nat]]
+ [collection
+ ["." list]]]
+ [target
+ [jvm
+ ["." field (#+ Field)]
+ ["." method (#+ Method)]
+ ["_" bytecode (#+ Bytecode)]
+ ["." constant
+ [pool (#+ Resource)]]
+ [type (#+ Type)
+ ["." category (#+ Class Value Return)]]]]
+ [tool
+ [compiler
+ [meta
+ ["." archive (#+ Archive)]]]]]]
+ ["." //
+ ["#." init]
+ ["#." implementation]
+ ["/#" // #_
+ [field
+ [constant
+ ["#." arity]]
+ [variable
+ ["#." foreign]
+ ["#." partial]]]
+ ["/#" // #_
+ [runtime (#+ Operation Phase)]
+ ["#." value]
+ ["#." reference]
+ [////
+ [analysis (#+ Environment)]
+ [synthesis (#+ Synthesis)]
+ [///
+ ["." arity (#+ Arity)]
+ ["." phase]]]]]])
+
+(def: #export (instance' foreign-setup class environment arity)
+ (-> (List (Bytecode Any)) (Type Class) (Environment Synthesis) Arity (Bytecode Any))
+ ($_ _.compose
+ (_.new class)
+ _.dup
+ (monad.seq _.monad foreign-setup)
+ (///partial.new arity)
+ (_.invokespecial class //init.name (//init.type environment arity))))
+
+(def: #export (instance generate archive class environment arity)
+ (-> Phase Archive (Type Class) (Environment Synthesis) Arity (Operation (Bytecode Any)))
+ (do {! phase.monad}
+ [foreign* (monad.map ! (generate archive) environment)]
+ (wrap (instance' foreign* class environment arity))))
+
+(def: #export (method class environment arity)
+ (-> (Type Class) (Environment Synthesis) Arity (Resource Method))
+ (let [after-this (: (-> Nat Nat)
+ (n.+ 1))
+ environment-size (list.size environment)
+ after-environment (: (-> Nat Nat)
+ (|>> after-this (n.+ environment-size)))
+ after-arity (: (-> Nat Nat)
+ (|>> after-environment (n.+ 1)))]
+ (method.method //.modifier //init.name
+ (//init.type environment arity)
+ (list)
+ (#.Some ($_ _.compose
+ ////reference.this
+ (//init.super environment-size arity)
+ (monad.map _.monad (function (_ register)
+ (///foreign.put class register (_.aload (after-this register))))
+ (list.indices environment-size))
+ (monad.map _.monad (function (_ register)
+ (///partial.put class register (_.aload (after-arity register))))
+ (list.indices (n.- ///arity.minimum arity)))
+ _.areturn)))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux
new file mode 100644
index 000000000..229538870
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux
@@ -0,0 +1,50 @@
+(.module:
+ [library
+ [lux (#- Type type)
+ [data
+ [collection
+ ["." list ("#\." functor)]]]
+ [target
+ [jvm
+ ["." method (#+ Method)]
+ ["_" bytecode (#+ Bytecode)]
+ [constant
+ [pool (#+ Resource)]]
+ ["." type (#+ Type)
+ ["." category (#+ Class)]]]]]]
+ ["." //
+ ["#." new]
+ ["/#" // #_
+ [field
+ [variable
+ ["#." foreign]]]
+ ["/#" // #_
+ ["#." reference]
+ [////
+ [analysis (#+ Environment)]
+ [synthesis (#+ Synthesis)]
+ [///
+ ["." arity (#+ Arity)]]]]]])
+
+(def: #export name "reset")
+
+(def: #export (type class)
+ (-> (Type Class) (Type category.Method))
+ (type.method [(list) class (list)]))
+
+(def: (current-environment class)
+ (-> (Type Class) (Environment Synthesis) (List (Bytecode Any)))
+ (|>> list.size
+ list.indices
+ (list\map (///foreign.get class))))
+
+(def: #export (method class environment arity)
+ (-> (Type Class) (Environment Synthesis) Arity (Resource Method))
+ (method.method //.modifier ..name
+ (..type class)
+ (list)
+ (#.Some ($_ _.compose
+ (if (arity.multiary? arity)
+ (//new.instance' (..current-environment class environment) class environment arity)
+ ////reference.this)
+ _.areturn))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux
new file mode 100644
index 000000000..2f6b8041c
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux
@@ -0,0 +1,161 @@
+(.module:
+ [library
+ [lux (#- Definition)
+ ["." ffi (#+ import: do-to object)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ pipe
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO io)]
+ [concurrency
+ ["." atom (#+ Atom atom)]]]
+ [data
+ [binary (#+ Binary)]
+ ["." product]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]]
+ [collection
+ ["." array]
+ ["." dictionary (#+ Dictionary)]
+ ["." row]]
+ ["." format #_
+ ["#" binary]]]
+ [target
+ [jvm
+ ["." loader (#+ Library)]
+ ["_" bytecode (#+ Bytecode)]
+ ["." modifier (#+ Modifier) ("#\." monoid)]
+ ["." field (#+ Field)]
+ ["." method (#+ Method)]
+ ["." version]
+ ["." class (#+ Class)]
+ ["." encoding #_
+ ["#/." name]]
+ ["." type
+ ["." descriptor]]]]
+ [tool
+ [compiler
+ ["." name]]]]]
+ ["." // #_
+ ["#." runtime (#+ Definition)]]
+ )
+
+(import: java/lang/reflect/Field
+ (get [#? java/lang/Object] #try #? java/lang/Object))
+
+(import: (java/lang/Class a)
+ (getField [java/lang/String] #try java/lang/reflect/Field))
+
+(import: java/lang/Object
+ (getClass [] (java/lang/Class java/lang/Object)))
+
+(import: java/lang/ClassLoader)
+
+(def: value::field "value")
+(def: value::type (type.class "java.lang.Object" (list)))
+(def: value::modifier ($_ modifier\compose field.public field.final field.static))
+
+(def: init::type (type.method [(list) type.void (list)]))
+(def: init::modifier ($_ modifier\compose method.public method.static method.strict))
+
+(exception: #export (cannot-load {class Text} {error Text})
+ (exception.report
+ ["Class" class]
+ ["Error" error]))
+
+(exception: #export (invalid-field {class Text} {field Text} {error Text})
+ (exception.report
+ ["Class" class]
+ ["Field" field]
+ ["Error" error]))
+
+(exception: #export (invalid-value {class Text})
+ (exception.report
+ ["Class" class]))
+
+(def: (class-value class-name class)
+ (-> Text (java/lang/Class java/lang/Object) (Try Any))
+ (case (java/lang/Class::getField ..value::field class)
+ (#try.Success field)
+ (case (java/lang/reflect/Field::get #.None field)
+ (#try.Success ?value)
+ (case ?value
+ (#.Some value)
+ (#try.Success value)
+
+ #.None
+ (exception.throw ..invalid-value [class-name]))
+
+ (#try.Failure error)
+ (exception.throw ..cannot-load [class-name error]))
+
+ (#try.Failure error)
+ (exception.throw ..invalid-field [class-name ..value::field error])))
+
+(def: class-path-separator ".")
+
+(def: (evaluate! library loader eval-class valueG)
+ (-> Library java/lang/ClassLoader Text (Bytecode Any) (Try [Any Definition]))
+ (let [bytecode-name (text.replace-all class-path-separator .module-separator eval-class)
+ bytecode (class.class version.v6_0
+ class.public
+ (encoding/name.internal bytecode-name)
+ (encoding/name.internal "java.lang.Object") (list)
+ (list (field.field ..value::modifier ..value::field ..value::type (row.row)))
+ (list (method.method ..init::modifier "<clinit>" ..init::type
+ (list)
+ (#.Some
+ ($_ _.compose
+ valueG
+ (_.putstatic (type.class bytecode-name (list)) ..value::field ..value::type)
+ _.return))))
+ (row.row))]
+ (io.run (do {! (try.with io.monad)}
+ [bytecode (\ ! map (format.run class.writer)
+ (io.io bytecode))
+ _ (loader.store eval-class bytecode library)
+ class (loader.load eval-class loader)
+ value (\ io.monad wrap (class-value eval-class class))]
+ (wrap [value
+ [eval-class bytecode]])))))
+
+(def: (execute! library loader temp-label [class-name class-bytecode])
+ (-> Library java/lang/ClassLoader Text Definition (Try Any))
+ (io.run (do (try.with io.monad)
+ [existing-class? (|> (atom.read library)
+ (\ io.monad map (function (_ library)
+ (dictionary.key? library class-name)))
+ (try.lift io.monad)
+ (: (IO (Try Bit))))
+ _ (if existing-class?
+ (wrap [])
+ (loader.store class-name class-bytecode library))]
+ (loader.load class-name loader))))
+
+(def: (define! library loader [module name] valueG)
+ (-> Library java/lang/ClassLoader Name (Bytecode Any) (Try [Text Any Definition]))
+ (let [class-name (format (text.replace-all .module-separator class-path-separator module)
+ class-path-separator (name.normalize name)
+ "___" (%.nat (text\hash name)))]
+ (do try.monad
+ [[value definition] (evaluate! library loader class-name valueG)]
+ (wrap [class-name value definition]))))
+
+(def: #export host
+ (IO //runtime.Host)
+ (io (let [library (loader.new-library [])
+ loader (loader.memory library)]
+ (: //runtime.Host
+ (implementation
+ (def: (evaluate! temp-label valueG)
+ (let [eval-class (|> temp-label name.normalize (text.replace-all " " "$"))]
+ (\ try.monad map product.left
+ (..evaluate! library loader eval-class valueG))))
+
+ (def: execute!
+ (..execute! library loader))
+
+ (def: define!
+ (..define! library loader)))))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux
new file mode 100644
index 000000000..465e8d1af
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux
@@ -0,0 +1,90 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]]
+ [data
+ ["." product]
+ [number
+ ["n" nat]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [target
+ [jvm
+ ["_" bytecode (#+ Label Bytecode) ("#\." monad)]]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." value]
+ [////
+ ["." synthesis (#+ Path Synthesis)]
+ ["." generation]
+ [///
+ ["." phase]
+ [reference
+ [variable (#+ Register)]]]]])
+
+(def: (invariant? register changeS)
+ (-> Register Synthesis Bit)
+ (case changeS
+ (^ (synthesis.variable/local var))
+ (n.= register var)
+
+ _
+ false))
+
+(def: no-op
+ (_\wrap []))
+
+(def: #export (recur translate archive updatesS)
+ (Generator (List Synthesis))
+ (do {! phase.monad}
+ [[@begin offset] generation.anchor
+ updatesG (|> updatesS
+ list.enumeration
+ (list\map (function (_ [index updateS])
+ [(n.+ offset index) updateS]))
+ (monad.map ! (function (_ [register updateS])
+ (if (invariant? register updateS)
+ (wrap [..no-op
+ ..no-op])
+ (do !
+ [fetchG (translate archive updateS)
+ #let [storeG (_.astore register)]]
+ (wrap [fetchG storeG]))))))]
+ (wrap ($_ _.compose
+ ## It may look weird that first I fetch all the values separately,
+ ## and then I store them all.
+ ## It must be done that way in order to avoid a potential bug.
+ ## Let's say that you'll recur with 2 expressions: X and Y.
+ ## If Y depends on the value of X, and you don't perform fetches
+ ## and stores separately, then by the time Y is evaluated, it
+ ## will refer to the new value of X, instead of the old value, as
+ ## should be the case.
+ (|> updatesG
+ (list\map product.left)
+ (monad.seq _.monad))
+ (|> updatesG
+ list.reverse
+ (list\map product.right)
+ (monad.seq _.monad))
+ (_.goto @begin)))))
+
+(def: #export (scope translate archive [offset initsS+ iterationS])
+ (Generator [Nat (List Synthesis) Synthesis])
+ (do {! phase.monad}
+ [@begin //runtime.forge-label
+ initsI+ (monad.map ! (translate archive) initsS+)
+ iterationG (generation.with-anchor [@begin offset]
+ (translate archive iterationS))
+ #let [initializationG (|> (list.enumeration initsI+)
+ (list\map (function (_ [index initG])
+ ($_ _.compose
+ initG
+ (_.astore (n.+ offset index)))))
+ (monad.seq _.monad))]]
+ (wrap ($_ _.compose
+ initializationG
+ (_.set-label @begin)
+ iterationG))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux
new file mode 100644
index 000000000..6b24fb2f5
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux
@@ -0,0 +1,121 @@
+(.module:
+ [library
+ [lux (#- i64)
+ ["." ffi (#+ import:)]
+ [abstract
+ [monad (#+ do)]]
+ [target
+ [jvm
+ ["_" bytecode (#+ Bytecode)]
+ ["." type]
+ [encoding
+ ["." signed]]]]]]
+ ["." // #_
+ ["#." runtime]])
+
+(def: $Boolean (type.class "java.lang.Boolean" (list)))
+(def: $Long (type.class "java.lang.Long" (list)))
+(def: $Double (type.class "java.lang.Double" (list)))
+
+(def: #export (bit value)
+ (-> Bit (Bytecode Any))
+ (_.getstatic $Boolean (if value "TRUE" "FALSE") $Boolean))
+
+(def: wrap-i64
+ (_.invokestatic $Long "valueOf" (type.method [(list type.long) $Long (list)])))
+
+(def: #export (i64 value)
+ (-> (I64 Any) (Bytecode Any))
+ (case (.int value)
+ (^template [<int> <instruction>]
+ [<int>
+ (do _.monad
+ [_ <instruction>]
+ ..wrap-i64)])
+ ([+0 _.lconst-0]
+ [+1 _.lconst-1])
+
+ (^template [<int> <instruction>]
+ [<int>
+ (do _.monad
+ [_ <instruction>
+ _ _.i2l]
+ ..wrap-i64)])
+ ([-1 _.iconst-m1]
+ ## [+0 _.iconst-0]
+ ## [+1 _.iconst-1]
+ [+2 _.iconst-2]
+ [+3 _.iconst-3]
+ [+4 _.iconst-4]
+ [+5 _.iconst-5])
+
+ value
+ (case (signed.s1 value)
+ (#try.Success value)
+ (do _.monad
+ [_ (_.bipush value)
+ _ _.i2l]
+ ..wrap-i64)
+
+ (#try.Failure _)
+ (case (signed.s2 value)
+ (#try.Success value)
+ (do _.monad
+ [_ (_.sipush value)
+ _ _.i2l]
+ ..wrap-i64)
+
+ (#try.Failure _)
+ (do _.monad
+ [_ (_.long value)]
+ ..wrap-i64)))))
+
+(def: wrap-f64
+ (_.invokestatic $Double "valueOf" (type.method [(list type.double) $Double (list)])))
+
+(import: java/lang/Double
+ (#static doubleToRawLongBits #manual [double] int))
+
+(def: #export (f64 value)
+ (-> Frac (Bytecode Any))
+ (case value
+ (^template [<int> <instruction>]
+ [<int>
+ (do _.monad
+ [_ <instruction>]
+ ..wrap-f64)])
+ ([+1.0 _.dconst-1])
+
+ (^template [<int> <instruction>]
+ [<int>
+ (do _.monad
+ [_ <instruction>
+ _ _.f2d]
+ ..wrap-f64)])
+ ([+2.0 _.fconst-2])
+
+ (^template [<int> <instruction>]
+ [<int>
+ (do _.monad
+ [_ <instruction>
+ _ _.i2d]
+ ..wrap-f64)])
+ ([-1.0 _.iconst-m1]
+ ## [+0.0 _.iconst-0]
+ ## [+1.0 _.iconst-1]
+ [+2.0 _.iconst-2]
+ [+3.0 _.iconst-3]
+ [+4.0 _.iconst-4]
+ [+5.0 _.iconst-5])
+
+ _
+ (let [constantI (if (i.= ..d0-bits
+ (java/lang/Double::doubleToRawLongBits (:as java/lang/Double value)))
+ _.dconst-0
+ (_.double value))]
+ (do _.monad
+ [_ constantI]
+ ..wrap-f64))))
+
+(def: #export text
+ _.string)
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux
new file mode 100644
index 000000000..0441f3b00
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux
@@ -0,0 +1,144 @@
+(.module:
+ [library
+ [lux (#- Definition)
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]]
+ [data
+ [collection
+ ["." row]]
+ ["." format #_
+ ["#" binary]]]
+ [target
+ [jvm
+ ["_" bytecode (#+ Bytecode)]
+ ["." modifier (#+ Modifier) ("#\." monoid)]
+ ["." method (#+ Method)]
+ ["." version]
+ ["." class (#+ Class)]
+ [encoding
+ ["." name]]
+ ["." type
+ ["." reflection]]]]]]
+ ["." //
+ ["#." runtime (#+ Definition)]
+ ["#." function/abstract]])
+
+(def: #export class "LuxProgram")
+
+(def: ^Object (type.class "java.lang.Object" (list)))
+(def: ^String (type.class "java.lang.String" (list)))
+(def: ^Args (type.array ^String))
+
+(def: main::type (type.method [(list ..^Args) type.void (list)]))
+
+(def: main::modifier
+ (Modifier Method)
+ ($_ modifier\compose
+ method.public
+ method.static
+ method.strict
+ ))
+
+(def: program::modifier
+ (Modifier Class)
+ ($_ modifier\compose
+ class.public
+ class.final
+ ))
+
+(def: nil //runtime.none-injection)
+
+(def: amount-of-inputs
+ (Bytecode Any)
+ ($_ _.compose
+ _.aload-0
+ _.arraylength))
+
+(def: decrease
+ (Bytecode Any)
+ ($_ _.compose
+ _.iconst-1
+ _.isub))
+
+(def: head
+ (Bytecode Any)
+ ($_ _.compose
+ _.dup
+ _.aload-0
+ _.swap
+ _.aaload
+ _.swap
+ _.dup-x2
+ _.pop))
+
+(def: pair
+ (Bytecode Any)
+ ($_ _.compose
+ _.iconst-2
+ (_.anewarray ^Object)
+ _.dup-x1
+ _.swap
+ _.iconst-0
+ _.swap
+ _.aastore
+ _.dup-x1
+ _.swap
+ _.iconst-1
+ _.swap
+ _.aastore))
+
+(def: cons //runtime.right-injection)
+
+(def: input-list
+ (Bytecode Any)
+ (do _.monad
+ [@loop _.new-label
+ @end _.new-label]
+ ($_ _.compose
+ ..nil
+ ..amount-of-inputs
+ (_.set-label @loop)
+ ..decrease
+ _.dup
+ (_.iflt @end)
+ ..head
+ ..pair
+ ..cons
+ _.swap
+ (_.goto @loop)
+ (_.set-label @end)
+ _.pop)))
+
+(def: feed-inputs //runtime.apply)
+
+(def: run-io
+ (Bytecode Any)
+ ($_ _.compose
+ (_.checkcast //function/abstract.class)
+ _.aconst-null
+ //runtime.apply))
+
+(def: #export (program program)
+ (-> (Bytecode Any) Definition)
+ (let [super-class (|> ..^Object type.reflection reflection.reflection name.internal)
+ main (method.method ..main::modifier "main" ..main::type
+ (list)
+ (#.Some ($_ _.compose
+ program
+ ..input-list
+ ..feed-inputs
+ ..run-io
+ _.return)))]
+ [..class
+ (<| (format.run class.writer)
+ try.assume
+ (class.class version.v6_0
+ ..program::modifier
+ (name.internal ..class)
+ super-class
+ (list)
+ (list)
+ (list main)
+ (row.row)))]))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux
new file mode 100644
index 000000000..c41e5c16a
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux
@@ -0,0 +1,67 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [data
+ [text
+ ["%" format (#+ format)]]]
+ [target
+ [jvm
+ ["_" bytecode (#+ Bytecode)]
+ ["." type]
+ [encoding
+ ["." unsigned]]]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation)]
+ ["#." value]
+ ["#." type]
+ ["//#" /// #_
+ [//
+ ["." generation]
+ [///
+ ["#" phase ("operation\." monad)]
+ [reference
+ ["." variable (#+ Register Variable)]]
+ [meta
+ [archive (#+ Archive)]]]]]])
+
+(def: #export this
+ (Bytecode Any)
+ _.aload-0)
+
+(template [<name> <prefix>]
+ [(def: #export <name>
+ (-> Register Text)
+ (|>> %.nat (format <prefix>)))]
+
+ [foreign-name "f"]
+ [partial-name "p"]
+ )
+
+(def: (foreign archive variable)
+ (-> Archive Register (Operation (Bytecode Any)))
+ (do {! ////.monad}
+ [bytecode-name (\ ! map //runtime.class-name
+ (generation.context archive))]
+ (wrap ($_ _.compose
+ ..this
+ (_.getfield (type.class bytecode-name (list))
+ (..foreign-name variable)
+ //type.value)))))
+
+(def: #export (variable archive variable)
+ (-> Archive Variable (Operation (Bytecode Any)))
+ (case variable
+ (#variable.Local variable)
+ (operation\wrap (_.aload variable))
+
+ (#variable.Foreign variable)
+ (..foreign archive variable)))
+
+(def: #export (constant archive name)
+ (-> Archive Name (Operation (Bytecode Any)))
+ (do {! ////.monad}
+ [bytecode-name (\ ! map //runtime.class-name
+ (generation.remember archive name))]
+ (wrap (_.getstatic (type.class bytecode-name (list)) //value.field //type.value))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux
new file mode 100644
index 000000000..e445ec2d4
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux
@@ -0,0 +1,611 @@
+(.module:
+ [library
+ [lux (#- Type Definition case false true try)
+ [abstract
+ ["." monad (#+ do)]
+ ["." enum]]
+ [control
+ ["." try]]
+ [data
+ [binary (#+ Binary)]
+ [collection
+ ["." list ("#\." functor)]
+ ["." row]]
+ ["." format #_
+ ["#" binary]]
+ [text
+ ["%" format (#+ format)]]]
+ [math
+ [number
+ ["n" nat]
+ ["." i32]
+ ["." i64]]]
+ [target
+ ["." jvm #_
+ ["_" bytecode (#+ Label Bytecode)]
+ ["." modifier (#+ Modifier) ("#\." monoid)]
+ ["." field (#+ Field)]
+ ["." method (#+ Method)]
+ ["#/." version]
+ ["." class (#+ Class)]
+ ["." constant
+ [pool (#+ Resource)]]
+ [encoding
+ ["." name]]
+ ["." type (#+ Type)
+ ["." category (#+ Return' Value')]
+ ["." reflection]]]]]]
+ ["." // #_
+ ["#." type]
+ ["#." value]
+ ["#." function #_
+ ["#" abstract]
+ [field
+ [constant
+ ["#/." arity]]
+ [variable
+ [partial
+ ["#/." count]]]]]
+ ["//#" /// #_
+ [//
+ ["." version]
+ ["." synthesis]
+ ["." generation]
+ [///
+ ["#" phase]
+ [arity (#+ Arity)]
+ [reference
+ [variable (#+ Register)]]
+ [meta
+ [io (#+ lux_context)]
+ [archive (#+ Archive)]]]]]])
+
+(type: #export Byte_Code Binary)
+
+(type: #export Definition [Text Byte_Code])
+
+(type: #export Anchor [Label Register])
+
+(template [<name> <base>]
+ [(type: #export <name>
+ (<base> Anchor (Bytecode Any) Definition))]
+
+ [Operation generation.Operation]
+ [Phase generation.Phase]
+ [Handler generation.Handler]
+ [Bundle generation.Bundle]
+ )
+
+(type: #export (Generator i)
+ (-> Phase Archive i (Operation (Bytecode Any))))
+
+(type: #export Host
+ (generation.Host (Bytecode Any) Definition))
+
+(def: #export (class_name [module id])
+ (-> generation.Context Text)
+ (format lux_context
+ "/" (%.nat version.version)
+ "/" (%.nat module)
+ "/" (%.nat id)))
+
+(def: artifact_id
+ 0)
+
+(def: #export class
+ (type.class (%.nat ..artifact_id) (list)))
+
+(def: procedure
+ (-> Text (Type category.Method) (Bytecode Any))
+ (_.invokestatic ..class))
+
+(def: modifier
+ (Modifier Method)
+ ($_ modifier\compose
+ method.public
+ method.static
+ method.strict
+ ))
+
+(def: this
+ (Bytecode Any)
+ _.aload_0)
+
+(def: #export (get index)
+ (-> (Bytecode Any) (Bytecode Any))
+ ($_ _.compose
+ index
+ _.aaload))
+
+(def: (set! index value)
+ (-> (Bytecode Any) (Bytecode Any) (Bytecode Any))
+ ($_ _.compose
+ ## A
+ _.dup ## AA
+ index ## AAI
+ value ## AAIV
+ _.aastore ## A
+ ))
+
+(def: #export unit (_.string synthesis.unit))
+
+(def: variant::name "variant")
+(def: variant::type (type.method [(list //type.tag //type.flag //type.value) //type.variant (list)]))
+(def: #export variant (..procedure ..variant::name ..variant::type))
+
+(def: variant_tag _.iconst_0)
+(def: variant_last? _.iconst_1)
+(def: variant_value _.iconst_2)
+
+(def: variant::method
+ (let [new_variant ($_ _.compose
+ _.iconst_3
+ (_.anewarray //type.value))
+ $tag ($_ _.compose
+ _.iload_0
+ (//value.wrap type.int))
+ $last? _.aload_1
+ $value _.aload_2]
+ (method.method ..modifier ..variant::name
+ ..variant::type
+ (list)
+ (#.Some ($_ _.compose
+ new_variant ## A[3]
+ (..set! ..variant_tag $tag) ## A[3]
+ (..set! ..variant_last? $last?) ## A[3]
+ (..set! ..variant_value $value) ## A[3]
+ _.areturn)))))
+
+(def: #export left_flag _.aconst_null)
+(def: #export right_flag ..unit)
+
+(def: #export left_injection
+ (Bytecode Any)
+ ($_ _.compose
+ _.iconst_0
+ ..left_flag
+ _.dup2_x1
+ _.pop2
+ ..variant))
+
+(def: #export right_injection
+ (Bytecode Any)
+ ($_ _.compose
+ _.iconst_1
+ ..right_flag
+ _.dup2_x1
+ _.pop2
+ ..variant))
+
+(def: #export some_injection ..right_injection)
+
+(def: #export none_injection
+ (Bytecode Any)
+ ($_ _.compose
+ _.iconst_0
+ ..left_flag
+ ..unit
+ ..variant))
+
+(def: (risky $unsafe)
+ (-> (Bytecode Any) (Bytecode Any))
+ (do _.monad
+ [@try _.new_label
+ @handler _.new_label]
+ ($_ _.compose
+ (_.try @try @handler @handler //type.error)
+ (_.set_label @try)
+ $unsafe
+ ..some_injection
+ _.areturn
+ (_.set_label @handler)
+ ..none_injection
+ _.areturn
+ )))
+
+(def: decode_frac::name "decode_frac")
+(def: decode_frac::type (type.method [(list //type.text) //type.variant (list)]))
+(def: #export decode_frac (..procedure ..decode_frac::name ..decode_frac::type))
+
+(def: decode_frac::method
+ (method.method ..modifier ..decode_frac::name
+ ..decode_frac::type
+ (list)
+ (#.Some
+ (..risky
+ ($_ _.compose
+ _.aload_0
+ (_.invokestatic //type.frac "parseDouble" (type.method [(list //type.text) type.double (list)]))
+ (//value.wrap type.double)
+ )))))
+
+(def: #export log!
+ (Bytecode Any)
+ (let [^PrintStream (type.class "java.io.PrintStream" (list))
+ ^System (type.class "java.lang.System" (list))
+ out (_.getstatic ^System "out" ^PrintStream)
+ print_type (type.method [(list //type.value) type.void (list)])
+ print! (function (_ method) (_.invokevirtual ^PrintStream method print_type))]
+ ($_ _.compose
+ out (_.string "LUX LOG: ") (print! "print")
+ out _.swap (print! "println"))))
+
+(def: exception_constructor (type.method [(list //type.text) type.void (list)]))
+(def: (illegal_state_exception message)
+ (-> Text (Bytecode Any))
+ (let [^IllegalStateException (type.class "java.lang.IllegalStateException" (list))]
+ ($_ _.compose
+ (_.new ^IllegalStateException)
+ _.dup
+ (_.string message)
+ (_.invokespecial ^IllegalStateException "<init>" ..exception_constructor))))
+
+(def: failure::type
+ (type.method [(list) type.void (list)]))
+
+(def: (failure name message)
+ (-> Text Text (Resource Method))
+ (method.method ..modifier name
+ ..failure::type
+ (list)
+ (#.Some
+ ($_ _.compose
+ (..illegal_state_exception message)
+ _.athrow))))
+
+(def: pm_failure::name "pm_failure")
+(def: #export pm_failure (..procedure ..pm_failure::name ..failure::type))
+
+(def: pm_failure::method
+ (..failure ..pm_failure::name "Invalid expression for pattern-matching."))
+
+(def: #export stack_head _.iconst_0)
+(def: #export stack_tail _.iconst_1)
+
+(def: push::name "push")
+(def: push::type (type.method [(list //type.stack //type.value) //type.stack (list)]))
+(def: #export push (..procedure ..push::name ..push::type))
+
+(def: push::method
+ (method.method ..modifier ..push::name
+ ..push::type
+ (list)
+ (#.Some
+ (let [new_stack_frame! ($_ _.compose
+ _.iconst_2
+ (_.anewarray //type.value))
+ $head _.aload_1
+ $tail _.aload_0]
+ ($_ _.compose
+ new_stack_frame!
+ (..set! ..stack_head $head)
+ (..set! ..stack_tail $tail)
+ _.areturn)))))
+
+(def: case::name "case")
+(def: case::type (type.method [(list //type.variant //type.tag //type.flag) //type.value (list)]))
+(def: #export case (..procedure ..case::name ..case::type))
+
+(def: case::method
+ (method.method ..modifier ..case::name ..case::type
+ (list)
+ (#.Some
+ (do _.monad
+ [@loop _.new_label
+ @perfect_match! _.new_label
+ @tags_match! _.new_label
+ @maybe_nested _.new_label
+ @mismatch! _.new_label
+ #let [::tag ($_ _.compose
+ (..get ..variant_tag)
+ (//value.unwrap type.int))
+ ::last? (..get ..variant_last?)
+ ::value (..get ..variant_value)
+
+ $variant _.aload_0
+ $tag _.iload_1
+ $last? _.aload_2
+
+ not_found _.aconst_null
+
+ update_$tag _.isub
+ update_$variant ($_ _.compose
+ $variant ::value
+ (_.checkcast //type.variant)
+ _.astore_0)
+ recur (: (-> Label (Bytecode Any))
+ (function (_ @loop_start)
+ ($_ _.compose
+ ## tag, sumT
+ update_$variant ## tag, sumT
+ update_$tag ## sub_tag
+ (_.goto @loop_start))))
+
+ super_nested_tag ($_ _.compose
+ ## tag, sumT
+ _.swap ## sumT, tag
+ _.isub)
+ super_nested ($_ _.compose
+ ## tag, sumT
+ super_nested_tag ## super_tag
+ $variant ::last? ## super_tag, super_last
+ $variant ::value ## super_tag, super_last, super_value
+ ..variant)]]
+ ($_ _.compose
+ $tag
+ (_.set_label @loop)
+ $variant ::tag
+ _.dup2 (_.if_icmpeq @tags_match!)
+ _.dup2 (_.if_icmpgt @maybe_nested)
+ $last? (_.ifnull @mismatch!) ## tag, sumT
+ super_nested ## super_variant
+ _.areturn
+ (_.set_label @tags_match!) ## tag, sumT
+ $last? ## tag, sumT, wants_last?
+ $variant ::last? ## tag, sumT, wants_last?, is_last?
+ (_.if_acmpeq @perfect_match!) ## tag, sumT
+ (_.set_label @maybe_nested) ## tag, sumT
+ $variant ::last? ## tag, sumT, last?
+ (_.ifnull @mismatch!) ## tag, sumT
+ (recur @loop)
+ (_.set_label @perfect_match!) ## tag, sumT
+ ## _.pop2
+ $variant ::value
+ _.areturn
+ (_.set_label @mismatch!) ## tag, sumT
+ ## _.pop2
+ not_found
+ _.areturn
+ )))))
+
+(def: projection_type (type.method [(list //type.tuple //type.offset) //type.value (list)]))
+
+(def: left_projection::name "left")
+(def: #export left_projection (..procedure ..left_projection::name ..projection_type))
+
+(def: right_projection::name "right")
+(def: #export right_projection (..procedure ..right_projection::name ..projection_type))
+
+(def: projection::method2
+ [(Resource Method) (Resource Method)]
+ (let [$tuple _.aload_0
+ $tuple::size ($_ _.compose
+ $tuple _.arraylength)
+
+ $lefts _.iload_1
+
+ $last_right ($_ _.compose
+ $tuple::size _.iconst_1 _.isub)
+
+ update_$lefts ($_ _.compose
+ $lefts $last_right _.isub
+ _.istore_1)
+ update_$tuple ($_ _.compose
+ $tuple $last_right _.aaload (_.checkcast //type.tuple)
+ _.astore_0)
+ recur (: (-> Label (Bytecode Any))
+ (function (_ @loop)
+ ($_ _.compose
+ update_$lefts
+ update_$tuple
+ (_.goto @loop))))
+
+ left_projection::method
+ (method.method ..modifier ..left_projection::name ..projection_type
+ (list)
+ (#.Some
+ (do _.monad
+ [@loop _.new_label
+ @recursive _.new_label
+ #let [::left ($_ _.compose
+ $lefts _.aaload)]]
+ ($_ _.compose
+ (_.set_label @loop)
+ $lefts $last_right (_.if_icmpge @recursive)
+ $tuple ::left
+ _.areturn
+ (_.set_label @recursive)
+ ## Recursive
+ (recur @loop)))))
+
+ right_projection::method
+ (method.method ..modifier ..right_projection::name ..projection_type
+ (list)
+ (#.Some
+ (do _.monad
+ [@loop _.new_label
+ @not_tail _.new_label
+ @slice _.new_label
+ #let [$right ($_ _.compose
+ $lefts
+ _.iconst_1
+ _.iadd)
+ $::nested ($_ _.compose
+ $tuple _.swap _.aaload)
+ super_nested ($_ _.compose
+ $tuple
+ $right
+ $tuple::size
+ (_.invokestatic (type.class "java.util.Arrays" (list)) "copyOfRange"
+ (type.method [(list //type.tuple //type.index //type.index) //type.tuple (list)])))]]
+ ($_ _.compose
+ (_.set_label @loop)
+ $last_right $right
+ _.dup2 (_.if_icmpne @not_tail)
+ ## _.pop
+ $::nested
+ _.areturn
+ (_.set_label @not_tail)
+ (_.if_icmpgt @slice)
+ ## Must recurse
+ (recur @loop)
+ (_.set_label @slice)
+ super_nested
+ _.areturn))))]
+ [left_projection::method
+ right_projection::method]))
+
+(def: #export apply::name "apply")
+
+(def: #export (apply::type arity)
+ (-> Arity (Type category.Method))
+ (type.method [(list.repeat arity //type.value) //type.value (list)]))
+
+(def: #export apply
+ (_.invokevirtual //function.class ..apply::name (..apply::type 1)))
+
+(def: try::name "try")
+(def: try::type (type.method [(list //function.class) //type.variant (list)]))
+(def: #export try (..procedure ..try::name ..try::type))
+
+(def: false _.iconst_0)
+(def: true _.iconst_1)
+
+(def: try::method
+ (method.method ..modifier ..try::name ..try::type
+ (list)
+ (#.Some
+ (do _.monad
+ [@try _.new_label
+ @handler _.new_label
+ #let [$unsafe ..this
+ unit _.aconst_null
+
+ ^StringWriter (type.class "java.io.StringWriter" (list))
+ string_writer ($_ _.compose
+ (_.new ^StringWriter)
+ _.dup
+ (_.invokespecial ^StringWriter "<init>" (type.method [(list) type.void (list)])))
+
+ ^PrintWriter (type.class "java.io.PrintWriter" (list))
+ print_writer ($_ _.compose
+ ## WTW
+ (_.new ^PrintWriter) ## WTWP
+ _.dup_x1 ## WTPWP
+ _.swap ## WTPPW
+ ..true ## WTPPWZ
+ (_.invokespecial ^PrintWriter "<init>" (type.method [(list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)]))
+ ## WTP
+ )]]
+ ($_ _.compose
+ (_.try @try @handler @handler //type.error)
+ (_.set_label @try)
+ $unsafe unit ..apply
+ ..right_injection _.areturn
+ (_.set_label @handler) ## T
+ string_writer ## TW
+ _.dup_x1 ## WTW
+ print_writer ## WTP
+ (_.invokevirtual //type.error "printStackTrace" (type.method [(list ^PrintWriter) type.void (list)])) ## W
+ (_.invokevirtual ^StringWriter "toString" (type.method [(list) //type.text (list)])) ## S
+ ..left_injection _.areturn
+ )))))
+
+(def: reflection
+ (All [category]
+ (-> (Type (<| Return' Value' category)) Text))
+ (|>> type.reflection reflection.reflection))
+
+(def: ^Object (type.class "java.lang.Object" (list)))
+
+(def: generate_runtime
+ (Operation Any)
+ (let [class (..reflection ..class)
+ modifier (: (Modifier Class)
+ ($_ modifier\compose
+ class.public
+ class.final))
+ bytecode (<| (format.run class.writer)
+ try.assume
+ (class.class jvm/version.v6_0
+ modifier
+ (name.internal class)
+ (name.internal (..reflection ^Object)) (list)
+ (list)
+ (let [[left_projection::method right_projection::method] projection::method2]
+ (list ..decode_frac::method
+ ..variant::method
+
+ ..pm_failure::method
+
+ ..push::method
+ ..case::method
+ left_projection::method
+ right_projection::method
+
+ ..try::method))
+ (row.row)))]
+ (do ////.monad
+ [_ (generation.execute! [class bytecode])]
+ (generation.save! ..artifact_id [class bytecode]))))
+
+(def: generate_function
+ (Operation Any)
+ (let [apply::method+ (|> (enum.range n.enum
+ (inc //function/arity.minimum)
+ //function/arity.maximum)
+ (list\map (function (_ arity)
+ (method.method method.public ..apply::name (..apply::type arity)
+ (list)
+ (#.Some
+ (let [previous_inputs (|> arity
+ list.indices
+ (monad.map _.monad _.aload))]
+ ($_ _.compose
+ previous_inputs
+ (_.invokevirtual //function.class ..apply::name (..apply::type (dec arity)))
+ (_.checkcast //function.class)
+ (_.aload arity)
+ (_.invokevirtual //function.class ..apply::name (..apply::type //function/arity.minimum))
+ _.areturn))))))
+ (list& (method.method (modifier\compose method.public method.abstract)
+ ..apply::name (..apply::type //function/arity.minimum)
+ (list)
+ #.None)))
+ <init>::method (method.method method.public "<init>" //function.init
+ (list)
+ (#.Some
+ (let [$partials _.iload_1]
+ ($_ _.compose
+ ..this
+ (_.invokespecial ^Object "<init>" (type.method [(list) type.void (list)]))
+ ..this
+ $partials
+ (_.putfield //function.class //function/count.field //function/count.type)
+ _.return))))
+ modifier (: (Modifier Class)
+ ($_ modifier\compose
+ class.public
+ class.abstract))
+ class (..reflection //function.class)
+ partial_count (: (Resource Field)
+ (field.field (modifier\compose field.public field.final)
+ //function/count.field
+ //function/count.type
+ (row.row)))
+ bytecode (<| (format.run class.writer)
+ try.assume
+ (class.class jvm/version.v6_0
+ modifier
+ (name.internal class)
+ (name.internal (..reflection ^Object)) (list)
+ (list partial_count)
+ (list& <init>::method apply::method+)
+ (row.row)))]
+ (do ////.monad
+ [_ (generation.execute! [class bytecode])]
+ (generation.save! //function.artifact_id [class bytecode]))))
+
+(def: #export generate
+ (Operation Any)
+ (do ////.monad
+ [_ ..generate_runtime]
+ ..generate_function))
+
+(def: #export forge_label
+ (Operation Label)
+ (let [shift (n./ 4 i64.width)]
+ ## This shift is done to avoid the possibility of forged labels
+ ## to be in the range of the labels that are generated automatically
+ ## during the evaluation of Bytecode expressions.
+ (\ ////.monad map (i64.left_shift shift) generation.next)))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux
new file mode 100644
index 000000000..4ff9bdb81
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux
@@ -0,0 +1,95 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ [number
+ ["." i32]]
+ [collection
+ ["." list]]]
+ [target
+ [jvm
+ ["_" bytecode (#+ Bytecode)]
+ ["." type]
+ [encoding
+ ["." signed]]]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." primitive]
+ ["///#" //// #_
+ [analysis (#+ Variant Tuple)]
+ ["#." synthesis (#+ Synthesis)]
+ [///
+ ["." phase]]]])
+
+(def: $Object
+ (type.class "java.lang.Object" (list)))
+
+(def: #export (tuple generate archive membersS)
+ (Generator (Tuple Synthesis))
+ (case membersS
+ #.Nil
+ (\ phase.monad wrap //runtime.unit)
+
+ (#.Cons singletonS #.Nil)
+ (generate archive singletonS)
+
+ _
+ (do {! phase.monad}
+ [membersI (|> membersS
+ list.enumeration
+ (monad.map ! (function (_ [idx member])
+ (do !
+ [memberI (generate archive member)]
+ (wrap (do _.monad
+ [_ _.dup
+ _ (_.int (.i64 idx))
+ _ memberI]
+ _.aastore))))))]
+ (wrap (do {! _.monad}
+ [_ (_.int (.i64 (list.size membersS)))
+ _ (_.anewarray $Object)]
+ (monad.seq ! membersI))))))
+
+(def: #export (tag lefts right?)
+ (-> Nat Bit (Bytecode Any))
+ (case (if right?
+ (.inc lefts)
+ lefts)
+ 0 _.iconst-0
+ 1 _.iconst-1
+ 2 _.iconst-2
+ 3 _.iconst-3
+ 4 _.iconst-4
+ 5 _.iconst-5
+ tag (case (signed.s1 (.int tag))
+ (#try.Success value)
+ (_.bipush value)
+
+ (#try.Failure _)
+ (case (signed.s2 (.int tag))
+ (#try.Success value)
+ (_.sipush value)
+
+ (#try.Failure _)
+ (_.int (.i64 tag))))))
+
+(def: #export (flag right?)
+ (-> Bit (Bytecode Any))
+ (if right?
+ //runtime.right-flag
+ //runtime.left-flag))
+
+(def: #export (variant generate archive [lefts right? valueS])
+ (Generator (Variant Synthesis))
+ (do phase.monad
+ [valueI (generate archive valueS)]
+ (wrap (do _.monad
+ [_ (..tag lefts right?)
+ _ (..flag right?)
+ _ valueI]
+ (_.invokestatic //runtime.class "variant"
+ (type.method [(list type.int $Object $Object)
+ (type.array $Object)
+ (list)]))))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux
new file mode 100644
index 000000000..4c6f14a3f
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux
@@ -0,0 +1,23 @@
+(.module:
+ [library
+ [lux #*
+ [target
+ [jvm
+ ["." type]]]]])
+
+(def: #export frac (type.class "java.lang.Double" (list)))
+(def: #export text (type.class "java.lang.String" (list)))
+
+(def: #export value (type.class "java.lang.Object" (list)))
+
+(def: #export tag type.int)
+(def: #export flag ..value)
+(def: #export variant (type.array ..value))
+
+(def: #export offset type.int)
+(def: #export index ..offset)
+(def: #export tuple (type.array ..value))
+
+(def: #export stack (type.array ..value))
+
+(def: #export error (type.class "java.lang.Throwable" (list)))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux
new file mode 100644
index 000000000..ef82a6257
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux
@@ -0,0 +1,49 @@
+(.module:
+ [library
+ [lux (#- Type type)
+ [target
+ [jvm
+ ["_" bytecode (#+ Bytecode)]
+ ["." type (#+ Type) ("#\." equivalence)
+ [category (#+ Primitive)]
+ ["." box]]]]]])
+
+(def: #export field "value")
+
+(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>]
+ [(def: (<name> type)
+ (-> (Type Primitive) Text)
+ (`` (cond (~~ (template [<type> <output>]
+ [(type\= <type> type) <output>]
+
+ [type.boolean <boolean>]
+ [type.byte <byte>]
+ [type.short <short>]
+ [type.int <int>]
+ [type.long <long>]
+ [type.float <float>]
+ [type.double <double>]
+ [type.char <char>]))
+ ## else
+ (undefined))))]
+
+ [primitive-wrapper
+ box.boolean box.byte box.short box.int
+ box.long box.float box.double box.char]
+ [primitive-unwrap
+ "booleanValue" "byteValue" "shortValue" "intValue"
+ "longValue" "floatValue" "doubleValue" "charValue"]
+ )
+
+(def: #export (wrap type)
+ (-> (Type Primitive) (Bytecode Any))
+ (let [wrapper (type.class (primitive-wrapper type) (list))]
+ (_.invokestatic wrapper "valueOf"
+ (type.method [(list type) wrapper (list)]))))
+
+(def: #export (unwrap type)
+ (-> (Type Primitive) (Bytecode Any))
+ (let [wrapper (type.class (primitive-wrapper type) (list))]
+ ($_ _.compose
+ (_.checkcast wrapper)
+ (_.invokevirtual wrapper (primitive-unwrap type) (type.method [(list) type (list)])))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua.lux
new file mode 100644
index 000000000..529dd28a0
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua.lux
@@ -0,0 +1,119 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]]
+ [target
+ ["_" lua]]]]
+ ["." / #_
+ [runtime (#+ Phase Phase!)]
+ ["#." primitive]
+ ["#." structure]
+ ["#." reference]
+ ["#." case]
+ ["#." loop]
+ ["#." function]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." extension]
+ ["/#" // #_
+ [analysis (#+)]
+ ["." synthesis]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]
+ [reference (#+)
+ [variable (#+)]]]]]]])
+
+(def: (statement expression archive synthesis)
+ Phase!
+ (case synthesis
+ (^template [<tag>]
+ [(^ (<tag> value))
+ (//////phase\map _.return (expression archive synthesis))])
+ ([synthesis.bit]
+ [synthesis.i64]
+ [synthesis.f64]
+ [synthesis.text]
+ [synthesis.variant]
+ [synthesis.tuple]
+ [#synthesis.Reference]
+ [synthesis.branch/get]
+ [synthesis.function/apply]
+ [#synthesis.Extension])
+
+ (^ (synthesis.branch/case case))
+ (/case.case! statement expression archive case)
+
+ (^ (synthesis.branch/let let))
+ (/case.let! statement expression archive let)
+
+ (^ (synthesis.branch/if if))
+ (/case.if! statement expression archive if)
+
+ (^ (synthesis.loop/scope scope))
+ (do //////phase.monad
+ [[inits scope!] (/loop.scope! statement expression archive false scope)]
+ (wrap scope!))
+
+ (^ (synthesis.loop/recur updates))
+ (/loop.recur! statement expression archive updates)
+
+ (^ (synthesis.function/abstraction abstraction))
+ (//////phase\map _.return (/function.function statement expression archive abstraction))
+ ))
+
+(exception: #export cannot-recur-as-an-expression)
+
+(def: (expression archive synthesis)
+ Phase
+ (case synthesis
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (//////phase\wrap (<generator> value))])
+ ([synthesis.bit /primitive.bit]
+ [synthesis.i64 /primitive.i64]
+ [synthesis.f64 /primitive.f64]
+ [synthesis.text /primitive.text])
+
+ (^ (synthesis.variant variantS))
+ (/structure.variant expression archive variantS)
+
+ (^ (synthesis.tuple members))
+ (/structure.tuple expression archive members)
+
+ (#synthesis.Reference value)
+ (//reference.reference /reference.system archive value)
+
+ (^ (synthesis.branch/case case))
+ (/case.case ..statement expression archive case)
+
+ (^ (synthesis.branch/let let))
+ (/case.let expression archive let)
+
+ (^ (synthesis.branch/if if))
+ (/case.if expression archive if)
+
+ (^ (synthesis.branch/get get))
+ (/case.get expression archive get)
+
+ (^ (synthesis.loop/scope scope))
+ (/loop.scope ..statement expression archive scope)
+
+ (^ (synthesis.loop/recur updates))
+ (//////phase.throw ..cannot-recur-as-an-expression [])
+
+ (^ (synthesis.function/abstraction abstraction))
+ (/function.function ..statement expression archive abstraction)
+
+ (^ (synthesis.function/apply application))
+ (/function.apply expression archive application)
+
+ (#synthesis.Extension extension)
+ (///extension.apply archive expression extension)))
+
+(def: #export generate
+ Phase
+ ..expression)
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/case.lux
new file mode 100644
index 000000000..0be2698f8
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/case.lux
@@ -0,0 +1,280 @@
+(.module:
+ [library
+ [lux (#- case let if)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." set]]]
+ [target
+ ["_" lua (#+ Expression Var Statement)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Phase! Generator Generator!)]
+ ["#." reference]
+ ["#." primitive]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." synthesis #_
+ ["#/." case]]
+ ["/#" // #_
+ ["#." synthesis (#+ Member Synthesis Path)]
+ ["#." generation]
+ ["//#" /// #_
+ [reference
+ ["#." variable (#+ Register)]]
+ ["#." phase ("#\." monad)]
+ [meta
+ [archive (#+ Archive)]]]]]]])
+
+(def: #export register
+ (-> Register Var)
+ (|>> (///reference.local //reference.system) :assume))
+
+(def: #export capture
+ (-> Register Var)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: #export (let expression archive [valueS register bodyS])
+ (Generator [Synthesis Register Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)
+ bodyO (expression archive bodyS)]
+ ## TODO: Find some way to do 'let' without paying the price of the closure.
+ (wrap (|> bodyO
+ _.return
+ (_.closure (list (..register register)))
+ (_.apply/* (list valueO))))))
+
+(def: #export (let! statement expression archive [valueS register bodyS])
+ (Generator! [Synthesis Register Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)
+ bodyO (statement expression archive bodyS)]
+ (wrap ($_ _.then
+ (_.local/1 (..register register) valueO)
+ bodyO))))
+
+(def: #export (get expression archive [pathP valueS])
+ (Generator [(List Member) Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)]
+ (wrap (list\fold (function (_ side source)
+ (.let [method (.case side
+ (^template [<side> <accessor>]
+ [(<side> lefts)
+ (<accessor> (_.int (.int lefts)))])
+ ([#.Left //runtime.tuple//left]
+ [#.Right //runtime.tuple//right]))]
+ (method source)))
+ valueO
+ (list.reverse pathP)))))
+
+(def: #export (if expression archive [testS thenS elseS])
+ (Generator [Synthesis Synthesis Synthesis])
+ (do ///////phase.monad
+ [testO (expression archive testS)
+ thenO (expression archive thenS)
+ elseO (expression archive elseS)]
+ (wrap (|> (_.if testO
+ (_.return thenO)
+ (_.return elseO))
+ (_.closure (list))
+ (_.apply/* (list))))))
+
+(def: #export (if! statement expression archive [testS thenS elseS])
+ (Generator! [Synthesis Synthesis Synthesis])
+ (do ///////phase.monad
+ [testO (expression archive testS)
+ thenO (statement expression archive thenS)
+ elseO (statement expression archive elseS)]
+ (wrap (_.if testO
+ thenO
+ elseO))))
+
+(def: @savepoint (_.var "lux_pm_savepoint"))
+(def: @cursor (_.var "lux_pm_cursor"))
+(def: @temp (_.var "lux_pm_temp"))
+
+(def: (push! value)
+ (-> Expression Statement)
+ (_.statement (|> (_.var "table.insert") (_.apply/* (list @cursor value)))))
+
+(def: peek_and_pop
+ Expression
+ (|> (_.var "table.remove") (_.apply/* (list @cursor))))
+
+(def: pop!
+ Statement
+ (_.statement ..peek_and_pop))
+
+(def: peek
+ Expression
+ (_.nth (_.length @cursor) @cursor))
+
+(def: save!
+ Statement
+ (_.statement (|> (_.var "table.insert")
+ (_.apply/* (list @savepoint
+ (_.apply/* (list @cursor
+ (_.int +1)
+ (_.length @cursor)
+ (_.int +1)
+ (_.table (list)))
+ (_.var "table.move")))))))
+
+(def: restore!
+ Statement
+ (_.set (list @cursor) (|> (_.var "table.remove") (_.apply/* (list @savepoint)))))
+
+(def: fail! _.break)
+
+(template [<name> <flag> <prep>]
+ [(def: (<name> simple? idx)
+ (-> Bit Nat Statement)
+ ($_ _.then
+ (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>)))
+ (.if simple?
+ (_.when (_.= _.nil @temp)
+ fail!)
+ (_.if (_.= _.nil @temp)
+ fail!
+ (..push! @temp)))))]
+
+ [left_choice _.nil (<|)]
+ [right_choice (_.string "") inc]
+ )
+
+(def: (alternation pre! post!)
+ (-> Statement Statement Statement)
+ ($_ _.then
+ (_.while (_.bool true)
+ ($_ _.then
+ ..save!
+ pre!))
+ ($_ _.then
+ ..restore!
+ post!)))
+
+(def: (pattern_matching' statement expression archive)
+ (-> Phase! Phase Archive Path (Operation Statement))
+ (function (recur pathP)
+ (.case pathP
+ (#/////synthesis.Then bodyS)
+ (statement expression archive bodyS)
+
+ #/////synthesis.Pop
+ (///////phase\wrap ..pop!)
+
+ (#/////synthesis.Bind register)
+ (///////phase\wrap (_.local/1 (..register register) ..peek))
+
+ (#/////synthesis.Bit_Fork when thenP elseP)
+ (do {! ///////phase.monad}
+ [then! (recur thenP)
+ else! (.case elseP
+ (#.Some elseP)
+ (recur elseP)
+
+ #.None
+ (wrap ..fail!))]
+ (wrap (.if when
+ (_.if ..peek
+ then!
+ else!)
+ (_.if ..peek
+ else!
+ then!))))
+
+ (^template [<tag> <format>]
+ [(<tag> cons)
+ (do {! ///////phase.monad}
+ [clauses (monad.map ! (function (_ [match then])
+ (do !
+ [then! (recur then)]
+ (wrap [(_.= (|> match <format>)
+ ..peek)
+ then!])))
+ (#.Cons cons))]
+ (wrap (_.cond clauses ..fail!)))])
+ ([#/////synthesis.I64_Fork (<| _.int .int)]
+ [#/////synthesis.F64_Fork _.float]
+ [#/////synthesis.Text_Fork _.string])
+
+ (^template [<complex> <simple> <choice>]
+ [(^ (<complex> idx))
+ (///////phase\wrap (<choice> false idx))
+
+ (^ (<simple> idx nextP))
+ (///////phase\map (_.then (<choice> true idx)) (recur nextP))])
+ ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice]
+ [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice])
+
+ (^ (/////synthesis.member/left 0))
+ (///////phase\wrap (|> ..peek (_.nth (_.int +1)) ..push!))
+
+ (^template [<pm> <getter>]
+ [(^ (<pm> lefts))
+ (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))])
+ ([/////synthesis.member/left //runtime.tuple//left]
+ [/////synthesis.member/right //runtime.tuple//right])
+
+ (^ (/////synthesis.!bind_top register thenP))
+ (do ///////phase.monad
+ [then! (recur thenP)]
+ (///////phase\wrap ($_ _.then
+ (_.local/1 (..register register) ..peek_and_pop)
+ then!)))
+
+ (^template [<tag> <combinator>]
+ [(^ (<tag> preP postP))
+ (do ///////phase.monad
+ [pre! (recur preP)
+ post! (recur postP)]
+ (wrap (<combinator> pre! post!)))])
+ ([/////synthesis.path/seq _.then]
+ [/////synthesis.path/alt ..alternation]))))
+
+(def: (pattern_matching statement expression archive pathP)
+ (-> Phase! Phase Archive Path (Operation Statement))
+ (do ///////phase.monad
+ [pattern_matching! (pattern_matching' statement expression archive pathP)]
+ (wrap ($_ _.then
+ (_.while (_.bool true)
+ pattern_matching!)
+ (_.statement (|> (_.var "error") (_.apply/* (list (_.string ////synthesis/case.pattern_matching_error)))))))))
+
+(def: #export dependencies
+ (-> Path (List Var))
+ (|>> ////synthesis/case.storage
+ (get@ #////synthesis/case.dependencies)
+ set.to_list
+ (list\map (function (_ variable)
+ (.case variable
+ (#///////variable.Local register)
+ (..register register)
+
+ (#///////variable.Foreign register)
+ (..capture register))))))
+
+(def: #export (case! statement expression archive [valueS pathP])
+ (Generator! [Synthesis Path])
+ (do ///////phase.monad
+ [stack_init (expression archive valueS)
+ pattern_matching! (pattern_matching statement expression archive pathP)]
+ (wrap ($_ _.then
+ (_.local (list @temp))
+ (_.local/1 @cursor (_.array (list stack_init)))
+ (_.local/1 @savepoint (_.array (list)))
+ pattern_matching!))))
+
+(def: #export (case statement expression archive [valueS pathP])
+ (-> Phase! (Generator [Synthesis Path]))
+ (|> [valueS pathP]
+ (..case! statement expression archive)
+ (\ ///////phase.monad map
+ (|>> (_.closure (list))
+ (_.apply/* (list))))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux
new file mode 100644
index 000000000..97a5b1691
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux
@@ -0,0 +1,137 @@
+(.module:
+ [library
+ [lux (#- function)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ pipe]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [target
+ ["_" lua (#+ Var Expression Label Statement)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Phase! Generator)]
+ ["#." reference]
+ ["#." case]
+ ["/#" // #_
+ ["#." reference]
+ ["//#" /// #_
+ [analysis (#+ Variant Tuple Abstraction Application Analysis)]
+ [synthesis (#+ Synthesis)]
+ ["#." generation (#+ Context)]
+ ["//#" /// #_
+ [arity (#+ Arity)]
+ ["#." phase ("#\." monad)]
+ [reference
+ [variable (#+ Register Variable)]]]]]])
+
+(def: #export (apply expression archive [functionS argsS+])
+ (Generator (Application Synthesis))
+ (do {! ///////phase.monad}
+ [functionO (expression archive functionS)
+ argsO+ (monad.map ! (expression archive) argsS+)]
+ (wrap (_.apply/* argsO+ functionO))))
+
+(def: capture
+ (-> Register Var)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: (with_closure inits @self @args body!)
+ (-> (List Expression) Var (List Var) Statement [Statement Expression])
+ (case inits
+ #.Nil
+ [(_.function @self @args body!)
+ @self]
+
+ _
+ (let [@inits (|> (list.enumeration inits)
+ (list\map (|>> product.left ..capture)))]
+ [(_.function @self @inits
+ ($_ _.then
+ (_.local_function @self @args body!)
+ (_.return @self)))
+ (_.apply/* inits @self)])))
+
+(def: input
+ (|>> inc //case.register))
+
+(def: (@scope function_name)
+ (-> Context Label)
+ (_.label (format (///reference.artifact function_name) "_scope")))
+
+(def: #export (function statement expression archive [environment arity bodyS])
+ (-> Phase! (Generator (Abstraction Synthesis)))
+ (do {! ///////phase.monad}
+ [[function_name body!] (/////generation.with_new_context archive
+ (do !
+ [@scope (\ ! map ..@scope
+ (/////generation.context archive))]
+ (/////generation.with_anchor [1 @scope]
+ (statement expression archive bodyS))))
+ closureO+ (monad.map ! (expression archive) environment)
+ #let [@curried (_.var "curried")
+ arityO (|> arity .int _.int)
+ @num_args (_.var "num_args")
+ @scope (..@scope function_name)
+ @self (_.var (///reference.artifact function_name))
+ initialize_self! (_.local/1 (//case.register 0) @self)
+ initialize! (list\fold (.function (_ post pre!)
+ ($_ _.then
+ pre!
+ (_.local/1 (..input post) (_.nth (|> post inc .int _.int) @curried))))
+ initialize_self!
+ (list.indices arity))
+ pack (|>> (list) _.array)
+ unpack (_.apply/1 (_.var "table.unpack"))
+ @var_args (_.var "...")]
+ #let [[definition instantiation] (with_closure closureO+ @self (list @var_args)
+ ($_ _.then
+ (_.local/1 @curried (pack @var_args))
+ (_.local/1 @num_args (_.length @curried))
+ (_.cond (list [(|> @num_args (_.= arityO))
+ ($_ _.then
+ initialize!
+ (_.set_label @scope)
+ body!)]
+ [(|> @num_args (_.> arityO))
+ (let [arity_inputs (_.apply/5 (_.var "table.move")
+ @curried
+ (_.int +1)
+ arityO
+ (_.int +1)
+ (_.array (list)))
+ extra_inputs (_.apply/5 (_.var "table.move")
+ @curried
+ (_.+ (_.int +1) arityO)
+ @num_args
+ (_.int +1)
+ (_.array (list)))]
+ (_.return (|> @self
+ (_.apply/* (list (unpack arity_inputs)))
+ (_.apply/* (list (unpack extra_inputs))))))])
+ ## (|> @num_args (_.< arityO))
+ (_.return (_.closure (list @var_args)
+ (let [@extra_args (_.var "extra_args")]
+ ($_ _.then
+ (_.local/1 @extra_args (pack @var_args))
+ (_.return (|> (_.array (list))
+ (_.apply/5 (_.var "table.move")
+ @curried
+ (_.int +1)
+ @num_args
+ (_.int +1))
+ (_.apply/5 (_.var "table.move")
+ @extra_args
+ (_.int +1)
+ (_.length @extra_args)
+ (_.+ (_.int +1) @num_args))
+ unpack
+ (_.apply/1 @self))))))))
+ ))]
+ _ (/////generation.execute! definition)
+ _ (/////generation.save! (product.right function_name) definition)]
+ (wrap instantiation)))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux
new file mode 100644
index 000000000..a6719856c
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux
@@ -0,0 +1,119 @@
+(.module:
+ [library
+ [lux (#- Scope)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." set]]]
+ [math
+ [number
+ ["n" nat]]]
+ [target
+ ["_" lua (#+ Var Expression Label Statement)]]]]
+ ["." // #_
+ [runtime (#+ Operation Phase Phase! Generator Generator!)]
+ ["#." case]
+ ["/#" // #_
+ ["#." reference]
+ ["//#" /// #_
+ ["."synthesis (#+ Scope Synthesis)]
+ ["#." generation]
+ ["//#" /// #_
+ ["#." phase]
+ [meta
+ [archive (#+ Archive)]]
+ [reference
+ [variable (#+ Register)]]]]]])
+
+(def: @scope
+ (-> Nat Label)
+ (|>> %.nat (format "scope") _.label))
+
+(def: (setup initial? offset bindings as_expression? body)
+ (-> Bit Register (List Expression) Bit Statement Statement)
+ (let [variables (|> bindings
+ list.enumeration
+ (list\map (|>> product.left (n.+ offset) //case.register)))]
+ (if as_expression?
+ body
+ ($_ _.then
+ (if initial?
+ (_.let variables (_.multi bindings))
+ (_.set variables (_.multi bindings)))
+ body))))
+
+(def: #export (scope! statement expression archive as_expression? [start initsS+ bodyS])
+ ## (Generator! (Scope Synthesis))
+ (-> Phase! Phase Archive Bit (Scope Synthesis)
+ (Operation [(List Expression) Statement]))
+ (case initsS+
+ ## function/false/non-independent loop
+ #.Nil
+ (|> bodyS
+ (statement expression archive)
+ (\ ///////phase.monad map (|>> [(list)])))
+
+ ## true loop
+ _
+ (do {! ///////phase.monad}
+ [@scope (\ ! map ..@scope /////generation.next)
+ initsO+ (monad.map ! (expression archive) initsS+)
+ body! (/////generation.with_anchor [start @scope]
+ (statement expression archive bodyS))]
+ (wrap [initsO+
+ (..setup true start initsO+ as_expression?
+ ($_ _.then
+ (_.set_label @scope)
+ body!))]))))
+
+(def: #export (scope statement expression archive [start initsS+ bodyS])
+ (-> Phase! (Generator (Scope Synthesis)))
+ (case initsS+
+ ## function/false/non-independent loop
+ #.Nil
+ (expression archive bodyS)
+
+ ## true loop
+ _
+ (do {! ///////phase.monad}
+ [[[artifact_module artifact_id] [initsO+ scope!]] (/////generation.with_new_context archive
+ (scope! statement expression archive true [start initsS+ bodyS]))
+ #let [@loop (_.var (///reference.artifact [artifact_module artifact_id]))
+ locals (|> initsO+
+ list.enumeration
+ (list\map (|>> product.left (n.+ start) //case.register)))
+ [directive instantiation] (: [Statement Expression]
+ (case (|> (synthesis.path/then bodyS)
+ //case.dependencies
+ (set.from_list _.hash)
+ (set.difference (set.from_list _.hash locals))
+ set.to_list)
+ #.Nil
+ [(_.function @loop locals
+ scope!)
+ @loop]
+
+ foreigns
+ (let [@context (_.var (format (_.code @loop) "_context"))]
+ [(_.function @context foreigns
+ ($_ _.then
+ (<| (_.local_function @loop locals)
+ scope!)
+ (_.return @loop)
+ ))
+ (|> @context (_.apply/* foreigns))])))]
+ _ (/////generation.execute! directive)
+ _ (/////generation.save! artifact_id directive)]
+ (wrap (|> instantiation (_.apply/* initsO+))))))
+
+(def: #export (recur! statement expression archive argsS+)
+ (Generator! (List Synthesis))
+ (do {! ///////phase.monad}
+ [[offset @scope] /////generation.anchor
+ argsO+ (monad.map ! (expression archive) argsS+)]
+ (wrap (..setup false offset argsO+ false (_.go_to @scope)))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux
new file mode 100644
index 000000000..7d010b4cb
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux
@@ -0,0 +1,16 @@
+(.module:
+ [library
+ [lux (#- i64)
+ [target
+ ["_" lua (#+ Literal)]]]])
+
+(template [<name> <type> <implementation>]
+ [(def: #export <name>
+ (-> <type> Literal)
+ <implementation>)]
+
+ [bit Bit _.bool]
+ [i64 (I64 Any) (|>> .int _.int)]
+ [f64 Frac _.float]
+ [text Text _.string]
+ )
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux
new file mode 100644
index 000000000..52bc69a29
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux
@@ -0,0 +1,13 @@
+(.module:
+ [library
+ [lux #*
+ [target
+ ["_" lua (#+ Expression)]]]]
+ [///
+ [reference (#+ System)]])
+
+(implementation: #export system
+ (System Expression)
+
+ (def: constant _.var)
+ (def: variable _.var))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux
new file mode 100644
index 000000000..a0266db38
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux
@@ -0,0 +1,432 @@
+(.module:
+ [library
+ [lux (#- Location inc)
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<.>" code]]]
+ [data
+ ["." product]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." row]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number (#+ hex)
+ ["." i64]]]
+ ["@" target
+ ["_" lua (#+ Expression Location Var Computation Literal Label Statement)]]]]
+ ["." /// #_
+ ["#." reference]
+ ["//#" /// #_
+ ["#." synthesis (#+ Synthesis)]
+ ["#." generation]
+ ["//#" ///
+ ["#." phase]
+ [reference
+ [variable (#+ Register)]]
+ [meta
+ [archive (#+ Output Archive)
+ ["." artifact (#+ Registry)]]]]]])
+
+(template [<name> <base>]
+ [(type: #export <name>
+ (<base> [Register Label] Expression Statement))]
+
+ [Operation /////generation.Operation]
+ [Phase /////generation.Phase]
+ [Handler /////generation.Handler]
+ [Bundle /////generation.Bundle]
+ )
+
+(type: #export (Generator i)
+ (-> Phase Archive i (Operation Expression)))
+
+(type: #export Phase!
+ (-> Phase Archive Synthesis (Operation Statement)))
+
+(type: #export (Generator! i)
+ (-> Phase! Phase Archive i (Operation Statement)))
+
+(def: #export unit
+ (_.string /////synthesis.unit))
+
+(def: (flag value)
+ (-> Bit Literal)
+ (if value
+ ..unit
+ _.nil))
+
+(def: #export variant_tag_field "_lux_tag")
+(def: #export variant_flag_field "_lux_flag")
+(def: #export variant_value_field "_lux_value")
+
+(def: (variant' tag last? value)
+ (-> Expression Expression Expression Literal)
+ (_.table (list [..variant_tag_field tag]
+ [..variant_flag_field last?]
+ [..variant_value_field value])))
+
+(def: #export (variant tag last? value)
+ (-> Nat Bit Expression Literal)
+ (variant' (_.int (.int tag))
+ (flag last?)
+ value))
+
+(def: #export none
+ Literal
+ (..variant 0 #0 ..unit))
+
+(def: #export some
+ (-> Expression Literal)
+ (..variant 1 #1))
+
+(def: #export left
+ (-> Expression Literal)
+ (..variant 0 #0))
+
+(def: #export right
+ (-> Expression Literal)
+ (..variant 1 #1))
+
+(def: (feature name definition)
+ (-> Var (-> Var Statement) Statement)
+ (definition name))
+
+(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
+ body)
+ (do {! meta.monad}
+ [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
+ (wrap (list (` (let [(~+ (|> vars
+ (list.zip/2 ids)
+ (list\map (function (_ [id var])
+ (list (code.local_identifier var)
+ (` (_.var (~ (code.text (format "v" (%.nat id)))))))))
+ list.concat))]
+ (~ body)))))))
+
+(def: module_id
+ 0)
+
+(syntax: (runtime: {declaration (<>.or <code>.local_identifier
+ (<code>.form (<>.and <code>.local_identifier
+ (<>.some <code>.local_identifier))))}
+ code)
+ (do meta.monad
+ [runtime_id meta.count]
+ (macro.with_gensyms [g!_]
+ (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id]))
+ runtime_name (` (_.var (~ (code.text (%.code runtime)))))]
+ (case declaration
+ (#.Left name)
+ (macro.with_gensyms [g!_]
+ (let [g!name (code.local_identifier name)]
+ (wrap (list (` (def: #export (~ g!name)
+ Var
+ (~ runtime_name)))
+
+ (` (def: (~ (code.local_identifier (format "@" name)))
+ Statement
+ (..feature (~ runtime_name)
+ (function ((~ g!_) (~ g!name))
+ (_.set (~ g!name) (~ code))))))))))
+
+ (#.Right [name inputs])
+ (macro.with_gensyms [g!_]
+ (let [g!name (code.local_identifier name)
+ inputsC (list\map code.local_identifier inputs)
+ inputs_typesC (list\map (function.constant (` _.Expression))
+ inputs)]
+ (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
+ (-> (~+ inputs_typesC) Computation)
+ (_.apply/* (list (~+ inputsC)) (~ runtime_name))))
+
+ (` (def: (~ (code.local_identifier (format "@" name)))
+ Statement
+ (..feature (~ runtime_name)
+ (function ((~ g!_) (~ g!_))
+ (..with_vars [(~+ inputsC)]
+ (_.function (~ g!_) (list (~+ inputsC))
+ (~ code))))))))))))))))
+
+(def: (nth index table)
+ (-> Expression Expression Location)
+ (_.nth (_.+ (_.int +1) index) table))
+
+(def: last_index
+ (|>> _.length (_.- (_.int +1))))
+
+(with_expansions [<recur> (as_is ($_ _.then
+ (_.set (list lefts) (_.- last_index_right lefts))
+ (_.set (list tuple) (..nth last_index_right tuple))))]
+ (runtime: (tuple//left lefts tuple)
+ (with_vars [last_index_right]
+ (<| (_.while (_.bool true))
+ ($_ _.then
+ (_.local/1 last_index_right (..last_index tuple))
+ (_.if (_.> lefts last_index_right)
+ ## No need for recursion
+ (_.return (..nth lefts tuple))
+ ## Needs recursion
+ <recur>)))))
+
+ (runtime: (tuple//right lefts tuple)
+ (with_vars [last_index_right right_index]
+ (<| (_.while (_.bool true))
+ ($_ _.then
+ (_.local/1 last_index_right (..last_index tuple))
+ (_.local/1 right_index (_.+ (_.int +1) lefts))
+ (_.cond (list [(_.= last_index_right right_index)
+ (_.return (..nth right_index tuple))]
+ [(_.> last_index_right right_index)
+ ## Needs recursion.
+ <recur>])
+ (_.return (_.apply/* (list tuple
+ (_.+ (_.int +1) right_index)
+ (_.length tuple)
+ (_.int +1)
+ (_.array (list)))
+ (_.var "table.move"))))
+ )))))
+
+(runtime: (sum//get sum wants_last wanted_tag)
+ (let [no_match! (_.return _.nil)
+ sum_tag (_.the ..variant_tag_field sum)
+ sum_flag (_.the ..variant_flag_field sum)
+ sum_value (_.the ..variant_value_field sum)
+ is_last? (_.= ..unit sum_flag)
+ extact_match! (_.return sum_value)
+ test_recursion! (_.if is_last?
+ ## Must recurse.
+ ($_ _.then
+ (_.set (list wanted_tag) (_.- sum_tag wanted_tag))
+ (_.set (list sum) sum_value))
+ no_match!)
+ extrac_sub_variant! (_.return (variant' (_.- wanted_tag sum_tag) sum_flag sum_value))]
+ (<| (_.while (_.bool true))
+ (_.cond (list [(_.= sum_tag wanted_tag)
+ (_.if (_.= wants_last sum_flag)
+ extact_match!
+ test_recursion!)]
+ [(_.< wanted_tag sum_tag)
+ test_recursion!]
+ [(_.= ..unit wants_last)
+ extrac_sub_variant!])
+ no_match!))))
+
+(def: runtime//adt
+ Statement
+ ($_ _.then
+ @tuple//left
+ @tuple//right
+ @sum//get
+ ))
+
+(runtime: (lux//try risky)
+ (with_vars [success value]
+ ($_ _.then
+ (_.let (list success value) (|> risky (_.apply/* (list ..unit))
+ _.return (_.closure (list))
+ list _.apply/* (|> (_.var "pcall"))))
+ (_.if success
+ (_.return (..right value))
+ (_.return (..left value))))))
+
+(runtime: (lux//program_args raw)
+ (with_vars [tail head idx]
+ ($_ _.then
+ (_.let (list tail) ..none)
+ (<| (_.for_step idx (_.length raw) (_.int +1) (_.int -1))
+ (_.set (list tail) (..some (_.array (list (_.nth idx raw)
+ tail)))))
+ (_.return tail))))
+
+(def: runtime//lux
+ Statement
+ ($_ _.then
+ @lux//try
+ @lux//program_args
+ ))
+
+(def: cap_shift
+ (_.% (_.int +64)))
+
+(runtime: (i64//left_shift param subject)
+ (_.return (_.bit_shl (..cap_shift param) subject)))
+
+(runtime: (i64//right_shift param subject)
+ (let [mask (|> (_.int +1)
+ (_.bit_shl (_.- param (_.int +64)))
+ (_.- (_.int +1)))]
+ ($_ _.then
+ (_.set (list param) (..cap_shift param))
+ (_.return (|> subject
+ (_.bit_shr param)
+ (_.bit_and mask))))))
+
+(runtime: (i64//division param subject)
+ (with_vars [floored]
+ ($_ _.then
+ (_.local/1 floored (_.// param subject))
+ (let [potentially_floored? (_.< (_.int +0) floored)
+ inexact? (|> subject
+ (_.% param)
+ (_.= (_.int +0))
+ _.not)]
+ (_.if (_.and potentially_floored?
+ inexact?)
+ (_.return (_.+ (_.int +1) floored))
+ (_.return floored))))))
+
+(runtime: (i64//remainder param subject)
+ (_.return (_.- (|> subject (..i64//division param) (_.* param))
+ subject)))
+
+(def: runtime//i64
+ Statement
+ ($_ _.then
+ @i64//left_shift
+ @i64//right_shift
+ @i64//division
+ @i64//remainder
+ ))
+
+(def: (find_byte_index subject param start)
+ (-> Expression Expression Expression Expression)
+ (_.apply/4 (_.var "string.find") subject param start (_.bool #1)))
+
+(def: (char_index subject byte_index)
+ (-> Expression Expression Expression)
+ (|> byte_index
+ (_.apply/3 (_.var "utf8.len") subject (_.int +1))))
+
+(def: (byte_index subject char_index)
+ (-> Expression Expression Expression)
+ (|> char_index
+ (_.+ (_.int +1))
+ (_.apply/2 (_.var "utf8.offset") subject)))
+
+(def: lux_index
+ (-> Expression Expression)
+ (_.- (_.int +1)))
+
+## TODO: Remove this once the Lua compiler becomes self-hosted.
+(def: on_rembulan?
+ (_.= (_.string "Lua 5.3")
+ (_.var "_VERSION")))
+
+(runtime: (text//index subject param start)
+ (with_expansions [<rembulan> ($_ _.then
+ (_.local/1 byte_index (|> start
+ (_.+ (_.int +1))
+ (..find_byte_index subject param)))
+ (_.if (_.= _.nil byte_index)
+ (_.return ..none)
+ (_.return (..some (..lux_index byte_index)))))
+ <normal> ($_ _.then
+ (_.local/1 byte_index (|> start
+ (..byte_index subject)
+ (..find_byte_index subject param)))
+ (_.if (_.= _.nil byte_index)
+ (_.return ..none)
+ (_.return (..some (|> byte_index
+ (..char_index subject)
+ ..lux_index)))))]
+ (with_vars [byte_index]
+ (for {@.lua <normal>}
+ (_.if ..on_rembulan?
+ <rembulan>
+ <normal>)))))
+
+(runtime: (text//clip text offset length)
+ (with_expansions [<rembulan> (_.return (_.apply/3 (_.var "string.sub") text (_.+ (_.int +1) offset) (_.+ offset length)))
+ <normal> (_.return (_.apply/3 (_.var "string.sub")
+ text
+ (..byte_index text offset)
+ (|> (_.+ offset length)
+ ## (_.+ (_.int +1))
+ (..byte_index text)
+ (_.- (_.int +1)))))]
+ (for {@.lua <normal>}
+ (_.if ..on_rembulan?
+ <rembulan>
+ <normal>))))
+
+(runtime: (text//size subject)
+ (with_expansions [<rembulan> (_.return (_.apply/1 (_.var "string.len") subject))
+ <normal> (_.return (_.apply/1 (_.var "utf8.len") subject))]
+ (for {@.lua <normal>}
+ (_.if ..on_rembulan?
+ <rembulan>
+ <normal>))))
+
+(runtime: (text//char idx text)
+ (with_expansions [<rembulan> (with_vars [char]
+ ($_ _.then
+ (_.local/1 char (_.apply/* (list text idx)
+ (_.var "string.byte")))
+ (_.if (_.= _.nil char)
+ (_.statement (_.error/1 (_.string "[Lux Error] Cannot get char from text.")))
+ (_.return char))))
+ <normal> (with_vars [offset char]
+ ($_ _.then
+ (_.local/1 offset (_.apply/2 (_.var "utf8.offset") text idx))
+ (_.if (_.= _.nil offset)
+ (_.statement (_.error/1 (_.string "[Lux Error] Cannot get char from text.")))
+ (_.return (_.apply/2 (_.var "utf8.codepoint") text offset)))))]
+ (for {@.lua <normal>}
+ (_.if ..on_rembulan?
+ <rembulan>
+ <normal>))))
+
+(def: runtime//text
+ Statement
+ ($_ _.then
+ @text//index
+ @text//clip
+ @text//size
+ @text//char
+ ))
+
+(runtime: (array//write idx value array)
+ ($_ _.then
+ (_.set (list (..nth idx array)) value)
+ (_.return array)))
+
+(def: runtime//array
+ Statement
+ ($_ _.then
+ @array//write
+ ))
+
+(def: runtime
+ Statement
+ ($_ _.then
+ ..runtime//adt
+ ..runtime//lux
+ ..runtime//i64
+ ..runtime//text
+ ..runtime//array
+ ))
+
+(def: #export generate
+ (Operation [Registry Output])
+ (do ///////phase.monad
+ [_ (/////generation.execute! ..runtime)
+ _ (/////generation.save! ..module_id ..runtime)]
+ (wrap [(|> artifact.empty
+ artifact.resource
+ product.right)
+ (row.row [..module_id
+ (|> ..runtime
+ _.code
+ (\ utf8.codec encode))])])))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux
new file mode 100644
index 000000000..ff9bae4be
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux
@@ -0,0 +1,37 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [target
+ ["_" lua (#+ Expression)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." primitive]
+ ["///#" //// #_
+ [analysis (#+ Variant Tuple)]
+ ["#." synthesis (#+ Synthesis)]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]]]])
+
+(def: #export (tuple generate archive elemsS+)
+ (Generator (Tuple Synthesis))
+ (case elemsS+
+ #.Nil
+ (///////phase\wrap (//primitive.text /////synthesis.unit))
+
+ (#.Cons singletonS #.Nil)
+ (generate archive singletonS)
+
+ _
+ (|> elemsS+
+ (monad.map ///////phase.monad (generate archive))
+ (///////phase\map _.array))))
+
+(def: #export (variant generate archive [lefts right? valueS])
+ (Generator (Variant Synthesis))
+ (let [tag (if right?
+ (inc lefts)
+ lefts)]
+ (///////phase\map (//runtime.variant tag right?)
+ (generate archive valueS))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php.lux
new file mode 100644
index 000000000..5bcb2770d
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php.lux
@@ -0,0 +1,103 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]]
+ [target
+ ["_" php]]]]
+ ["." / #_
+ [runtime (#+ Phase Phase!)]
+ ["#." primitive]
+ ["#." structure]
+ ["#." reference]
+ ["#." case]
+ ["#." loop]
+ ["#." function]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." extension]
+ ["/#" // #_
+ [analysis (#+)]
+ ["#." synthesis]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]
+ [reference (#+)
+ [variable (#+)]]]]]]])
+
+(def: (statement expression archive synthesis)
+ Phase!
+ (case synthesis
+ (^template [<tag>]
+ [(^ (<tag> value))
+ (//////phase\map _.return (expression archive synthesis))])
+ ([////synthesis.bit]
+ [////synthesis.i64]
+ [////synthesis.f64]
+ [////synthesis.text]
+ [////synthesis.variant]
+ [////synthesis.tuple]
+ [#////synthesis.Reference]
+ [////synthesis.branch/get]
+ [////synthesis.function/apply]
+ [#////synthesis.Extension])
+
+ (^ (////synthesis.branch/case case))
+ (/case.case! statement expression archive case)
+
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (<generator> statement expression archive value)])
+ ([////synthesis.branch/let /case.let!]
+ [////synthesis.branch/if /case.if!]
+ [////synthesis.loop/scope /loop.scope!]
+ [////synthesis.loop/recur /loop.recur!])
+
+ (^ (////synthesis.function/abstraction abstraction))
+ (//////phase\map _.return (/function.function statement expression archive abstraction))
+ ))
+
+(exception: #export cannot-recur-as-an-expression)
+
+(def: #export (expression archive synthesis)
+ Phase
+ (case synthesis
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (//////phase\wrap (<generator> value))])
+ ([////synthesis.bit /primitive.bit]
+ [////synthesis.i64 /primitive.i64]
+ [////synthesis.f64 /primitive.f64]
+ [////synthesis.text /primitive.text])
+
+ (#////synthesis.Reference value)
+ (//reference.reference /reference.system archive value)
+
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (<generator> expression archive value)])
+ ([////synthesis.variant /structure.variant]
+ [////synthesis.tuple /structure.tuple]
+ [////synthesis.branch/let /case.let]
+ [////synthesis.branch/if /case.if]
+ [////synthesis.branch/get /case.get]
+ [////synthesis.function/apply /function.apply])
+
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (<generator> statement expression archive value)])
+ ([////synthesis.branch/case /case.case]
+ [////synthesis.loop/scope /loop.scope]
+ [////synthesis.function/abstraction /function.function])
+
+ (^ (////synthesis.loop/recur _))
+ (//////phase.throw ..cannot-recur-as-an-expression [])
+
+ (#////synthesis.Extension extension)
+ (///extension.apply archive expression extension)))
+
+(def: #export generate
+ Phase
+ ..expression)
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/case.lux
new file mode 100644
index 000000000..d6a4c67b0
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/case.lux
@@ -0,0 +1,298 @@
+(.module:
+ [library
+ [lux (#- case let if)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." set]]]
+ [math
+ [number
+ ["i" int]]]
+ [target
+ ["_" php (#+ Expression Var Statement)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Phase! Generator Generator!)]
+ ["#." reference]
+ ["#." primitive]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." synthesis #_
+ ["#/." case]]
+ ["/#" // #_
+ ["#." synthesis (#+ Member Synthesis Path)]
+ ["#." generation]
+ ["//#" /// #_
+ [reference
+ ["#." variable (#+ Register)]]
+ ["#." phase ("#\." monad)]
+ [meta
+ [archive (#+ Archive)]]]]]]])
+
+(def: #export register
+ (-> Register Var)
+ (|>> (///reference.local //reference.system) :assume))
+
+(def: #export capture
+ (-> Register Var)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: #export (let expression archive [valueS register bodyS])
+ (Generator [Synthesis Register Synthesis])
+ (do ///////phase.monad
+ [valueG (expression archive valueS)
+ bodyG (expression archive bodyS)]
+ (wrap (|> bodyG
+ (list (_.set (..register register) valueG))
+ _.array/*
+ (_.nth (_.int +1))))))
+
+(def: #export (let! statement expression archive [valueS register bodyS])
+ (Generator! [Synthesis Register Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)
+ body! (statement expression archive bodyS)]
+ (wrap ($_ _.then
+ (_.set! (..register register) valueO)
+ body!))))
+
+(def: #export (if expression archive [testS thenS elseS])
+ (Generator [Synthesis Synthesis Synthesis])
+ (do ///////phase.monad
+ [testG (expression archive testS)
+ thenG (expression archive thenS)
+ elseG (expression archive elseS)]
+ (wrap (_.? testG thenG elseG))))
+
+(def: #export (if! statement expression archive [testS thenS elseS])
+ (Generator! [Synthesis Synthesis Synthesis])
+ (do ///////phase.monad
+ [test! (expression archive testS)
+ then! (statement expression archive thenS)
+ else! (statement expression archive elseS)]
+ (wrap (_.if test!
+ then!
+ else!))))
+
+(def: #export (get expression archive [pathP valueS])
+ (Generator [(List Member) Synthesis])
+ (do ///////phase.monad
+ [valueG (expression archive valueS)]
+ (wrap (list\fold (function (_ side source)
+ (.let [method (.case side
+ (^template [<side> <accessor>]
+ [(<side> lefts)
+ (<accessor> (_.int (.int lefts)))])
+ ([#.Left //runtime.tuple//left]
+ [#.Right //runtime.tuple//right]))]
+ (method source)))
+ valueG
+ (list.reverse pathP)))))
+
+(def: @savepoint (_.var "lux_pm_savepoint"))
+(def: @cursor (_.var "lux_pm_cursor"))
+(def: @temp (_.var "lux_pm_temp"))
+
+(def: (push! value)
+ (-> Expression Statement)
+ (_.; (_.array_push/2 [@cursor value])))
+
+(def: peek_and_pop
+ Expression
+ (_.array_pop/1 @cursor))
+
+(def: pop!
+ Statement
+ (_.; ..peek_and_pop))
+
+(def: peek
+ Expression
+ (_.nth (|> @cursor _.count/1 (_.- (_.int +1)))
+ @cursor))
+
+(def: save!
+ Statement
+ (.let [cursor (_.array_slice/2 [@cursor (_.int +0)])]
+ (_.; (_.array_push/2 [@savepoint cursor]))))
+
+(def: restore!
+ Statement
+ (_.set! @cursor (_.array_pop/1 @savepoint)))
+
+(def: fail! _.break)
+
+(def: (multi_pop! pops)
+ (-> Nat Statement)
+ (_.; (_.array_splice/3 [@cursor
+ (_.int +0)
+ (_.int (i.* -1 (.int pops)))])))
+
+(template [<name> <flag> <prep>]
+ [(def: (<name> simple? idx)
+ (-> Bit Nat Statement)
+ ($_ _.then
+ (_.set! @temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>)))
+ (.if simple?
+ (_.when (_.is_null/1 @temp)
+ fail!)
+ (_.if (_.is_null/1 @temp)
+ fail!
+ (..push! @temp)))))]
+
+ [left_choice _.null (<|)]
+ [right_choice (_.string "") inc]
+ )
+
+(def: (alternation pre! post!)
+ (-> Statement Statement Statement)
+ ($_ _.then
+ (_.do_while (_.bool false)
+ ($_ _.then
+ ..save!
+ pre!))
+ ($_ _.then
+ ..restore!
+ post!)))
+
+(def: (pattern_matching' statement expression archive)
+ (Generator! Path)
+ (function (recur pathP)
+ (.case pathP
+ (#/////synthesis.Then bodyS)
+ (statement expression archive bodyS)
+
+ #/////synthesis.Pop
+ (///////phase\wrap ..pop!)
+
+ (#/////synthesis.Bind register)
+ (///////phase\wrap (_.set! (..register register) ..peek))
+
+ (#/////synthesis.Bit_Fork when thenP elseP)
+ (do {! ///////phase.monad}
+ [then! (recur thenP)
+ else! (.case elseP
+ (#.Some elseP)
+ (recur elseP)
+
+ #.None
+ (wrap ..fail!))]
+ (wrap (.if when
+ (_.if ..peek
+ then!
+ else!)
+ (_.if ..peek
+ else!
+ then!))))
+
+ (^template [<tag> <format>]
+ [(<tag> cons)
+ (do {! ///////phase.monad}
+ [clauses (monad.map ! (function (_ [match then])
+ (do !
+ [then! (recur then)]
+ (wrap [(_.=== (|> match <format>)
+ ..peek)
+ then!])))
+ (#.Cons cons))]
+ (wrap (_.cond clauses ..fail!)))])
+ ([#/////synthesis.I64_Fork //primitive.i64]
+ [#/////synthesis.F64_Fork //primitive.f64]
+ [#/////synthesis.Text_Fork //primitive.text])
+
+ (^template [<complex> <simple> <choice>]
+ [(^ (<complex> idx))
+ (///////phase\wrap (<choice> false idx))
+
+ (^ (<simple> idx nextP))
+ (|> nextP
+ recur
+ (\ ///////phase.monad map (_.then (<choice> true idx))))])
+ ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice]
+ [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice])
+
+ (^ (/////synthesis.member/left 0))
+ (///////phase\wrap (|> ..peek (_.nth (_.int +0)) ..push!))
+
+ (^template [<pm> <getter>]
+ [(^ (<pm> lefts))
+ (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))])
+ ([/////synthesis.member/left //runtime.tuple//left]
+ [/////synthesis.member/right //runtime.tuple//right])
+
+ (^ (/////synthesis.!bind_top register thenP))
+ (do ///////phase.monad
+ [then! (recur thenP)]
+ (///////phase\wrap ($_ _.then
+ (_.set! (..register register) ..peek_and_pop)
+ then!)))
+
+ ## (^ (/////synthesis.!multi_pop nextP))
+ ## (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)]
+ ## (do ///////phase.monad
+ ## [next! (recur nextP')]
+ ## (///////phase\wrap ($_ _.then
+ ## (..multi_pop! (n.+ 2 extra_pops))
+ ## next!))))
+
+ (^template [<tag> <combinator>]
+ [(^ (<tag> preP postP))
+ (do ///////phase.monad
+ [pre! (recur preP)
+ post! (recur postP)]
+ (wrap (<combinator> pre! post!)))])
+ ([/////synthesis.path/seq _.then]
+ [/////synthesis.path/alt ..alternation]))))
+
+(def: (pattern_matching statement expression archive pathP)
+ (Generator! Path)
+ (do ///////phase.monad
+ [iteration! (pattern_matching' statement expression archive pathP)]
+ (wrap ($_ _.then
+ (_.do_while (_.bool false)
+ iteration!)
+ (_.throw (_.new (_.constant "Exception") (list (_.string ////synthesis/case.pattern_matching_error))))))))
+
+(def: (gensym prefix)
+ (-> Text (Operation Text))
+ (\ ///////phase.monad map (|>> %.nat (format prefix)) /////generation.next))
+
+(def: #export dependencies
+ (-> Path (List Var))
+ (|>> ////synthesis/case.storage
+ (get@ #////synthesis/case.dependencies)
+ set.to_list
+ (list\map (function (_ variable)
+ (.case variable
+ (#///////variable.Local register)
+ (..register register)
+
+ (#///////variable.Foreign register)
+ (..capture register))))))
+
+(def: #export (case! statement expression archive [valueS pathP])
+ (Generator! [Synthesis Path])
+ (do ///////phase.monad
+ [stack_init (expression archive valueS)
+ pattern_matching! (pattern_matching statement expression archive pathP)]
+ (wrap ($_ _.then
+ (_.set! @cursor (_.array/* (list stack_init)))
+ (_.set! @savepoint (_.array/* (list)))
+ pattern_matching!))))
+
+(def: #export (case statement expression archive [valueS pathP])
+ (-> Phase! (Generator [Synthesis Path]))
+ (do {! ///////phase.monad}
+ [[[case_module case_artifact] case!] (/////generation.with_new_context archive
+ (case! statement expression archive [valueS pathP]))
+ #let [@case (_.constant (///reference.artifact [case_module case_artifact]))
+ @dependencies+ (..dependencies (/////synthesis.path/seq (/////synthesis.path/then valueS)
+ pathP))
+ directive (_.define_function @case (list\map _.parameter @dependencies+) case!)]
+ _ (/////generation.execute! directive)
+ _ (/////generation.save! case_artifact directive)]
+ (wrap (_.apply/* @dependencies+ @case))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension.lux
new file mode 100644
index 000000000..1880d7700
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension.lux
@@ -0,0 +1,14 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]]
+ [//
+ [runtime (#+ Bundle)]]
+ [/
+ ["." common]])
+
+(def: #export bundle
+ Bundle
+ common.bundle)
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux
new file mode 100644
index 000000000..5eaccf0aa
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux
@@ -0,0 +1,112 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]]
+ [data
+ ["." product]
+ ["." text]
+ [number
+ ["f" frac]]
+ [collection
+ ["." dictionary]]]
+ [target
+ ["_" php (#+ Expression)]]]]
+ ["." /// #_
+ ["#." runtime (#+ Operation Phase Handler Bundle)]
+ ["#." primitive]
+ [//
+ [extension (#+ Nullary Unary Binary Trinary
+ nullary unary binary trinary)]
+ [//
+ [extension
+ ["." bundle]]]]])
+
+(def: lux-procs
+ Bundle
+ (|> bundle.empty
+ (bundle.install "is" (binary (product.uncurry _.=)))
+ (bundle.install "try" (unary ///runtime.lux//try))))
+
+(def: i64-procs
+ Bundle
+ (<| (bundle.prefix "i64")
+ (|> bundle.empty
+ (bundle.install "and" (binary (product.uncurry _.bit-and)))
+ (bundle.install "or" (binary (product.uncurry _.bit-or)))
+ (bundle.install "xor" (binary (product.uncurry _.bit-xor)))
+ (bundle.install "left-shift" (binary (product.uncurry _.bit-shl)))
+ (bundle.install "logical-right-shift" (binary (product.uncurry ///runtime.i64//logic-right-shift)))
+ (bundle.install "arithmetic-right-shift" (binary (product.uncurry _.bit-shr)))
+ (bundle.install "=" (binary (product.uncurry _.=)))
+ (bundle.install "+" (binary (product.uncurry _.+)))
+ (bundle.install "-" (binary (product.uncurry _.-)))
+ )))
+
+(def: int-procs
+ Bundle
+ (<| (bundle.prefix "int")
+ (|> bundle.empty
+ (bundle.install "<" (binary (product.uncurry _.<)))
+ (bundle.install "*" (binary (product.uncurry _.*)))
+ (bundle.install "/" (binary (product.uncurry _./)))
+ (bundle.install "%" (binary (product.uncurry _.%)))
+ (bundle.install "frac" (unary _.floatval/1))
+ (bundle.install "char" (unary _.chr/1)))))
+
+(def: frac-procs
+ Bundle
+ (<| (bundle.prefix "frac")
+ (|> bundle.empty
+ (bundle.install "+" (binary (product.uncurry _.+)))
+ (bundle.install "-" (binary (product.uncurry _.-)))
+ (bundle.install "*" (binary (product.uncurry _.*)))
+ (bundle.install "/" (binary (product.uncurry _./)))
+ (bundle.install "%" (binary (product.uncurry _.%)))
+ (bundle.install "=" (binary (product.uncurry _.=)))
+ (bundle.install "<" (binary (product.uncurry _.<)))
+ (bundle.install "int" (unary _.intval/1))
+ (bundle.install "encode" (unary _.strval/1))
+ (bundle.install "decode" (unary (|>> _.floatval/1 ///runtime.some)))
+ )))
+
+(def: (text//index [startO partO textO])
+ (Trinary (Expression Any))
+ (///runtime.text//index textO partO startO))
+
+(def: text-procs
+ Bundle
+ (<| (bundle.prefix "text")
+ (|> bundle.empty
+ (bundle.install "=" (binary (product.uncurry _.=)))
+ (bundle.install "<" (binary (product.uncurry _.<)))
+ (bundle.install "concat" (binary (product.uncurry _.concat)))
+ (bundle.install "index" (trinary text//index))
+ (bundle.install "size" (unary _.strlen/1))
+ (bundle.install "char" (binary (function (text//char [text idx])
+ (|> text (_.nth idx) _.ord/1))))
+ (bundle.install "clip" (trinary (function (text//clip [from to text])
+ (_.substr/3 [text from (_.- from to)]))))
+ )))
+
+(def: io-procs
+ Bundle
+ (<| (bundle.prefix "io")
+ (|> bundle.empty
+ (bundle.install "log" (unary (|>> (_.concat (_.string text.new-line)) _.print/1)))
+ (bundle.install "error" (unary ///runtime.io//throw!))
+ (bundle.install "exit" (unary _.exit/1))
+ (bundle.install "current-time" (nullary (|>> _.time/0 (_.* (_.int +1,000))))))))
+
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "lux")
+ (|> lux-procs
+ (dictionary.merge i64-procs)
+ (dictionary.merge int-procs)
+ (dictionary.merge frac-procs)
+ (dictionary.merge text-procs)
+ (dictionary.merge io-procs)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/function.lux
new file mode 100644
index 000000000..819f6b244
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/function.lux
@@ -0,0 +1,116 @@
+(.module:
+ [library
+ [lux (#- Global function)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ pipe]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [target
+ ["_" php (#+ Var Global Expression Argument Label Statement)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Phase! Generator)]
+ ["#." reference]
+ ["#." case]
+ ["/#" // #_
+ ["#." reference]
+ ["//#" /// #_
+ [analysis (#+ Variant Tuple Abstraction Application Analysis)]
+ [synthesis (#+ Synthesis)]
+ ["#." generation (#+ Context)]
+ ["//#" /// #_
+ [arity (#+ Arity)]
+ ["#." phase ("#\." monad)]
+ [reference
+ [variable (#+ Register Variable)]]]]]])
+
+(def: #export (apply expression archive [functionS argsS+])
+ (Generator (Application Synthesis))
+ (do {! ///////phase.monad}
+ [functionG (expression archive functionS)
+ argsG+ (monad.map ! (expression archive) argsS+)]
+ (wrap (_.apply/*' argsG+ functionG))))
+
+(def: capture
+ (-> Register Var)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: input
+ (|>> inc //case.register))
+
+(def: (@scope function_name)
+ (-> Context Label)
+ (_.label (format (///reference.artifact function_name) "_scope")))
+
+(def: (with_closure inits @selfG @selfL body!)
+ (-> (List Expression) Global Var Statement [Statement Expression])
+ (case inits
+ #.Nil
+ [($_ _.then
+ (_.set! @selfL (_.closure (list (_.reference @selfL)) (list) body!))
+ (_.set! @selfG @selfL))
+ @selfG]
+
+ _
+ (let [@inits (|> (list.enumeration inits)
+ (list\map (|>> product.left ..capture)))]
+ [(_.set! @selfG (_.closure (list) (list\map _.parameter @inits)
+ ($_ _.then
+ (_.set! @selfL (_.closure (list& (_.reference @selfL) (list\map _.reference @inits))
+ (list)
+ body!))
+ (_.return @selfL))))
+ (_.apply/* inits @selfG)])))
+
+(def: #export (function statement expression archive [environment arity bodyS])
+ (-> Phase! (Generator (Abstraction Synthesis)))
+ (do {! ///////phase.monad}
+ [[function_name body!] (/////generation.with_new_context archive
+ (do !
+ [@scope (\ ! map ..@scope
+ (/////generation.context archive))]
+ (/////generation.with_anchor [1 @scope]
+ (statement expression archive bodyS))))
+ closureG+ (monad.map ! (expression archive) environment)
+ #let [@curried (_.var "curried")
+ arityG (|> arity .int _.int)
+ @num_args (_.var "num_args")
+ @scope (..@scope function_name)
+ @selfG (_.global (///reference.artifact function_name))
+ @selfL (_.var (///reference.artifact function_name))
+ initialize_self! (_.set! (//case.register 0) @selfL)
+ initialize! (list\fold (.function (_ post pre!)
+ ($_ _.then
+ pre!
+ (_.set! (..input post) (_.nth (|> post .int _.int) @curried))))
+ initialize_self!
+ (list.indices arity))]
+ #let [[definition instantiation] (..with_closure closureG+ @selfG @selfL
+ ($_ _.then
+ (_.set! @num_args (_.func_num_args/0 []))
+ (_.set! @curried (_.func_get_args/0 []))
+ (_.cond (list [(|> @num_args (_.=== arityG))
+ ($_ _.then
+ initialize!
+ (_.set_label @scope)
+ body!)]
+ [(|> @num_args (_.> arityG))
+ (let [arity_inputs (_.array_slice/3 [@curried (_.int +0) arityG])
+ extra_inputs (_.array_slice/2 [@curried arityG])
+ next (_.call_user_func_array/2 [@selfL arity_inputs])]
+ (_.return (_.call_user_func_array/2 [next extra_inputs])))])
+ ## (|> @num_args (_.< arityG))
+ (let [@missing (_.var "missing")]
+ (_.return (<| (_.closure (list (_.reference @selfL) (_.reference @curried)) (list))
+ ($_ _.then
+ (_.set! @missing (_.func_get_args/0 []))
+ (_.return (_.call_user_func_array/2 [@selfL (_.array_merge/+ @curried (list @missing))])))))))
+ ))]
+ _ (/////generation.execute! definition)
+ _ (/////generation.save! (product.right function_name) definition)]
+ (wrap instantiation)))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/loop.lux
new file mode 100644
index 000000000..9dc7e9e78
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/loop.lux
@@ -0,0 +1,122 @@
+(.module:
+ [library
+ [lux (#- Scope)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." set (#+ Set)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [target
+ ["_" php (#+ Var Expression Label Statement)]]]]
+ ["." // #_
+ [runtime (#+ Operation Phase Phase! Generator Generator!)]
+ ["#." case]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ [synthesis
+ ["." case]]
+ ["/#" // #_
+ ["."synthesis (#+ Scope Synthesis)]
+ ["#." generation]
+ ["//#" /// #_
+ ["#." phase]
+ [meta
+ [archive (#+ Archive)]]
+ [reference
+ [variable (#+ Register)]]]]]]])
+
+(def: @scope
+ (-> Nat Label)
+ (|>> %.nat (format "scope") _.label))
+
+(def: (setup offset bindings body)
+ (-> Register (List Expression) Statement Statement)
+ (|> bindings
+ list.enumeration
+ (list\map (function (_ [register value])
+ (let [variable (//case.register (n.+ offset register))]
+ (_.set! variable value))))
+ list.reverse
+ (list\fold _.then body)))
+
+(def: #export (scope! statement expression archive [start initsS+ bodyS])
+ (Generator! (Scope Synthesis))
+ (case initsS+
+ ## function/false/non-independent loop
+ #.Nil
+ (statement expression archive bodyS)
+
+ ## true loop
+ _
+ (do {! ///////phase.monad}
+ [@scope (\ ! map ..@scope /////generation.next)
+ initsO+ (monad.map ! (expression archive) initsS+)
+ body! (/////generation.with_anchor [start @scope]
+ (statement expression archive bodyS))]
+ (wrap (..setup start initsO+
+ ($_ _.then
+ (_.set_label @scope)
+ body!))))))
+
+(def: #export (scope statement expression archive [start initsS+ bodyS])
+ (-> Phase! (Generator (Scope Synthesis)))
+ (case initsS+
+ ## function/false/non-independent loop
+ #.Nil
+ (expression archive bodyS)
+
+ ## true loop
+ _
+ (do {! ///////phase.monad}
+ [[[loop_module loop_artifact] scope!] (/////generation.with_new_context archive
+ (..scope! statement expression archive [start initsS+ bodyS]))
+ #let [locals (|> initsS+
+ list.enumeration
+ (list\map (|>> product.left (n.+ start) //case.register _.parameter)))
+ @loop (_.constant (///reference.artifact [loop_module loop_artifact]))
+ loop_variables (set.from_list _.hash (list\map product.right locals))
+ referenced_variables (: (-> Synthesis (Set Var))
+ (|>> synthesis.path/then
+ //case.dependencies
+ (set.from_list _.hash)))
+ [directive instantiation] (: [Statement Expression]
+ (case (|> (list\map referenced_variables initsS+)
+ (list\fold set.union (referenced_variables bodyS))
+ (set.difference loop_variables)
+ set.to_list)
+ #.Nil
+ [(_.define_function @loop (list) scope!)
+ @loop]
+
+ foreigns
+ [(<| (_.define_function @loop (list\map _.parameter foreigns))
+ (_.return (_.closure (list\map _.parameter foreigns) (list) scope!)))
+ (_.apply/* foreigns @loop)]))]
+ _ (/////generation.execute! directive)
+ _ (/////generation.save! loop_artifact directive)]
+ (wrap (_.apply/* (list) instantiation)))))
+
+(def: @temp
+ (_.var "lux_recur_values"))
+
+(def: #export (recur! statement expression archive argsS+)
+ (Generator! (List Synthesis))
+ (do {! ///////phase.monad}
+ [[offset @scope] /////generation.anchor
+ argsO+ (monad.map ! (expression archive) argsS+)]
+ (wrap ($_ _.then
+ (_.set! @temp (_.array/* argsO+))
+ (..setup offset
+ (|> argsO+
+ list.enumeration
+ (list\map (function (_ [idx _])
+ (_.nth (_.int (.int idx)) @temp))))
+ (_.go_to @scope))))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux
new file mode 100644
index 000000000..9101ee48d
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux
@@ -0,0 +1,32 @@
+(.module:
+ [library
+ [lux (#- i64)
+ [control
+ [pipe (#+ cond> new>)]]
+ [math
+ [number
+ ["." frac]]]
+ [target
+ ["_" php (#+ Literal Expression)]]]]
+ ["." // #_
+ ["#." runtime]])
+
+(def: #export bit
+ (-> Bit Literal)
+ _.bool)
+
+(def: #export (i64 value)
+ (-> (I64 Any) Expression)
+ (let [h32 (|> value //runtime.high .int _.int)
+ l32 (|> value //runtime.low .int _.int)]
+ (|> h32
+ (_.bit_shl (_.int +32))
+ (_.bit_or l32))))
+
+(def: #export f64
+ (-> Frac Literal)
+ _.float)
+
+(def: #export text
+ (-> Text Literal)
+ _.string)
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/reference.lux
new file mode 100644
index 000000000..5dce15a26
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/reference.lux
@@ -0,0 +1,13 @@
+(.module:
+ [library
+ [lux #*
+ [target
+ ["_" php (#+ Expression)]]]]
+ [///
+ [reference (#+ System)]])
+
+(implementation: #export system
+ (System Expression)
+
+ (def: constant _.global)
+ (def: variable _.var))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux
new file mode 100644
index 000000000..231bb4a29
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux
@@ -0,0 +1,610 @@
+(.module:
+ [library
+ [lux (#- Location inc)
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<.>" code]]]
+ [data
+ ["." product]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." row]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number (#+ hex)
+ ["." i64]]]
+ ["@" target
+ ["_" php (#+ Expression Label Constant Var Computation Literal Statement)]]]]
+ ["." /// #_
+ ["#." reference]
+ ["//#" /// #_
+ ["#." synthesis (#+ Synthesis)]
+ ["#." generation]
+ ["//#" ///
+ ["#." phase]
+ [reference
+ [variable (#+ Register)]]
+ [meta
+ [archive (#+ Output Archive)
+ ["." artifact (#+ Registry)]]]]]])
+
+(template [<name> <base>]
+ [(type: #export <name>
+ (<base> [Nat Label] Expression Statement))]
+
+ [Operation /////generation.Operation]
+ [Phase /////generation.Phase]
+ [Handler /////generation.Handler]
+ [Bundle /////generation.Bundle]
+ )
+
+(type: #export (Generator i)
+ (-> Phase Archive i (Operation Expression)))
+
+(type: #export Phase!
+ (-> Phase Archive Synthesis (Operation Statement)))
+
+(type: #export (Generator! i)
+ (-> Phase! Phase Archive i (Operation Statement)))
+
+(def: #export unit
+ (_.string /////synthesis.unit))
+
+(def: (flag value)
+ (-> Bit Literal)
+ (if value
+ ..unit
+ _.null))
+
+(def: (feature name definition)
+ (-> Constant (-> Constant Statement) Statement)
+ (definition name))
+
+(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
+ body)
+ (do {! meta.monad}
+ [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
+ (wrap (list (` (let [(~+ (|> vars
+ (list.zip/2 ids)
+ (list\map (function (_ [id var])
+ (list (code.local_identifier var)
+ (` (_.var (~ (code.text (format "v" (%.nat id)))))))))
+ list.concat))]
+ (~ body)))))))
+
+(def: module_id
+ 0)
+
+(syntax: (runtime: {declaration (<>.or <code>.local_identifier
+ (<code>.form (<>.and <code>.local_identifier
+ (<>.some <code>.local_identifier))))}
+ code)
+ (do meta.monad
+ [runtime_id meta.count]
+ (macro.with_gensyms [g!_]
+ (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id]))
+ runtime_name (` (_.constant (~ (code.text (%.code runtime)))))]
+ (case declaration
+ (#.Left name)
+ (macro.with_gensyms [g!_]
+ (let [g!name (code.local_identifier name)]
+ (wrap (list (` (def: #export (~ g!name)
+ Var
+ (~ runtime_name)))
+
+ (` (def: (~ (code.local_identifier (format "@" name)))
+ Statement
+ (..feature (~ runtime_name)
+ (function ((~ g!_) (~ g!name))
+ (_.define (~ g!name) (~ code))))))))))
+
+ (#.Right [name inputs])
+ (macro.with_gensyms [g!_]
+ (let [g!name (code.local_identifier name)
+ inputsC (list\map code.local_identifier inputs)
+ inputs_typesC (list\map (function.constant (` _.Expression))
+ inputs)]
+ (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
+ (-> (~+ inputs_typesC) Computation)
+ (_.apply/* (list (~+ inputsC)) (~ runtime_name))))
+
+ (` (def: (~ (code.local_identifier (format "@" name)))
+ Statement
+ (..feature (~ runtime_name)
+ (function ((~ g!_) (~ g!_))
+ (..with_vars [(~+ inputsC)]
+ (_.define_function (~ g!_)
+ (list (~+ (list\map (|>> (~) [false] (`)) inputsC)))
+ (~ code))))))))))))))))
+
+(runtime: (io//log! message)
+ ($_ _.then
+ (_.echo message)
+ (_.echo (_.string text.new_line))
+ (_.return ..unit)))
+
+(runtime: (io//throw! message)
+ ($_ _.then
+ (_.throw (_.new (_.constant "Exception") (list message)))
+ (_.return ..unit)))
+
+(def: runtime//io
+ Statement
+ ($_ _.then
+ @io//log!
+ @io//throw!
+ ))
+
+(def: #export tuple_size_field
+ "_lux_size")
+
+(def: tuple_size
+ (_.nth (_.string ..tuple_size_field)))
+
+(def: jphp?
+ (_.=== (_.string "5.6.99") (_.phpversion/0 [])))
+
+(runtime: (array//length array)
+ ## TODO: Get rid of this as soon as JPHP is no longer necessary.
+ (_.if ..jphp?
+ (_.return (..tuple_size array))
+ (_.return (_.count/1 array))))
+
+(runtime: (array//write idx value array)
+ ($_ _.then
+ (_.set! (_.nth idx array) value)
+ (_.return array)))
+
+(def: runtime//array
+ Statement
+ ($_ _.then
+ @array//length
+ @array//write
+ ))
+
+(def: jphp_last_index
+ (|>> ..tuple_size (_.- (_.int +1))))
+
+(def: normal_last_index
+ (|>> _.count/1 (_.- (_.int +1))))
+
+(with_expansions [<recur> (as_is ($_ _.then
+ (_.set! lefts (_.- last_index_right lefts))
+ (_.set! tuple (_.nth last_index_right tuple))))]
+ (runtime: (tuple//make size values)
+ (_.if ..jphp?
+ ($_ _.then
+ (_.set! (..tuple_size values) size)
+ (_.return values))
+ ## https://www.php.net/manual/en/language.operators.assignment.php
+ ## https://www.php.net/manual/en/language.references.php
+ ## https://www.php.net/manual/en/functions.arguments.php
+ ## https://www.php.net/manual/en/language.oop5.references.php
+ ## https://www.php.net/manual/en/class.arrayobject.php
+ (_.return (_.new (_.constant "ArrayObject") (list values)))))
+
+ (runtime: (tuple//left lefts tuple)
+ (with_vars [last_index_right]
+ (<| (_.while (_.bool true))
+ ($_ _.then
+ (_.if ..jphp?
+ (_.set! last_index_right (..jphp_last_index tuple))
+ (_.set! last_index_right (..normal_last_index tuple)))
+ (_.if (_.> lefts last_index_right)
+ ## No need for recursion
+ (_.return (_.nth lefts tuple))
+ ## Needs recursion
+ <recur>)))))
+
+ ## TODO: Get rid of this as soon as JPHP is no longer necessary.
+ (runtime: (tuple//slice offset input)
+ (with_vars [size index output]
+ ($_ _.then
+ (_.set! size (..array//length input))
+ (_.set! index (_.int +0))
+ (_.set! output (_.array/* (list)))
+ (<| (_.while (|> index (_.+ offset) (_.< size)))
+ ($_ _.then
+ (_.set! (_.nth index output) (_.nth (_.+ offset index) input))
+ (_.set! index (_.+ (_.int +1) index))
+ ))
+ (_.return (..tuple//make (_.- offset size) output))
+ )))
+
+ (runtime: (tuple//right lefts tuple)
+ (with_vars [last_index_right right_index]
+ (<| (_.while (_.bool true))
+ ($_ _.then
+ (_.if ..jphp?
+ (_.set! last_index_right (..jphp_last_index tuple))
+ (_.set! last_index_right (..normal_last_index tuple)))
+ (_.set! right_index (_.+ (_.int +1) lefts))
+ (_.cond (list [(_.=== last_index_right right_index)
+ (_.return (_.nth right_index tuple))]
+ [(_.> last_index_right right_index)
+ ## Needs recursion.
+ <recur>])
+ (_.if ..jphp?
+ (_.return (..tuple//make (_.- right_index (..tuple_size tuple))
+ (..tuple//slice right_index tuple)))
+ (_.return (..tuple//make (_.- right_index (_.count/1 tuple))
+ (_.array_slice/2 [(_.do "getArrayCopy" (list) tuple) right_index])))))
+ )))))
+
+(def: #export variant_tag_field "_lux_tag")
+(def: #export variant_flag_field "_lux_flag")
+(def: #export variant_value_field "_lux_value")
+
+(runtime: (sum//make tag last? value)
+ (_.return (_.array/** (list [(_.string ..variant_tag_field) tag]
+ [(_.string ..variant_flag_field) last?]
+ [(_.string ..variant_value_field) value]))))
+
+(def: #export (variant tag last? value)
+ (-> Nat Bit Expression Computation)
+ (sum//make (_.int (.int tag))
+ (..flag last?)
+ value))
+
+(def: #export none
+ Computation
+ (..variant 0 #0 ..unit))
+
+(def: #export some
+ (-> Expression Computation)
+ (..variant 1 #1))
+
+(def: #export left
+ (-> Expression Computation)
+ (..variant 0 #0))
+
+(def: #export right
+ (-> Expression Computation)
+ (..variant 1 #1))
+
+(runtime: (sum//get sum wantsLast wantedTag)
+ (let [no_match! (_.return _.null)
+ sum_tag (_.nth (_.string ..variant_tag_field) sum)
+ ## sum_tag (_.nth (_.int +0) sum)
+ sum_flag (_.nth (_.string ..variant_flag_field) sum)
+ ## sum_flag (_.nth (_.int +1) sum)
+ sum_value (_.nth (_.string ..variant_value_field) sum)
+ ## sum_value (_.nth (_.int +2) sum)
+ is_last? (_.=== ..unit sum_flag)
+ test_recursion! (_.if is_last?
+ ## Must recurse.
+ ($_ _.then
+ (_.set! wantedTag (_.- sum_tag wantedTag))
+ (_.set! sum sum_value))
+ no_match!)]
+ (<| (_.while (_.bool true))
+ (_.cond (list [(_.=== sum_tag wantedTag)
+ (_.if (_.=== wantsLast sum_flag)
+ (_.return sum_value)
+ test_recursion!)]
+
+ [(_.< wantedTag sum_tag)
+ test_recursion!]
+
+ [(_.=== ..unit wantsLast)
+ (_.return (sum//make (_.- wantedTag sum_tag) sum_flag sum_value))])
+ no_match!))))
+
+(def: runtime//adt
+ Statement
+ ($_ _.then
+ @tuple//make
+ @tuple//left
+ @tuple//slice
+ @tuple//right
+ @sum//make
+ @sum//get
+ ))
+
+(runtime: (lux//try op)
+ (with_vars [value]
+ (_.try ($_ _.then
+ (_.set! value (_.apply/1 op [..unit]))
+ (_.return (..right value)))
+ (list (with_vars [error]
+ {#_.class (_.constant "Exception")
+ #_.exception error
+ #_.handler (_.return (..left (_.do "getMessage" (list) error)))})))))
+
+(runtime: (lux//program_args inputs)
+ (with_vars [head tail]
+ ($_ _.then
+ (_.set! tail ..none)
+ (<| (_.for_each (_.array_reverse/1 inputs) head)
+ (_.set! tail (..some (_.array/* (list head tail)))))
+ (_.return tail))))
+
+(def: runtime//lux
+ Statement
+ ($_ _.then
+ @lux//try
+ @lux//program_args
+ ))
+
+(def: #export high
+ (-> (I64 Any) (I64 Any))
+ (i64.right_shift 32))
+
+(def: #export low
+ (-> (I64 Any) (I64 Any))
+ (let [mask (dec (i64.left_shift 32 1))]
+ (|>> (i64.and mask))))
+
+(runtime: (i64//right_shift param subject)
+ (let [## The mask has to be calculated this way instead of in a more straightforward way
+ ## because in some languages, 1<<63 = max_negative_value
+ ## and max_negative_value-1 = max_positive_value.
+ ## And bitwise, max_positive_value works out to the mask that is desired when param = 0.
+ ## However, in PHP, max_negative_value-1 underflows and gets cast into a float.
+ ## And this messes up the computation.
+ ## This slightly more convoluted calculation avoids that problem.
+ mask (|> (_.int +1)
+ (_.bit_shl (_.- param (_.int +63)))
+ (_.- (_.int +1))
+ (_.bit_shl (_.int +1))
+ (_.+ (_.int +1)))]
+ ($_ _.then
+ (_.set! param (_.% (_.int +64) param))
+ (_.if (_.=== (_.int +0) param)
+ (_.return subject)
+ (_.return (|> subject
+ (_.bit_shr param)
+ (_.bit_and mask)))))))
+
+(runtime: (i64//char code)
+ (_.if ..jphp?
+ (_.return (_.chr/1 [code]))
+ (_.return (|> code
+ [(_.string "V")]
+ _.pack/2
+ [(_.string "UTF-32LE") (_.string "UTF-8")]
+ _.iconv/3))))
+
+(runtime: (i64//+ parameter subject)
+ (let [high_16 (..i64//right_shift (_.int +16))
+ low_16 (_.bit_and (_.int (.int (hex "FFFF"))))
+
+ cap_16 low_16
+ hh (..i64//right_shift (_.int +48))
+ hl (|>> (..i64//right_shift (_.int +32)) cap_16)
+ lh (|>> (..i64//right_shift (_.int +16)) cap_16)
+ ll cap_16
+
+ up_16 (_.bit_shl (_.int +16))]
+ (with_vars [l48 l32 l16 l00
+ r48 r32 r16 r00
+ x48 x32 x16 x00]
+ ($_ _.then
+ (_.set! l48 (hh subject))
+ (_.set! l32 (hl subject))
+ (_.set! l16 (lh subject))
+ (_.set! l00 (ll subject))
+
+ (_.set! r48 (hh parameter))
+ (_.set! r32 (hl parameter))
+ (_.set! r16 (lh parameter))
+ (_.set! r00 (ll parameter))
+
+ (_.set! x00 (_.+ l00 r00))
+
+ (_.set! x16 (|> (high_16 x00)
+ (_.+ l16)
+ (_.+ r16)))
+ (_.set! x00 (low_16 x00))
+
+ (_.set! x32 (|> (high_16 x16)
+ (_.+ l32)
+ (_.+ r32)))
+ (_.set! x16 (low_16 x16))
+
+ (_.set! x48 (|> (high_16 x32)
+ (_.+ l48)
+ (_.+ r48)
+ low_16))
+ (_.set! x32 (low_16 x32))
+
+ (let [high32 (_.bit_or (up_16 x48) x32)
+ low32 (_.bit_or (up_16 x16) x00)]
+ (_.return (|> high32
+ (_.bit_shl (_.int +32))
+ (_.bit_or low32))))
+ ))))
+
+(runtime: (i64//negate value)
+ (let [i64//min (_.int (.int (hex "80,00,00,00,00,00,00,00")))]
+ (_.if (_.=== i64//min value)
+ (_.return i64//min)
+ (_.return (..i64//+ (_.int +1) (_.bit_not value))))))
+
+(runtime: (i64//- parameter subject)
+ (_.return (..i64//+ (..i64//negate parameter) subject)))
+
+(runtime: (i64//* parameter subject)
+ (let [high_16 (..i64//right_shift (_.int +16))
+ low_16 (_.bit_and (_.int (.int (hex "FFFF"))))
+
+ cap_16 low_16
+ hh (..i64//right_shift (_.int +48))
+ hl (|>> (..i64//right_shift (_.int +32)) cap_16)
+ lh (|>> (..i64//right_shift (_.int +16)) cap_16)
+ ll cap_16
+
+ up_16 (_.bit_shl (_.int +16))]
+ (with_vars [l48 l32 l16 l00
+ r48 r32 r16 r00
+ x48 x32 x16 x00]
+ ($_ _.then
+ (_.set! l48 (hh subject))
+ (_.set! l32 (hl subject))
+ (_.set! l16 (lh subject))
+ (_.set! l00 (ll subject))
+
+ (_.set! r48 (hh parameter))
+ (_.set! r32 (hl parameter))
+ (_.set! r16 (lh parameter))
+ (_.set! r00 (ll parameter))
+
+ (_.set! x00 (_.* l00 r00))
+ (_.set! x16 (high_16 x00))
+ (_.set! x00 (low_16 x00))
+
+ (_.set! x16 (|> x16 (_.+ (_.* l16 r00))))
+ (_.set! x32 (high_16 x16)) (_.set! x16 (low_16 x16))
+ (_.set! x16 (|> x16 (_.+ (_.* l00 r16))))
+ (_.set! x32 (|> x32 (_.+ (high_16 x16)))) (_.set! x16 (low_16 x16))
+
+ (_.set! x32 (|> x32 (_.+ (_.* l32 r00))))
+ (_.set! x48 (high_16 x32)) (_.set! x32 (low_16 x32))
+ (_.set! x32 (|> x32 (_.+ (_.* l16 r16))))
+ (_.set! x48 (|> x48 (_.+ (high_16 x32)))) (_.set! x32 (low_16 x32))
+ (_.set! x32 (|> x32 (_.+ (_.* l00 r32))))
+ (_.set! x48 (|> x48 (_.+ (high_16 x32)))) (_.set! x32 (low_16 x32))
+
+ (_.set! x48 (|> x48
+ (_.+ (_.* l48 r00))
+ (_.+ (_.* l32 r16))
+ (_.+ (_.* l16 r32))
+ (_.+ (_.* l00 r48))
+ low_16))
+
+ (let [high32 (_.bit_or (up_16 x48) x32)
+ low32 (_.bit_or (up_16 x16) x00)]
+ (_.return (|> high32
+ (_.bit_shl (_.int +32))
+ (_.bit_or low32))))
+ ))))
+
+(def: runtime//i64
+ Statement
+ ($_ _.then
+ @i64//right_shift
+ @i64//char
+ @i64//+
+ @i64//negate
+ @i64//-
+ @i64//*
+ ))
+
+(runtime: (text//size value)
+ (_.if ..jphp?
+ (_.return (_.strlen/1 [value]))
+ (_.return (_.iconv_strlen/1 [value]))))
+
+(runtime: (text//index subject param start)
+ (_.if (_.=== (_.string "") param)
+ (_.return (..some (_.int +0)))
+ (with_vars [idx]
+ (_.if ..jphp?
+ ($_ _.then
+ (_.set! idx (_.strpos/3 [subject param start]))
+ (_.if (_.=== (_.bool false) idx)
+ (_.return ..none)
+ (_.return (..some idx))))
+ ($_ _.then
+ (_.set! idx (_.iconv_strpos/3 [subject param start]))
+ (_.if (_.=== (_.bool false) idx)
+ (_.return ..none)
+ (_.return (..some idx))))))))
+
+(def: (within? top value)
+ (-> Expression Expression Computation)
+ (_.and (|> value (_.>= (_.int +0)))
+ (|> value (_.< top))))
+
+(runtime: (text//clip offset length text)
+ (_.if ..jphp?
+ (_.return (_.substr/3 [text offset length]))
+ (_.return (_.iconv_substr/3 [text offset length]))))
+
+(runtime: (text//char idx text)
+ (_.if (|> idx (within? (text//size text)))
+ (_.if ..jphp?
+ (_.return (_.ord/1 (_.substr/3 [text idx (_.int +1)])))
+ (_.return (|> (_.iconv_substr/3 [text idx (_.int +1)])
+ [(_.string "UTF-8") (_.string "UTF-32LE")]
+ _.iconv/3
+ [(_.string "V")]
+ _.unpack/2
+ (_.nth (_.int +1)))))
+ (_.throw (_.new (_.constant "Exception") (list (_.string "[Lux Error] Cannot get char from text."))))))
+
+(def: runtime//text
+ Statement
+ ($_ _.then
+ @text//size
+ @text//index
+ @text//clip
+ @text//char
+ ))
+
+(runtime: (f64//decode value)
+ (with_vars [output]
+ ($_ _.then
+ (_.set! output (_.floatval/1 value))
+ (_.if (_.=== (_.float +0.0) output)
+ (_.if ($_ _.or
+ (_.=== (_.string "0.0") output)
+ (_.=== (_.string "+0.0") output)
+ (_.=== (_.string "-0.0") output)
+ (_.=== (_.string "0") output)
+ (_.=== (_.string "+0") output)
+ (_.=== (_.string "-0") output))
+ (_.return (..some output))
+ (_.return ..none))
+ (_.return (..some output)))
+ )))
+
+(def: runtime//f64
+ Statement
+ ($_ _.then
+ @f64//decode
+ ))
+
+(def: check_necessary_conditions!
+ Statement
+ (let [i64_support? (_.=== (_.int +8) (_.constant "PHP_INT_SIZE"))
+ i64_error (_.string (format "Cannot run program!" text.new_line
+ "Lux/PHP programs require 64-bit PHP builds!"))]
+ (_.when (_.not i64_support?)
+ (_.throw (_.new (_.constant "Exception") (list i64_error))))))
+
+(def: runtime
+ Statement
+ ($_ _.then
+ check_necessary_conditions!
+ runtime//array
+ runtime//adt
+ runtime//lux
+ runtime//i64
+ runtime//f64
+ runtime//text
+ runtime//io
+ ))
+
+(def: #export generate
+ (Operation [Registry Output])
+ (do ///////phase.monad
+ [_ (/////generation.execute! ..runtime)
+ _ (/////generation.save! ..module_id ..runtime)]
+ (wrap [(|> artifact.empty
+ artifact.resource
+ product.right)
+ (row.row [..module_id
+ (|> ..runtime
+ _.code
+ (\ utf8.codec encode))])])))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/structure.lux
new file mode 100644
index 000000000..8d9334dca
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/structure.lux
@@ -0,0 +1,42 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ [collection
+ ["." list]]]
+ [target
+ ["_" php (#+ Expression)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." primitive]
+ ["///#" //// #_
+ [analysis (#+ Variant Tuple)]
+ ["#." synthesis (#+ Synthesis)]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]]]])
+
+(def: #export (tuple expression archive elemsS+)
+ (Generator (Tuple Synthesis))
+ (case elemsS+
+ #.Nil
+ (///////phase\wrap (//primitive.text /////synthesis.unit))
+
+ (#.Cons singletonS #.Nil)
+ (expression archive singletonS)
+
+ _
+ (let [size (_.int (.int (list.size elemsS+)))]
+ (|> elemsS+
+ (monad.map ///////phase.monad (expression archive))
+ (///////phase\map (|>> _.array/*
+ (//runtime.tuple//make size)))))))
+
+(def: #export (variant expression archive [lefts right? valueS])
+ (Generator (Variant Synthesis))
+ (let [tag (if right?
+ (inc lefts)
+ lefts)]
+ (///////phase\map (//runtime.variant tag right?)
+ (expression archive valueS))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python.lux
new file mode 100644
index 000000000..683a64ffe
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python.lux
@@ -0,0 +1,113 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]]
+ [target
+ ["_" python]]]]
+ ["." / #_
+ [runtime (#+ Phase Phase!)]
+ ["#." primitive]
+ ["#." structure]
+ ["#." reference]
+ ["#." function]
+ ["#." case]
+ ["#." loop]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." extension]
+ ["/#" // #_
+ [analysis (#+)]
+ ["#." synthesis]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]
+ [reference (#+)
+ [variable (#+)]]]]]]])
+
+(def: (statement expression archive synthesis)
+ Phase!
+ (case synthesis
+ (^template [<tag>]
+ [(^ (<tag> value))
+ (//////phase\map _.return (expression archive synthesis))])
+ ([////synthesis.bit]
+ [////synthesis.i64]
+ [////synthesis.f64]
+ [////synthesis.text]
+ [////synthesis.variant]
+ [////synthesis.tuple]
+ [#////synthesis.Reference]
+ [////synthesis.branch/get]
+ [////synthesis.function/apply]
+ [#////synthesis.Extension])
+
+ (^ (////synthesis.branch/case case))
+ (/case.case! false statement expression archive case)
+
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (<generator> statement expression archive value)])
+ ([////synthesis.branch/let /case.let!]
+ [////synthesis.branch/if /case.if!]
+ [////synthesis.loop/scope /loop.scope!]
+ [////synthesis.loop/recur /loop.recur!])
+
+ (^ (////synthesis.function/abstraction abstraction))
+ (//////phase\map _.return (/function.function statement expression archive abstraction))
+ ))
+
+(exception: #export cannot-recur-as-an-expression)
+
+(def: #export (expression archive synthesis)
+ Phase
+ (case synthesis
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (//////phase\wrap (<generator> value))])
+ ([////synthesis.bit /primitive.bit]
+ [////synthesis.i64 /primitive.i64]
+ [////synthesis.f64 /primitive.f64]
+ [////synthesis.text /primitive.text])
+
+ (^ (////synthesis.variant variantS))
+ (/structure.variant expression archive variantS)
+
+ (^ (////synthesis.tuple members))
+ (/structure.tuple expression archive members)
+
+ (#////synthesis.Reference value)
+ (//reference.reference /reference.system archive value)
+
+ (^ (////synthesis.branch/case case))
+ (/case.case ..statement expression archive case)
+
+ (^ (////synthesis.branch/let let))
+ (/case.let expression archive let)
+
+ (^ (////synthesis.branch/if if))
+ (/case.if expression archive if)
+
+ (^ (////synthesis.branch/get get))
+ (/case.get expression archive get)
+
+ (^ (////synthesis.loop/scope scope))
+ (/loop.scope ..statement expression archive scope)
+
+ (^ (////synthesis.loop/recur updates))
+ (//////phase.throw ..cannot-recur-as-an-expression [])
+
+ (^ (////synthesis.function/abstraction abstraction))
+ (/function.function ..statement expression archive abstraction)
+
+ (^ (////synthesis.function/apply application))
+ (/function.apply expression archive application)
+
+ (#////synthesis.Extension extension)
+ (///extension.apply archive expression extension)))
+
+(def: #export generate
+ Phase
+ ..expression)
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/case.lux
new file mode 100644
index 000000000..a4e5e81fc
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/case.lux
@@ -0,0 +1,334 @@
+(.module:
+ [library
+ [lux (#- case let if)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." set]]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]]]
+ [target
+ ["_" python (#+ Expression SVar Statement)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator Phase! Generator!)]
+ ["#." reference]
+ ["#." primitive]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ [synthesis
+ ["." case]]
+ ["/#" // #_
+ ["#." synthesis (#+ Member Synthesis Path)]
+ ["#." generation]
+ ["//#" /// #_
+ [reference
+ ["#." variable (#+ Register)]]
+ ["#." phase ("#\." monad)]
+ [meta
+ [archive (#+ Archive)]]]]]]])
+
+(def: #export (gensym prefix)
+ (-> Text (Operation SVar))
+ (///////phase\map (|>> %.nat (format prefix) _.var)
+ /////generation.next))
+
+(def: #export register
+ (-> Register SVar)
+ (|>> (///reference.local //reference.system) :assume))
+
+(def: #export capture
+ (-> Register SVar)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: #export (let expression archive [valueS register bodyS])
+ (Generator [Synthesis Register Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)
+ bodyO (expression archive bodyS)]
+ ## TODO: Find some way to do 'let' without paying the price of the closure.
+ (wrap (_.apply/* (_.lambda (list (..register register))
+ bodyO)
+ (list valueO)))))
+
+(def: #export (let! statement expression archive [valueS register bodyS])
+ (Generator! [Synthesis Register Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)
+ bodyO (statement expression archive bodyS)]
+ (wrap ($_ _.then
+ (_.set (list (..register register)) valueO)
+ bodyO))))
+
+(def: #export (if expression archive [testS thenS elseS])
+ (Generator [Synthesis Synthesis Synthesis])
+ (do ///////phase.monad
+ [testO (expression archive testS)
+ thenO (expression archive thenS)
+ elseO (expression archive elseS)]
+ (wrap (_.? testO thenO elseO))))
+
+(def: #export (if! statement expression archive [testS thenS elseS])
+ (Generator! [Synthesis Synthesis Synthesis])
+ (do ///////phase.monad
+ [test! (expression archive testS)
+ then! (statement expression archive thenS)
+ else! (statement expression archive elseS)]
+ (wrap (_.if test!
+ then!
+ else!))))
+
+(def: #export (get expression archive [pathP valueS])
+ (Generator [(List Member) Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)]
+ (wrap (list\fold (function (_ side source)
+ (.let [method (.case side
+ (^template [<side> <accessor>]
+ [(<side> lefts)
+ (<accessor> (_.int (.int lefts)))])
+ ([#.Left //runtime.tuple::left]
+ [#.Right //runtime.tuple::right]))]
+ (method source)))
+ valueO
+ (list.reverse pathP)))))
+
+(def: @savepoint (_.var "lux_pm_savepoint"))
+(def: @cursor (_.var "lux_pm_cursor"))
+(def: @temp (_.var "lux_pm_temp"))
+
+(def: (push! value)
+ (-> (Expression Any) (Statement Any))
+ (_.statement (|> @cursor (_.do "append" (list value)))))
+
+(def: peek_and_pop
+ (Expression Any)
+ (|> @cursor (_.do "pop" (list))))
+
+(def: pop!
+ (Statement Any)
+ (_.statement ..peek_and_pop))
+
+(def: peek
+ (Expression Any)
+ (_.nth (_.int -1) @cursor))
+
+(def: save!
+ (Statement Any)
+ (.let [cursor (_.slice_from (_.int +0) @cursor)]
+ (_.statement (|> @savepoint (_.do "append" (list cursor))))))
+
+(def: restore!
+ (Statement Any)
+ (_.set (list @cursor) (|> @savepoint (_.do "pop" (list)))))
+
+(def: fail_pm! _.break)
+
+(def: (multi_pop! pops)
+ (-> Nat (Statement Any))
+ (_.delete (_.slice_from (_.int (i.* -1 (.int pops))) @cursor)))
+
+(template [<name> <flag> <prep>]
+ [(def: (<name> simple? idx)
+ (-> Bit Nat (Statement Any))
+ ($_ _.then
+ (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum::get ..peek <flag>)))
+ (.if simple?
+ (_.when (_.= _.none @temp)
+ fail_pm!)
+ (_.if (_.= _.none @temp)
+ fail_pm!
+ (..push! @temp))
+ )))]
+
+ [left_choice _.none (<|)]
+ [right_choice (_.string "") inc]
+ )
+
+(def: (with_looping in_closure? g!once body!)
+ (-> Bit SVar (Statement Any) (Statement Any))
+ (.if in_closure?
+ (_.while (_.bool true)
+ body!
+ #.None)
+ ($_ _.then
+ (_.set (list g!once) (_.bool true))
+ (_.while g!once
+ ($_ _.then
+ (_.set (list g!once) (_.bool false))
+ body!)
+ (#.Some _.continue)))))
+
+(def: (alternation in_closure? g!once pre! post!)
+ (-> Bit SVar (Statement Any) (Statement Any) (Statement Any))
+ ($_ _.then
+ (..with_looping in_closure? g!once
+ ($_ _.then
+ ..save!
+ pre!))
+ ..restore!
+ post!))
+
+(def: (primitive_pattern_matching recur pathP)
+ (-> (-> Path (Operation (Statement Any)))
+ (-> Path (Operation (Maybe (Statement Any)))))
+ (.case pathP
+ (#/////synthesis.Bit_Fork when thenP elseP)
+ (do {! ///////phase.monad}
+ [then! (recur thenP)
+ else! (.case elseP
+ (#.Some elseP)
+ (recur elseP)
+
+ #.None
+ (wrap ..fail_pm!))]
+ (wrap (#.Some (.if when
+ (_.if ..peek
+ then!
+ else!)
+ (_.if ..peek
+ else!
+ then!)))))
+
+ (^template [<tag> <format>]
+ [(<tag> cons)
+ (do {! ///////phase.monad}
+ [clauses (monad.map ! (function (_ [match then])
+ (\ ! map
+ (|>> [(_.= (|> match <format>)
+ ..peek)])
+ (recur then)))
+ (#.Cons cons))]
+ (wrap (#.Some (_.cond clauses
+ ..fail_pm!))))])
+ ([#/////synthesis.I64_Fork (<| //primitive.i64 .int)]
+ [#/////synthesis.F64_Fork (<| //primitive.f64)]
+ [#/////synthesis.Text_Fork (<| //primitive.text)])
+
+ _
+ (\ ///////phase.monad wrap #.None)))
+
+(def: (pattern_matching' in_closure? statement expression archive)
+ (-> Bit Phase! Phase Archive Path (Operation (Statement Any)))
+ (function (recur pathP)
+ (do {! ///////phase.monad}
+ [?output (primitive_pattern_matching recur pathP)]
+ (.case ?output
+ (#.Some output)
+ (wrap output)
+
+ #.None
+ (.case pathP
+ (#/////synthesis.Then bodyS)
+ (statement expression archive bodyS)
+
+ #/////synthesis.Pop
+ (///////phase\wrap ..pop!)
+
+ (#/////synthesis.Bind register)
+ (///////phase\wrap (_.set (list (..register register)) ..peek))
+
+ (^template [<complex> <simple> <choice>]
+ [(^ (<complex> idx))
+ (///////phase\wrap (<choice> false idx))
+
+ (^ (<simple> idx nextP))
+ (|> nextP
+ recur
+ (///////phase\map (_.then (<choice> true idx))))])
+ ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice]
+ [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice])
+
+ (^ (/////synthesis.member/left 0))
+ (///////phase\wrap (|> ..peek (_.nth (_.int +0)) ..push!))
+
+ (^template [<pm> <getter>]
+ [(^ (<pm> lefts))
+ (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))])
+ ([/////synthesis.member/left //runtime.tuple::left]
+ [/////synthesis.member/right //runtime.tuple::right])
+
+ (^ (/////synthesis.!bind_top register thenP))
+ (do !
+ [then! (recur thenP)]
+ (///////phase\wrap ($_ _.then
+ (_.set (list (..register register)) ..peek_and_pop)
+ then!)))
+
+ (^ (/////synthesis.!multi_pop nextP))
+ (.let [[extra_pops nextP'] (case.count_pops nextP)]
+ (do !
+ [next! (recur nextP')]
+ (///////phase\wrap ($_ _.then
+ (..multi_pop! (n.+ 2 extra_pops))
+ next!))))
+
+ (^ (/////synthesis.path/seq preP postP))
+ (do !
+ [pre! (recur preP)
+ post! (recur postP)]
+ (wrap (_.then pre! post!)))
+
+ (^ (/////synthesis.path/alt preP postP))
+ (do !
+ [pre! (recur preP)
+ post! (recur postP)
+ g!once (..gensym "once")]
+ (wrap (..alternation in_closure? g!once pre! post!)))
+
+ _
+ (undefined))))))
+
+(def: (pattern_matching in_closure? statement expression archive pathP)
+ (-> Bit Phase! Phase Archive Path (Operation (Statement Any)))
+ (do ///////phase.monad
+ [pattern_matching! (pattern_matching' in_closure? statement expression archive pathP)
+ g!once (..gensym "once")]
+ (wrap ($_ _.then
+ (..with_looping in_closure? g!once
+ pattern_matching!)
+ (_.raise (_.Exception/1 (_.string case.pattern_matching_error)))))))
+
+(def: #export dependencies
+ (-> Path (List SVar))
+ (|>> case.storage
+ (get@ #case.dependencies)
+ set.to_list
+ (list\map (function (_ variable)
+ (.case variable
+ (#///////variable.Local register)
+ (..register register)
+
+ (#///////variable.Foreign register)
+ (..capture register))))))
+
+(def: #export (case! in_closure? statement expression archive [valueS pathP])
+ (-> Bit (Generator! [Synthesis Path]))
+ (do ///////phase.monad
+ [stack_init (expression archive valueS)
+ pattern_matching! (pattern_matching in_closure? statement expression archive pathP)]
+ (wrap ($_ _.then
+ (_.set (list @cursor) (_.list (list stack_init)))
+ (_.set (list @savepoint) (_.list (list)))
+ pattern_matching!
+ ))))
+
+(def: #export (case statement expression archive [valueS pathP])
+ (-> Phase! (Generator [Synthesis Path]))
+ (do ///////phase.monad
+ [[[case_module case_artifact] pattern_matching!] (/////generation.with_new_context archive
+ (case! true statement expression archive [valueS pathP]))
+ #let [@case (_.var (///reference.artifact [case_module case_artifact]))
+ @dependencies+ (..dependencies (/////synthesis.path/seq (/////synthesis.path/then valueS)
+ pathP))
+ directive (_.def @case @dependencies+
+ pattern_matching!)]
+ _ (/////generation.execute! directive)
+ _ (/////generation.save! case_artifact directive)]
+ (wrap (_.apply/* @case @dependencies+))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/function.lux
new file mode 100644
index 000000000..ca18fb0ef
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/function.lux
@@ -0,0 +1,112 @@
+(.module:
+ [library
+ [lux (#- function)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [target
+ ["_" python (#+ SVar Expression Statement)]]]]
+ ["." // #_
+ [runtime (#+ Operation Phase Generator Phase! Generator!)]
+ ["#." reference]
+ ["#." case]
+ ["#." loop]
+ ["/#" // #_
+ ["#." reference]
+ ["//#" /// #_
+ [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)]
+ [synthesis (#+ Synthesis)]
+ ["#." generation (#+ Context)]
+ ["//#" /// #_
+ [arity (#+ Arity)]
+ ["#." phase]
+ [reference
+ [variable (#+ Register Variable)]]
+ [meta
+ [archive (#+ Archive)
+ ["." artifact]]]]]]])
+
+(def: #export (apply expression archive [functionS argsS+])
+ (Generator (Application Synthesis))
+ (do {! ///////phase.monad}
+ [functionO (expression archive functionS)
+ argsO+ (monad.map ! (expression archive) argsS+)]
+ (wrap (_.apply/* functionO argsO+))))
+
+(def: #export capture
+ (-> Register SVar)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: (with_closure function_id @function inits function_definition)
+ (-> artifact.ID SVar (List (Expression Any)) (Statement Any) (Operation (Expression Any)))
+ (case inits
+ #.Nil
+ (do ///////phase.monad
+ [_ (/////generation.execute! function_definition)
+ _ (/////generation.save! function_id function_definition)]
+ (wrap @function))
+
+ _
+ (do {! ///////phase.monad}
+ [#let [directive (_.def @function
+ (|> (list.enumeration inits)
+ (list\map (|>> product.left ..capture)))
+ ($_ _.then
+ function_definition
+ (_.return @function)))]
+ _ (/////generation.execute! directive)
+ _ (/////generation.save! function_id directive)]
+ (wrap (_.apply/* @function inits)))))
+
+(def: input
+ (|>> inc //case.register))
+
+(def: #export (function statement expression archive [environment arity bodyS])
+ (-> Phase! (Generator (Abstraction Synthesis)))
+ (do {! ///////phase.monad}
+ [[[function_module function_artifact] body!] (/////generation.with_new_context archive
+ (/////generation.with_anchor 1
+ (statement expression archive bodyS)))
+ environment (monad.map ! (expression archive) environment)
+ #let [@curried (_.var "curried")
+ arityO (|> arity .int _.int)
+ @num_args (_.var "num_args")
+ @self (_.var (///reference.artifact [function_module function_artifact]))
+ apply_poly (.function (_ args func)
+ (_.apply_poly (list) args func))
+ initialize_self! (_.set (list (//case.register 0)) @self)
+ initialize! (list\fold (.function (_ post pre!)
+ ($_ _.then
+ pre!
+ (_.set (list (..input post)) (_.nth (|> post .int _.int) @curried))))
+ initialize_self!
+ (list.indices arity))]]
+ (with_closure function_artifact @self environment
+ (_.def @self (list (_.poly @curried))
+ ($_ _.then
+ (_.set (list @num_args) (_.len/1 @curried))
+ (_.cond (list [(|> @num_args (_.= arityO))
+ (<| (_.then initialize!)
+ //loop.set_scope
+ body!)]
+ [(|> @num_args (_.> arityO))
+ (let [arity_inputs (_.slice (_.int +0) arityO @curried)
+ extra_inputs (_.slice arityO @num_args @curried)]
+ (_.return (|> @self
+ (apply_poly arity_inputs)
+ (apply_poly extra_inputs))))])
+ ## (|> @num_args (_.< arityO))
+ (let [@next (_.var "next")
+ @missing (_.var "missing")]
+ ($_ _.then
+ (_.def @next (list (_.poly @missing))
+ (_.return (|> @self (apply_poly (|> @curried (_.+ @missing))))))
+ (_.return @next)
+ )))
+ )))
+ ))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/loop.lux
new file mode 100644
index 000000000..353c890f9
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/loop.lux
@@ -0,0 +1,122 @@
+(.module:
+ [library
+ [lux (#- Scope)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." set]]]
+ [math
+ [number
+ ["n" nat]]]
+ [target
+ ["_" python (#+ Expression SVar Statement)]]]]
+ ["." // #_
+ [runtime (#+ Operation Phase Generator Phase! Generator!)]
+ ["#." case]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ [synthesis
+ ["." case]]
+ ["/#" // #_
+ ["." synthesis (#+ Scope Synthesis)]
+ ["#." generation]
+ ["//#" /// #_
+ ["#." phase]
+ [reference
+ ["#." variable (#+ Register)]]]]]]])
+
+(def: (setup offset bindings body)
+ (-> Register (List (Expression Any)) (Statement Any) (Statement Any))
+ (|> bindings
+ list.enumeration
+ (list\map (function (_ [register value])
+ (_.set (list (//case.register (n.+ offset register)))
+ value)))
+ list.reverse
+ (list\fold _.then body)))
+
+(def: #export (set_scope body!)
+ (-> (Statement Any) (Statement Any))
+ (_.while (_.bool true)
+ body!
+ #.None))
+
+(def: #export (scope! statement expression archive [start initsS+ bodyS])
+ (Generator! (Scope Synthesis))
+ (case initsS+
+ ## function/false/non-independent loop
+ #.Nil
+ (statement expression archive bodyS)
+
+ ## true loop
+ _
+ (do {! ///////phase.monad}
+ [initsO+ (monad.map ! (expression archive) initsS+)
+ body! (/////generation.with_anchor start
+ (statement expression archive bodyS))]
+ (wrap (<| (..setup start initsO+)
+ ..set_scope
+ body!)))))
+
+(def: #export (scope statement expression archive [start initsS+ bodyS])
+ (-> Phase! (Generator (Scope Synthesis)))
+ (case initsS+
+ ## function/false/non-independent loop
+ #.Nil
+ (expression archive bodyS)
+
+ ## true loop
+ _
+ (do {! ///////phase.monad}
+ [initsO+ (monad.map ! (expression archive) initsS+)
+ [[loop_module loop_artifact] body!] (/////generation.with_new_context archive
+ (/////generation.with_anchor start
+ (statement expression archive bodyS)))
+ #let [@loop (_.var (///reference.artifact [loop_module loop_artifact]))
+ locals (|> initsS+
+ list.enumeration
+ (list\map (|>> product.left (n.+ start) //case.register)))
+ actual_loop (<| (_.def @loop locals)
+ ..set_scope
+ body!)
+ [directive instantiation] (: [(Statement Any) (Expression Any)]
+ (case (|> (synthesis.path/then bodyS)
+ //case.dependencies
+ (set.from_list _.hash)
+ (set.difference (set.from_list _.hash locals))
+ set.to_list)
+ #.Nil
+ [actual_loop
+ @loop]
+
+ foreigns
+ [(_.def @loop foreigns
+ ($_ _.then
+ actual_loop
+ (_.return @loop)
+ ))
+ (_.apply/* @loop foreigns)]))]
+ _ (/////generation.execute! directive)
+ _ (/////generation.save! loop_artifact directive)]
+ (wrap (_.apply/* instantiation initsO+)))))
+
+(def: #export (recur! statement expression archive argsS+)
+ (Generator! (List Synthesis))
+ (do {! ///////phase.monad}
+ [offset /////generation.anchor
+ @temp (//case.gensym "lux_recur_values")
+ argsO+ (monad.map ! (expression archive) argsS+)
+ #let [re_binds (|> argsO+
+ list.enumeration
+ (list\map (function (_ [idx _])
+ (_.nth (_.int (.int idx)) @temp))))]]
+ (wrap ($_ _.then
+ (_.set (list @temp) (_.list argsO+))
+ (..setup offset re_binds
+ _.continue)))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux
new file mode 100644
index 000000000..60175358f
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux
@@ -0,0 +1,18 @@
+(.module:
+ [library
+ [lux (#- i64)
+ [target
+ ["_" python (#+ Expression)]]]]
+ ["." // #_
+ ["#." runtime]])
+
+(template [<type> <name> <implementation>]
+ [(def: #export <name>
+ (-> <type> (Expression Any))
+ <implementation>)]
+
+ [Bit bit _.bool]
+ [(I64 Any) i64 (|>> .int _.int //runtime.i64::64)]
+ [Frac f64 _.float]
+ [Text text _.unicode]
+ )
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/reference.lux
new file mode 100644
index 000000000..eeb4604a3
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/reference.lux
@@ -0,0 +1,13 @@
+(.module:
+ [library
+ [lux #*
+ [target
+ ["_" python (#+ Expression)]]]]
+ [///
+ [reference (#+ System)]])
+
+(implementation: #export system
+ (System (Expression Any))
+
+ (def: constant _.var)
+ (def: variable _.var))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux
new file mode 100644
index 000000000..1b7c4310c
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux
@@ -0,0 +1,456 @@
+(.module:
+ [library
+ [lux (#- inc)
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<.>" code]]]
+ [data
+ ["." product]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." row]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number (#+ hex)
+ ["f" frac]
+ ["." i64]]]
+ ["@" target
+ ["_" python (#+ Expression SVar Computation Literal Statement)]]]]
+ ["." /// #_
+ ["#." reference]
+ ["//#" /// #_
+ ["$" version]
+ ["#." synthesis (#+ Synthesis)]
+ ["#." generation]
+ ["//#" ///
+ ["#." phase]
+ [reference
+ [variable (#+ Register)]]
+ [meta
+ [archive (#+ Output Archive)
+ ["." artifact (#+ Registry)]]]]]])
+
+(template [<name> <base>]
+ [(type: #export <name>
+ (<base> Register (Expression Any) (Statement Any)))]
+
+ [Operation /////generation.Operation]
+ [Phase /////generation.Phase]
+ [Handler /////generation.Handler]
+ [Bundle /////generation.Bundle]
+ )
+
+(type: #export Phase!
+ (-> Phase Archive Synthesis (Operation (Statement Any))))
+
+(type: #export (Generator! i)
+ (-> Phase! Phase Archive i (Operation (Statement Any))))
+
+(type: #export (Generator i)
+ (-> Phase Archive i (Operation (Expression Any))))
+
+(def: prefix
+ "LuxRuntime")
+
+(def: #export
+ unit
+ (_.unicode /////synthesis.unit))
+
+(def: (flag value)
+ (-> Bit Literal)
+ (if value
+ ..unit
+ _.none))
+
+(def: (variant' tag last? value)
+ (-> (Expression Any) (Expression Any) (Expression Any) Literal)
+ (_.tuple (list tag last? value)))
+
+(def: #export (variant tag last? value)
+ (-> Nat Bit (Expression Any) Literal)
+ (variant' (_.int (.int tag))
+ (flag last?)
+ value))
+
+(def: #export none
+ Literal
+ (..variant 0 #0 unit))
+
+(def: #export some
+ (-> (Expression Any) Literal)
+ (..variant 1 #1))
+
+(def: #export left
+ (-> (Expression Any) Literal)
+ (..variant 0 #0))
+
+(def: #export right
+ (-> (Expression Any) Literal)
+ (..variant 1 #1))
+
+(def: (runtime_name name)
+ (-> Text SVar)
+ (let [identifier (format ..prefix
+ "_" (%.nat $.version)
+ "_" (%.nat (text\hash name)))]
+ (_.var identifier)))
+
+(def: (feature name definition)
+ (-> SVar (-> SVar (Statement Any)) (Statement Any))
+ (definition name))
+
+(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
+ body)
+ (do {! meta.monad}
+ [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
+ (wrap (list (` (let [(~+ (|> vars
+ (list.zip/2 ids)
+ (list\map (function (_ [id var])
+ (list (code.local_identifier var)
+ (` (_.var (~ (code.text (format "v" (%.nat id)))))))))
+ list.concat))]
+ (~ body)))))))
+
+(syntax: (runtime: {declaration (<>.or <code>.local_identifier
+ (<code>.form (<>.and <code>.local_identifier
+ (<>.some <code>.local_identifier))))}
+ code)
+ (case declaration
+ (#.Left name)
+ (macro.with_gensyms [g!_]
+ (let [nameC (code.local_identifier name)
+ code_nameC (code.local_identifier (format "@" name))
+ runtime_nameC (` (runtime_name (~ (code.text name))))]
+ (wrap (list (` (def: #export (~ nameC) SVar (~ runtime_nameC)))
+ (` (def: (~ code_nameC)
+ (Statement Any)
+ (..feature (~ runtime_nameC)
+ (function ((~ g!_) (~ g!_))
+ (_.set (list (~ g!_)) (~ code))))))))))
+
+ (#.Right [name inputs])
+ (macro.with_gensyms [g!_]
+ (let [nameC (code.local_identifier name)
+ code_nameC (code.local_identifier (format "@" name))
+ runtime_nameC (` (runtime_name (~ (code.text name))))
+ inputsC (list\map code.local_identifier inputs)
+ inputs_typesC (list\map (function.constant (` (_.Expression Any)))
+ inputs)]
+ (wrap (list (` (def: #export ((~ nameC) (~+ inputsC))
+ (-> (~+ inputs_typesC) (Computation Any))
+ (_.apply/* (~ runtime_nameC) (list (~+ inputsC)))))
+ (` (def: (~ code_nameC)
+ (Statement Any)
+ (..feature (~ runtime_nameC)
+ (function ((~ g!_) (~ g!_))
+ (..with_vars [(~+ inputsC)]
+ (_.def (~ g!_) (list (~+ inputsC))
+ (~ code)))))))))))))
+
+(runtime: (lux::try op)
+ (with_vars [exception]
+ (_.try (_.return (..right (_.apply/* op (list ..unit))))
+ (list [(list (_.var "Exception")) exception
+ (_.return (..left (_.str/1 exception)))]))))
+
+(runtime: (lux::program_args program_args)
+ (with_vars [inputs value]
+ ($_ _.then
+ (_.set (list inputs) ..none)
+ (<| (_.for_in value (_.apply/* (_.var "reversed") (list program_args)))
+ (_.set (list inputs)
+ (..some (_.list (list value inputs)))))
+ (_.return inputs))))
+
+(runtime: (lux::exec code globals)
+ ($_ _.then
+ (_.exec code (#.Some globals))
+ (_.return ..unit)))
+
+(def: runtime::lux
+ (Statement Any)
+ ($_ _.then
+ @lux::try
+ @lux::program_args
+ @lux::exec
+ ))
+
+(runtime: (io::log! message)
+ ($_ _.then
+ (_.print message)
+ (_.return ..unit)))
+
+(runtime: (io::throw! message)
+ (_.raise (_.Exception/1 message)))
+
+(def: runtime::io
+ (Statement Any)
+ ($_ _.then
+ @io::log!
+ @io::throw!
+ ))
+
+(def: last_index
+ (|>> _.len/1 (_.- (_.int +1))))
+
+(with_expansions [<recur> (as_is ($_ _.then
+ (_.set (list lefts) (_.- last_index_right lefts))
+ (_.set (list tuple) (_.nth last_index_right tuple))))]
+ (runtime: (tuple::left lefts tuple)
+ (with_vars [last_index_right]
+ (_.while (_.bool true)
+ ($_ _.then
+ (_.set (list last_index_right) (..last_index tuple))
+ (_.if (_.> lefts last_index_right)
+ ## No need for recursion
+ (_.return (_.nth lefts tuple))
+ ## Needs recursion
+ <recur>))
+ #.None)))
+
+ (runtime: (tuple::right lefts tuple)
+ (with_vars [last_index_right right_index]
+ (_.while (_.bool true)
+ ($_ _.then
+ (_.set (list last_index_right) (..last_index tuple))
+ (_.set (list right_index) (_.+ (_.int +1) lefts))
+ (_.cond (list [(_.= last_index_right right_index)
+ (_.return (_.nth right_index tuple))]
+ [(_.> last_index_right right_index)
+ ## Needs recursion.
+ <recur>])
+ (_.return (_.slice_from right_index tuple))))
+ #.None))))
+
+(runtime: (sum::get sum wantsLast wantedTag)
+ (let [no_match! (_.return _.none)
+ sum_tag (_.nth (_.int +0) sum)
+ sum_flag (_.nth (_.int +1) sum)
+ sum_value (_.nth (_.int +2) sum)
+ is_last? (_.= ..unit sum_flag)
+ test_recursion! (_.if is_last?
+ ## Must recurse.
+ ($_ _.then
+ (_.set (list wantedTag) (_.- sum_tag wantedTag))
+ (_.set (list sum) sum_value))
+ no_match!)]
+ (_.while (_.bool true)
+ (_.cond (list [(_.= wantedTag sum_tag)
+ (_.if (_.= wantsLast sum_flag)
+ (_.return sum_value)
+ test_recursion!)]
+
+ [(_.< wantedTag sum_tag)
+ test_recursion!]
+
+ [(_.= ..unit wantsLast)
+ (_.return (variant' (_.- wantedTag sum_tag) sum_flag sum_value))])
+
+ no_match!)
+ #.None)))
+
+(def: runtime::adt
+ (Statement Any)
+ ($_ _.then
+ @tuple::left
+ @tuple::right
+ @sum::get
+ ))
+
+(def: i64::+limit (_.manual "+0x7FFFFFFFFFFFFFFF"))
+(def: i64::-limit (_.manual "-0x8000000000000000"))
+(def: i64::+iteration (_.manual "+0x10000000000000000"))
+(def: i64::-iteration (_.manual "-0x10000000000000000"))
+(def: i64::+cap (_.manual "+0x8000000000000000"))
+(def: i64::-cap (_.manual "-0x8000000000000001"))
+
+(runtime: (i64::64 input)
+ (with_vars [temp]
+ (`` (<| (~~ (template [<scenario> <iteration> <cap> <entrance>]
+ [(_.if (|> input <scenario>)
+ ($_ _.then
+ (_.set (list temp) (_.% <iteration> input))
+ (_.return (_.? (|> temp <scenario>)
+ (|> temp (_.- <cap>) (_.+ <entrance>))
+ temp))))]
+
+ [(_.> ..i64::+limit) ..i64::+iteration ..i64::+cap ..i64::-limit]
+ [(_.< ..i64::-limit) ..i64::-iteration ..i64::-cap ..i64::+limit]
+ ))
+ (_.return (for {@.python input}
+ ## This +- is only necessary to guarantee that values within the limits are always longs in Python 2
+ (|> input (_.+ ..i64::+limit) (_.- ..i64::+limit))))))))
+
+(def: as_nat
+ (_.% ..i64::+iteration))
+
+(runtime: (i64::left_shift param subject)
+ (_.return (|> subject
+ (_.bit_shl (_.% (_.int +64) param))
+ ..i64::64)))
+
+(runtime: (i64::right_shift param subject)
+ ($_ _.then
+ (_.set (list param) (_.% (_.int +64) param))
+ (_.return (_.? (_.= (_.int +0) param)
+ subject
+ (|> subject
+ ..as_nat
+ (_.bit_shr param))))))
+
+(runtime: (i64::division param subject)
+ (with_vars [floored]
+ ($_ _.then
+ (_.set (list floored) (_.// param subject))
+ (_.return (let [potentially_floored? (_.< (_.int +0) floored)
+ inexact? (|> subject
+ (_.% param)
+ (_.= (_.int +0))
+ _.not)]
+ (_.? (_.and potentially_floored?
+ inexact?)
+ (_.+ (_.int +1) floored)
+ floored))))))
+
+(runtime: (i64::remainder param subject)
+ (_.return (_.- (|> subject (..i64::division param) (_.* param))
+ subject)))
+
+(template [<runtime> <host>]
+ [(runtime: (<runtime> left right)
+ (_.return (..i64::64 (<host> (..as_nat left) (..as_nat right)))))]
+
+ [i64::and _.bit_and]
+ [i64::or _.bit_or]
+ [i64::xor _.bit_xor]
+ )
+
+(def: python_version
+ (Expression Any)
+ (|> (_.__import__/1 (_.unicode "sys"))
+ (_.the "version_info")
+ (_.the "major")))
+
+(runtime: (i64::char value)
+ (_.return (_.? (_.= (_.int +3) ..python_version)
+ (_.chr/1 value)
+ (_.unichr/1 value))))
+
+(def: runtime::i64
+ (Statement Any)
+ ($_ _.then
+ @i64::64
+ @i64::left_shift
+ @i64::right_shift
+ @i64::division
+ @i64::remainder
+ @i64::and
+ @i64::or
+ @i64::xor
+ @i64::char
+ ))
+
+(runtime: (f64::/ parameter subject)
+ (_.return (_.? (_.= (_.float +0.0) parameter)
+ (<| (_.? (_.> (_.float +0.0) subject)
+ (_.float f.positive_infinity))
+ (_.? (_.< (_.float +0.0) subject)
+ (_.float f.negative_infinity))
+ (_.float f.not_a_number))
+ (_./ parameter subject))))
+
+(runtime: (f64::decode input)
+ (with_vars [ex]
+ (_.try
+ (_.return (..some (_.float/1 input)))
+ (list [(list (_.var "Exception")) ex
+ (_.return ..none)]))))
+
+(def: runtime::f64
+ (Statement Any)
+ ($_ _.then
+ @f64::/
+ @f64::decode
+ ))
+
+(runtime: (text::index start param subject)
+ (with_vars [idx]
+ ($_ _.then
+ (_.set (list idx) (|> subject (_.do "find" (list param start))))
+ (_.return (_.? (_.= (_.int -1) idx)
+ ..none
+ (..some (..i64::64 idx)))))))
+
+(def: inc
+ (|>> (_.+ (_.int +1))))
+
+(def: (within? top value)
+ (-> (Expression Any) (Expression Any) (Computation Any))
+ (_.and (|> value (_.>= (_.int +0)))
+ (|> value (_.< top))))
+
+(runtime: (text::clip @offset @length @text)
+ (_.return (|> @text (_.slice @offset (_.+ @offset @length)))))
+
+(runtime: (text::char idx text)
+ (_.if (|> idx (within? (_.len/1 text)))
+ (_.return (|> text (_.slice idx (..inc idx)) _.ord/1 ..i64::64))
+ (_.raise (_.Exception/1 (_.unicode "[Lux Error] Cannot get char from text.")))))
+
+(def: runtime::text
+ (Statement Any)
+ ($_ _.then
+ @text::index
+ @text::clip
+ @text::char
+ ))
+
+(runtime: (array::write idx value array)
+ ($_ _.then
+ (_.set (list (_.nth idx array)) value)
+ (_.return array)))
+
+(def: runtime::array
+ (Statement Any)
+ ($_ _.then
+ @array::write
+ ))
+
+(def: runtime
+ (Statement Any)
+ ($_ _.then
+ runtime::lux
+ runtime::io
+ runtime::adt
+ runtime::i64
+ runtime::f64
+ runtime::text
+ runtime::array
+ ))
+
+(def: module_id
+ 0)
+
+(def: #export generate
+ (Operation [Registry Output])
+ (/////generation.with_buffer
+ (do ///////phase.monad
+ [_ (/////generation.execute! ..runtime)
+ _ (/////generation.save! ..module_id ..runtime)]
+ (wrap [(|> artifact.empty
+ artifact.resource
+ product.right)
+ (row.row [..module_id
+ (|> ..runtime
+ _.code
+ (\ utf8.codec encode))])]))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/structure.lux
new file mode 100644
index 000000000..342e180d0
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/structure.lux
@@ -0,0 +1,37 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [target
+ ["_" python (#+ Expression)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." primitive]
+ ["///#" //// #_
+ [analysis (#+ Variant Tuple)]
+ ["#." synthesis (#+ Synthesis)]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]]]])
+
+(def: #export (tuple generate archive elemsS+)
+ (Generator (Tuple Synthesis))
+ (case elemsS+
+ #.Nil
+ (///////phase\wrap (//primitive.text /////synthesis.unit))
+
+ (#.Cons singletonS #.Nil)
+ (generate archive singletonS)
+
+ _
+ (|> elemsS+
+ (monad.map ///////phase.monad (generate archive))
+ (///////phase\map _.list))))
+
+(def: #export (variant generate archive [lefts right? valueS])
+ (Generator (Variant Synthesis))
+ (let [tag (if right?
+ (inc lefts)
+ lefts)]
+ (///////phase\map (//runtime.variant tag right?)
+ (generate archive valueS))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r.lux
new file mode 100644
index 000000000..d3636709a
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r.lux
@@ -0,0 +1,59 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [target
+ ["_" r]]]]
+ ["." / #_
+ [runtime (#+ Phase)]
+ ["#." primitive]
+ ["#." structure]
+ ["#." reference]
+ ["#." case]
+ ["#." loop]
+ ["#." function]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." extension]
+ ["/#" // #_
+ [analysis (#+)]
+ ["#." synthesis]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]
+ [reference (#+)
+ [variable (#+)]]]]]]])
+
+(def: #export (generate archive synthesis)
+ Phase
+ (case synthesis
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (//////phase\wrap (<generator> value))])
+ ([////synthesis.bit /primitive.bit]
+ [////synthesis.i64 /primitive.i64]
+ [////synthesis.f64 /primitive.f64]
+ [////synthesis.text /primitive.text])
+
+ (#////synthesis.Reference value)
+ (//reference.reference /reference.system archive value)
+
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (<generator> generate archive value)])
+ ([////synthesis.variant /structure.variant]
+ [////synthesis.tuple /structure.tuple]
+ [////synthesis.branch/let /case.let]
+ [////synthesis.branch/if /case.if]
+ [////synthesis.branch/get /case.get]
+ [////synthesis.function/apply /function.apply]
+
+ [////synthesis.branch/case /case.case]
+ [////synthesis.loop/scope /loop.scope]
+ [////synthesis.loop/recur /loop.recur]
+ [////synthesis.function/abstraction /function.function])
+
+ (#////synthesis.Extension extension)
+ (///extension.apply archive generate extension)
+ ))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/case.lux
new file mode 100644
index 000000000..912b7aff7
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/case.lux
@@ -0,0 +1,240 @@
+(.module:
+ [library
+ [lux (#- case let if)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." set]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["i" int]]]
+ [target
+ ["_" r (#+ Expression SVar)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." reference]
+ ["#." primitive]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." synthesis #_
+ ["#/." case]]
+ ["/#" // #_
+ ["#." synthesis (#+ Member Synthesis Path)]
+ ["#." generation]
+ ["//#" /// #_
+ [reference
+ ["#." variable (#+ Register)]]
+ ["#." phase ("#\." monad)]
+ [meta
+ [archive (#+ Archive)]]]]]]])
+
+(def: #export register
+ (-> Register SVar)
+ (|>> (///reference.local //reference.system) :assume))
+
+(def: #export capture
+ (-> Register SVar)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: #export (let expression archive [valueS register bodyS])
+ (Generator [Synthesis Register Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)
+ bodyO (expression archive bodyS)]
+ (wrap (_.block
+ ($_ _.then
+ (_.set! (..register register) valueO)
+ bodyO)))))
+
+(def: #export (if expression archive [testS thenS elseS])
+ (Generator [Synthesis Synthesis Synthesis])
+ (do ///////phase.monad
+ [testO (expression archive testS)
+ thenO (expression archive thenS)
+ elseO (expression archive elseS)]
+ (wrap (_.if testO thenO elseO))))
+
+(def: #export (get expression archive [pathP valueS])
+ (Generator [(List Member) Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)]
+ (wrap (list\fold (function (_ side source)
+ (.let [method (.case side
+ (^template [<side> <accessor>]
+ [(<side> lefts)
+ (<accessor> (_.int (.int lefts)))])
+ ([#.Left //runtime.tuple::left]
+ [#.Right //runtime.tuple::right]))]
+ (method source)))
+ valueO
+ (list.reverse pathP)))))
+
+(def: $savepoint (_.var "lux_pm_cursor_savepoint"))
+(def: $cursor (_.var "lux_pm_cursor"))
+(def: $temp (_.var "lux_pm_temp"))
+(def: $alt_error (_.var "alt_error"))
+
+(def: top
+ _.length)
+
+(def: next
+ (|>> _.length (_.+ (_.int +1))))
+
+(def: (push! value var)
+ (-> Expression SVar Expression)
+ (_.set_nth! (next var) value var))
+
+(def: (pop! var)
+ (-> SVar Expression)
+ (_.set_nth! (top var) _.null var))
+
+(def: (push_cursor! value)
+ (-> Expression Expression)
+ (push! value $cursor))
+
+(def: save_cursor!
+ Expression
+ (push! (_.slice (_.float +1.0) (_.length $cursor) $cursor)
+ $savepoint))
+
+(def: restore_cursor!
+ Expression
+ (_.set! $cursor (_.nth (top $savepoint) $savepoint)))
+
+(def: peek
+ Expression
+ (|> $cursor (_.nth (top $cursor))))
+
+(def: pop_cursor!
+ Expression
+ (pop! $cursor))
+
+(def: error
+ (_.string (template.with_locals [error]
+ (template.text [error]))))
+
+(def: fail!
+ (_.stop ..error))
+
+(def: (catch handler)
+ (-> Expression Expression)
+ (_.function (list $alt_error)
+ (_.if (|> $alt_error (_.= ..error))
+ handler
+ (_.stop $alt_error))))
+
+(def: (pattern_matching' expression archive)
+ (Generator Path)
+ (function (recur pathP)
+ (.case pathP
+ (#/////synthesis.Then bodyS)
+ (expression archive bodyS)
+
+ #/////synthesis.Pop
+ (///////phase\wrap ..pop_cursor!)
+
+ (#/////synthesis.Bind register)
+ (///////phase\wrap (_.set! (..register register) ..peek))
+
+ (#/////synthesis.Bit_Fork when thenP elseP)
+ (do {! ///////phase.monad}
+ [then! (recur thenP)
+ else! (.case elseP
+ (#.Some elseP)
+ (recur elseP)
+
+ #.None
+ (wrap ..fail!))]
+ (wrap (.if when
+ (_.if ..peek
+ then!
+ else!)
+ (_.if ..peek
+ else!
+ then!))))
+
+ (^template [<tag> <format> <=>]
+ [(<tag> cons)
+ (do {! ///////phase.monad}
+ [clauses (monad.map ! (function (_ [match then])
+ (do !
+ [then! (recur then)]
+ (wrap [(<=> (|> match <format>)
+ ..peek)
+ then!])))
+ (#.Cons cons))]
+ (wrap (list\fold (function (_ [when then] else)
+ (_.if when then else))
+ ..fail!
+ clauses)))])
+ ([#/////synthesis.I64_Fork //primitive.i64 //runtime.i64::=]
+ [#/////synthesis.F64_Fork //primitive.f64 _.=]
+ [#/////synthesis.Text_Fork //primitive.text _.=])
+
+ (^template [<pm> <flag> <prep>]
+ [(^ (<pm> idx))
+ (///////phase\wrap ($_ _.then
+ (_.set! $temp (|> idx <prep> .int _.int (//runtime.sum::get ..peek (//runtime.flag <flag>))))
+ (_.if (_.= _.null $temp)
+ ..fail!
+ (..push_cursor! $temp))))])
+ ([/////synthesis.side/left false (<|)]
+ [/////synthesis.side/right true inc])
+
+ (^ (/////synthesis.member/left 0))
+ (///////phase\wrap (_.nth (_.int +1) ..peek))
+
+ (^template [<pm> <getter>]
+ [(^ (<pm> lefts))
+ (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push_cursor!))])
+ ([/////synthesis.member/left //runtime.tuple::left]
+ [/////synthesis.member/right //runtime.tuple::right])
+
+ (^ (/////synthesis.path/seq leftP rightP))
+ (do ///////phase.monad
+ [leftO (recur leftP)
+ rightO (recur rightP)]
+ (wrap ($_ _.then
+ leftO
+ rightO)))
+
+ (^ (/////synthesis.path/alt leftP rightP))
+ (do {! ///////phase.monad}
+ [leftO (recur leftP)
+ rightO (recur rightP)]
+ (wrap (_.try ($_ _.then
+ ..save_cursor!
+ leftO)
+ #.None
+ (#.Some (..catch ($_ _.then
+ ..restore_cursor!
+ rightO)))
+ #.None)))
+ )))
+
+(def: (pattern_matching expression archive pathP)
+ (Generator Path)
+ (do ///////phase.monad
+ [pattern_matching! (pattern_matching' expression archive pathP)]
+ (wrap (_.try pattern_matching!
+ #.None
+ (#.Some (..catch (_.stop (_.string "Invalid expression for pattern-matching."))))
+ #.None))))
+
+(def: #export (case expression archive [valueS pathP])
+ (Generator [Synthesis Path])
+ (do {! ///////phase.monad}
+ [valueO (expression archive valueS)]
+ (<| (\ ! map (|>> ($_ _.then
+ (_.set! $cursor (_.list (list valueO)))
+ (_.set! $savepoint (_.list (list))))
+ _.block))
+ (pattern_matching expression archive pathP))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/function.lux
new file mode 100644
index 000000000..f30e18def
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/function.lux
@@ -0,0 +1,117 @@
+(.module:
+ [library
+ [lux (#- function)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ pipe]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [target
+ ["_" r (#+ Expression SVar)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." reference]
+ ["#." case]
+ ["/#" // #_
+ ["#." reference]
+ ["//#" /// #_
+ [analysis (#+ Variant Tuple Abstraction Application Analysis)]
+ [synthesis (#+ Synthesis)]
+ ["#." generation (#+ Context)]
+ ["//#" /// #_
+ [arity (#+ Arity)]
+ ["#." phase ("#\." monad)]
+ [reference
+ [variable (#+ Register Variable)]]
+ [meta
+ [archive
+ ["." artifact]]]]]]])
+
+(def: #export (apply expression archive [functionS argsS+])
+ (Generator (Application Synthesis))
+ (do {! ///////phase.monad}
+ [functionO (expression archive functionS)
+ argsO+ (monad.map ! (expression archive) argsS+)]
+ (wrap (_.apply argsO+ functionO))))
+
+(def: (with_closure function_id $function inits function_definition)
+ (-> artifact.ID SVar (List Expression) Expression (Operation Expression))
+ (case inits
+ #.Nil
+ (do ///////phase.monad
+ [_ (/////generation.execute! function_definition)
+ _ (/////generation.save! (%.nat function_id)
+ function_definition)]
+ (wrap $function))
+
+ _
+ (do ///////phase.monad
+ [#let [closure_definition (_.set! $function
+ (_.function (|> inits
+ list.size
+ list.indices
+ (list\map //case.capture))
+ ($_ _.then
+ function_definition
+ $function)))]
+ _ (/////generation.execute! closure_definition)
+ _ (/////generation.save! (%.nat function_id) closure_definition)]
+ (wrap (_.apply inits $function)))))
+
+(def: $curried (_.var "curried"))
+(def: $missing (_.var "missing"))
+
+(def: (input_declaration register)
+ (-> Register Expression)
+ (_.set! (|> register inc //case.register)
+ (|> $curried (_.nth (|> register inc .int _.int)))))
+
+(def: #export (function expression archive [environment arity bodyS])
+ (Generator (Abstraction Synthesis))
+ (do {! ///////phase.monad}
+ [[[function_module function_artifact] bodyO] (/////generation.with_new_context archive
+ (do !
+ [$self (\ ! map (|>> ///reference.artifact _.var)
+ (/////generation.context archive))]
+ (/////generation.with_anchor $self
+ (expression archive bodyS))))
+ closureO+ (monad.map ! (expression archive) environment)
+ #let [arityO (|> arity .int _.int)
+ $num_args (_.var "num_args")
+ $self (_.var (///reference.artifact [function_module function_artifact]))
+ apply_poly (.function (_ args func)
+ (_.apply (list func args) (_.var "do.call")))]]
+ (with_closure function_artifact $self closureO+
+ (_.set! $self (_.function (list _.var_args)
+ ($_ _.then
+ (_.set! $curried (_.list (list _.var_args)))
+ (_.set! $num_args (_.length $curried))
+ (_.cond (list [(|> $num_args (_.= arityO))
+ ($_ _.then
+ (_.set! (//case.register 0) $self)
+ (|> arity
+ list.indices
+ (list\map input_declaration)
+ (list\fold _.then bodyO)))]
+ [(|> $num_args (_.> arityO))
+ (let [arity_args (_.slice (_.int +1) arityO $curried)
+ output_func_args (_.slice (|> arityO (_.+ (_.int +1)))
+ $num_args
+ $curried)]
+ (|> $self
+ (apply_poly arity_args)
+ (apply_poly output_func_args)))])
+ ## (|> $num_args (_.< arityO))
+ (let [$missing (_.var "missing")]
+ (_.function (list _.var_args)
+ ($_ _.then
+ (_.set! $missing (_.list (list _.var_args)))
+ (|> $self
+ (apply_poly (_.apply (list $curried $missing)
+ (_.var "append"))))))))))))
+ ))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/loop.lux
new file mode 100644
index 000000000..f4887aaaa
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/loop.lux
@@ -0,0 +1,65 @@
+(.module:
+ [library
+ [lux (#- Scope)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." set (#+ Set)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [target
+ ["_" r]]]]
+ ["." // #_
+ [runtime (#+ Operation Phase Generator)]
+ ["#." case]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ [synthesis
+ ["." case]]
+ ["/#" // #_
+ ["."synthesis (#+ Scope Synthesis)]
+ ["#." generation]
+ ["//#" /// #_
+ ["#." phase]
+ [meta
+ [archive (#+ Archive)]]
+ [reference
+ [variable (#+ Register)]]]]]]])
+
+(def: #export (scope expression archive [offset initsS+ bodyS])
+ (Generator (Scope Synthesis))
+ (case initsS+
+ ## function/false/non-independent loop
+ #.Nil
+ (expression archive bodyS)
+
+ ## true loop
+ _
+ (do {! ///////phase.monad}
+ [$scope (\ ! map _.var (/////generation.gensym "loop_scope"))
+ initsO+ (monad.map ! (expression archive) initsS+)
+ bodyO (/////generation.with_anchor $scope
+ (expression archive bodyS))]
+ (wrap (_.block
+ ($_ _.then
+ (_.set! $scope
+ (_.function (|> initsS+
+ list.size
+ list.indices
+ (list\map (|>> (n.+ offset) //case.register)))
+ bodyO))
+ (_.apply initsO+ $scope)))))))
+
+(def: #export (recur expression archive argsS+)
+ (Generator (List Synthesis))
+ (do {! ///////phase.monad}
+ [$scope /////generation.anchor
+ argsO+ (monad.map ! (expression archive) argsS+)]
+ (wrap (_.apply argsO+ $scope))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux
new file mode 100644
index 000000000..9b7f40e86
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux
@@ -0,0 +1,18 @@
+(.module:
+ [library
+ [lux (#- i64)
+ [target
+ ["_" r (#+ Expression)]]]]
+ ["." // #_
+ ["#." runtime]])
+
+(template [<name> <type> <code>]
+ [(def: #export <name>
+ (-> <type> Expression)
+ <code>)]
+
+ [bit Bit _.bool]
+ [i64 (I64 Any) (|>> .int //runtime.i64)]
+ [f64 Frac _.float]
+ [text Text _.string]
+ )
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux
new file mode 100644
index 000000000..4917eb90f
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux
@@ -0,0 +1,340 @@
+(.module:
+ lux
+ (lux (control [library
+ [monad #+ do]]
+ ["ex" exception #+ exception:]
+ ["p" parser])
+ (data ["e" error]
+ [text]
+ text/format
+ [number]
+ (coll [list "list/" Functor<List>]
+ (dictionary ["dict" unordered #+ Dict])))
+ [macro #+ with-gensyms]
+ (macro [code]
+ ["s" syntax #+ syntax:])
+ [host])
+ (luxc ["&" lang]
+ (lang ["la" analysis]
+ ["ls" synthesis]
+ (host [r #+ Expression])))
+ [///]
+ (/// [".T" runtime]
+ [".T" case]
+ [".T" function]
+ [".T" loop]))
+
+## [Types]
+(type: #export Translator
+ (-> ls.Synthesis (Meta Expression)))
+
+(type: #export Proc
+ (-> Translator (List ls.Synthesis) (Meta Expression)))
+
+(type: #export Bundle
+ (Dict Text Proc))
+
+(syntax: (Vector {size s.nat} elemT)
+ (wrap (list (` [(~+ (list.repeat size elemT))]))))
+
+(type: #export Nullary (-> (Vector +0 Expression) Expression))
+(type: #export Unary (-> (Vector +1 Expression) Expression))
+(type: #export Binary (-> (Vector +2 Expression) Expression))
+(type: #export Trinary (-> (Vector +3 Expression) Expression))
+(type: #export Variadic (-> (List Expression) Expression))
+
+## [Utils]
+(def: #export (install name unnamed)
+ (-> Text (-> Text Proc)
+ (-> Bundle Bundle))
+ (dict.put name (unnamed name)))
+
+(def: #export (prefix prefix bundle)
+ (-> Text Bundle Bundle)
+ (|> bundle
+ dict.entries
+ (list/map (function (_ [key val]) [(format prefix " " key) val]))
+ (dict.from-list text.Hash<Text>)))
+
+(def: (wrong-arity proc expected actual)
+ (-> Text Nat Nat Text)
+ (format "Wrong number of arguments for " (%t proc) "\n"
+ "Expected: " (|> expected .int %i) "\n"
+ " Actual: " (|> actual .int %i)))
+
+(syntax: (arity: {name s.local-identifier} {arity s.nat})
+ (with-gensyms [g!_ g!proc g!name g!translate g!inputs]
+ (do {@ macro.monad}
+ [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))]
+ (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!proc))
+ (-> (-> (..Vector (~ (code.nat arity)) Expression) Expression)
+ (-> Text ..Proc))
+ (function ((~ g!_) (~ g!name))
+ (function ((~ g!_) (~ g!translate) (~ g!inputs))
+ (case (~ g!inputs)
+ (^ (list (~+ g!input+)))
+ (do macro.Monad<Meta>
+ [(~+ (|> g!input+
+ (list/map (function (_ g!input)
+ (list g!input (` ((~ g!translate) (~ g!input))))))
+ list.concat))]
+ ((~' wrap) ((~ g!proc) [(~+ g!input+)])))
+
+ (~' _)
+ (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs))))))))))))))
+
+(arity: nullary +0)
+(arity: unary +1)
+(arity: binary +2)
+(arity: trinary +3)
+
+(def: #export (variadic proc)
+ (-> Variadic (-> Text Proc))
+ (function (_ proc-name)
+ (function (_ translate inputsS)
+ (do {@ macro.Monad<Meta>}
+ [inputsI (monad.map @ translate inputsS)]
+ (wrap (proc inputsI))))))
+
+## [Procedures]
+## [[Lux]]
+(def: (lux//is [leftO rightO])
+ Binary
+ (r.apply (list leftO rightO)
+ (r.global "identical")))
+
+(def: (lux//if [testO thenO elseO])
+ Trinary
+ (caseT.translate-if testO thenO elseO))
+
+(def: (lux//try riskyO)
+ Unary
+ (runtimeT.lux//try riskyO))
+
+(exception: #export (Wrong-Syntax {message Text})
+ message)
+
+(def: #export (wrong-syntax procedure args)
+ (-> Text (List ls.Synthesis) Text)
+ (format "Procedure: " procedure "\n"
+ "Arguments: " (%code (code.tuple args))))
+
+(def: lux//loop
+ (-> Text Proc)
+ (function (_ proc-name)
+ (function (_ translate inputsS)
+ (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any))
+ (#e.Success [offset initsS+ bodyS])
+ (loopT.translate-loop translate offset initsS+ bodyS)
+
+ (#e.Error error)
+ (&.throw Wrong-Syntax (wrong-syntax proc-name inputsS)))
+ )))
+
+(def: lux//recur
+ (-> Text Proc)
+ (function (_ proc-name)
+ (function (_ translate inputsS)
+ (loopT.translate-recur translate inputsS))))
+
+(def: lux-procs
+ Bundle
+ (|> (dict.new text.Hash<Text>)
+ (install "is" (binary lux//is))
+ (install "try" (unary lux//try))
+ (install "if" (trinary lux//if))
+ (install "loop" lux//loop)
+ (install "recur" lux//recur)
+ ))
+
+## [[Bits]]
+(template [<name> <op>]
+ [(def: (<name> [subjectO paramO])
+ Binary
+ (<op> paramO subjectO))]
+
+ [bit//and runtimeT.bit//and]
+ [bit//or runtimeT.bit//or]
+ [bit//xor runtimeT.bit//xor]
+ )
+
+(template [<name> <op>]
+ [(def: (<name> [subjectO paramO])
+ Binary
+ (<op> (runtimeT.int64-low paramO) subjectO))]
+
+ [bit//left-shift runtimeT.bit//left-shift]
+ [bit//arithmetic-right-shift runtimeT.bit//arithmetic-right-shift]
+ [bit//logical-right-shift runtimeT.bit//logical-right-shift]
+ )
+
+(def: bit-procs
+ Bundle
+ (<| (prefix "bit")
+ (|> (dict.new text.Hash<Text>)
+ (install "and" (binary bit//and))
+ (install "or" (binary bit//or))
+ (install "xor" (binary bit//xor))
+ (install "left-shift" (binary bit//left-shift))
+ (install "logical-right-shift" (binary bit//logical-right-shift))
+ (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift))
+ )))
+
+## [[Numbers]]
+(host.import: java/lang/Double
+ (#static MIN_VALUE Double)
+ (#static MAX_VALUE Double))
+
+(template [<name> <const> <encode>]
+ [(def: (<name> _)
+ Nullary
+ (<encode> <const>))]
+
+ [frac//smallest Double::MIN_VALUE r.float]
+ [frac//min (f/* -1.0 Double::MAX_VALUE) r.float]
+ [frac//max Double::MAX_VALUE r.float]
+ )
+
+(template [<name> <op>]
+ [(def: (<name> [subjectO paramO])
+ Binary
+ (|> subjectO (<op> paramO)))]
+
+ [int//add runtimeT.int//+]
+ [int//sub runtimeT.int//-]
+ [int//mul runtimeT.int//*]
+ [int//div runtimeT.int///]
+ [int//rem runtimeT.int//%]
+ )
+
+(template [<name> <op>]
+ [(def: (<name> [subjectO paramO])
+ Binary
+ (<op> paramO subjectO))]
+
+ [frac//add r.+]
+ [frac//sub r.-]
+ [frac//mul r.*]
+ [frac//div r./]
+ [frac//rem r.%%]
+ [frac//= r.=]
+ [frac//< r.<]
+
+ [text//= r.=]
+ [text//< r.<]
+ )
+
+(template [<name> <cmp>]
+ [(def: (<name> [subjectO paramO])
+ Binary
+ (<cmp> paramO subjectO))]
+
+ [int//= runtimeT.int//=]
+ [int//< runtimeT.int//<]
+ )
+
+(def: (apply1 func)
+ (-> Expression (-> Expression Expression))
+ (function (_ value)
+ (r.apply (list value) func)))
+
+(def: int//char (|>> runtimeT.int64-low (apply1 (r.global "intToUtf8"))))
+
+(def: int-procs
+ Bundle
+ (<| (prefix "int")
+ (|> (dict.new text.Hash<Text>)
+ (install "+" (binary int//add))
+ (install "-" (binary int//sub))
+ (install "*" (binary int//mul))
+ (install "/" (binary int//div))
+ (install "%" (binary int//rem))
+ (install "=" (binary int//=))
+ (install "<" (binary int//<))
+ (install "to-frac" (unary runtimeT.int//to-float))
+ (install "char" (unary int//char)))))
+
+(def: (frac//encode value)
+ (-> Expression Expression)
+ (r.apply (list (r.string "%f") value) (r.global "sprintf")))
+
+(def: frac-procs
+ Bundle
+ (<| (prefix "frac")
+ (|> (dict.new text.Hash<Text>)
+ (install "+" (binary frac//add))
+ (install "-" (binary frac//sub))
+ (install "*" (binary frac//mul))
+ (install "/" (binary frac//div))
+ (install "%" (binary frac//rem))
+ (install "=" (binary frac//=))
+ (install "<" (binary frac//<))
+ (install "smallest" (nullary frac//smallest))
+ (install "min" (nullary frac//min))
+ (install "max" (nullary frac//max))
+ (install "to-int" (unary (apply1 (r.global "as.integer"))))
+ (install "encode" (unary frac//encode))
+ (install "decode" (unary runtimeT.frac//decode)))))
+
+## [[Text]]
+(def: (text//concat [subjectO paramO])
+ Binary
+ (r.apply (list subjectO paramO) (r.global "paste0")))
+
+(def: (text//char [subjectO paramO])
+ Binary
+ (runtimeT.text//char subjectO paramO))
+
+(def: (text//clip [subjectO paramO extraO])
+ Trinary
+ (runtimeT.text//clip subjectO paramO extraO))
+
+(def: (text//index [textO partO startO])
+ Trinary
+ (runtimeT.text//index textO partO startO))
+
+(def: text-procs
+ Bundle
+ (<| (prefix "text")
+ (|> (dict.new text.Hash<Text>)
+ (install "=" (binary text//=))
+ (install "<" (binary text//<))
+ (install "concat" (binary text//concat))
+ (install "index" (trinary text//index))
+ (install "size" (unary (|>> (apply1 (r.global "nchar")) runtimeT.int//from-float)))
+ (install "char" (binary text//char))
+ (install "clip" (trinary text//clip))
+ )))
+
+## [[IO]]
+(def: (io//exit input)
+ Unary
+ (r.apply-kw (list)
+ (list ["status" (runtimeT.int//to-float input)])
+ (r.global "quit")))
+
+(def: (void code)
+ (-> Expression Expression)
+ (r.block (r.then code runtimeT.unit)))
+
+(def: io-procs
+ Bundle
+ (<| (prefix "io")
+ (|> (dict.new text.Hash<Text>)
+ (install "log" (unary (|>> r.print ..void)))
+ (install "error" (unary r.stop))
+ (install "exit" (unary io//exit))
+ (install "current-time" (nullary (function (_ _)
+ (runtimeT.io//current-time! runtimeT.unit)))))))
+
+## [Bundles]
+(def: #export procedures
+ Bundle
+ (<| (prefix "lux")
+ (|> lux-procs
+ (dict.merge bit-procs)
+ (dict.merge int-procs)
+ (dict.merge frac-procs)
+ (dict.merge text-procs)
+ (dict.merge io-procs)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux
new file mode 100644
index 000000000..5dabf7f2a
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux
@@ -0,0 +1,90 @@
+(.module:
+ lux
+ (lux (control [library
+ [monad #+ do]])
+ (data [text]
+ text/format
+ (coll [list "list/" Functor<List>]
+ (dictionary ["dict" unordered #+ Dict])))
+ [macro "macro/" Monad<Meta>])
+ (luxc ["&" lang]
+ (lang ["la" analysis]
+ ["ls" synthesis]
+ (host [ruby #+ Ruby Expression Statement])))
+ [///]
+ (/// [".T" runtime])
+ (// ["@" common]))
+
+## (template [<name> <lua>]
+## [(def: (<name> _) @.Nullary <lua>)]
+
+## [lua//nil "nil"]
+## [lua//table "{}"]
+## )
+
+## (def: (lua//global proc translate inputs)
+## (-> Text @.Proc)
+## (case inputs
+## (^ (list [_ (#.Text name)]))
+## (do macro.Monad<Meta>
+## []
+## (wrap name))
+
+## _
+## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
+
+## (def: (lua//call proc translate inputs)
+## (-> Text @.Proc)
+## (case inputs
+## (^ (list& functionS argsS+))
+## (do {@ macro.Monad<Meta>}
+## [functionO (translate functionS)
+## argsO+ (monad.map @ translate argsS+)]
+## (wrap (lua.apply functionO argsO+)))
+
+## _
+## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
+
+## (def: lua-procs
+## @.Bundle
+## (|> (dict.new text.Hash<Text>)
+## (@.install "nil" (@.nullary lua//nil))
+## (@.install "table" (@.nullary lua//table))
+## (@.install "global" lua//global)
+## (@.install "call" lua//call)))
+
+## (def: (table//call proc translate inputs)
+## (-> Text @.Proc)
+## (case inputs
+## (^ (list& tableS [_ (#.Text field)] argsS+))
+## (do {@ macro.Monad<Meta>}
+## [tableO (translate tableS)
+## argsO+ (monad.map @ translate argsS+)]
+## (wrap (lua.method field tableO argsO+)))
+
+## _
+## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
+
+## (def: (table//get [fieldO tableO])
+## @.Binary
+## (runtimeT.lua//get tableO fieldO))
+
+## (def: (table//set [fieldO valueO tableO])
+## @.Trinary
+## (runtimeT.lua//set tableO fieldO valueO))
+
+## (def: table-procs
+## @.Bundle
+## (<| (@.prefix "table")
+## (|> (dict.new text.Hash<Text>)
+## (@.install "call" table//call)
+## (@.install "get" (@.binary table//get))
+## (@.install "set" (@.trinary table//set)))))
+
+(def: #export procedures
+ @.Bundle
+ (<| (@.prefix "lua")
+ (dict.new text.Hash<Text>)
+ ## (|> lua-procs
+ ## (dict.merge table-procs))
+ ))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/reference.lux
new file mode 100644
index 000000000..bbdb06ba0
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/reference.lux
@@ -0,0 +1,13 @@
+(.module:
+ [library
+ [lux #*
+ [target
+ ["_" r (#+ Expression)]]]]
+ [///
+ [reference (#+ System)]])
+
+(implementation: #export system
+ (System Expression)
+
+ (def: constant _.var)
+ (def: variable _.var))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux
new file mode 100644
index 000000000..4682a593d
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux
@@ -0,0 +1,855 @@
+(.module:
+ [library
+ [lux (#- Location inc i64)
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<.>" code]]]
+ [data
+ ["." product]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." row]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number (#+ hex)
+ ["n" nat]
+ ["i" int ("#\." interval)]
+ ["." i64]]]
+ ["@" target
+ ["_" r (#+ SVar Expression)]]]]
+ ["." /// #_
+ ["#." reference]
+ ["//#" /// #_
+ [analysis (#+ Variant)]
+ ["#." synthesis (#+ Synthesis)]
+ ["#." generation]
+ ["//#" ///
+ ["#." phase]
+ [reference
+ [variable (#+ Register)]]
+ [meta
+ [archive (#+ Output Archive)
+ ["." artifact (#+ Registry)]]]]]])
+
+(def: module_id
+ 0)
+
+(template [<name> <base>]
+ [(type: #export <name>
+ (<base> _.SVar _.Expression _.Expression))]
+
+ [Operation /////generation.Operation]
+ [Phase /////generation.Phase]
+ [Handler /////generation.Handler]
+ [Bundle /////generation.Bundle]
+ )
+
+(type: #export (Generator i)
+ (-> Phase Archive i (Operation Expression)))
+
+(def: #export unit
+ Expression
+ (_.string /////synthesis.unit))
+
+(def: full_32 (hex "FFFFFFFF"))
+(def: half_32 (hex "7FFFFFFF"))
+(def: post_32 (hex "100000000"))
+
+(def: (cap_32 input)
+ (-> Nat Int)
+ (cond (n.> full_32 input)
+ (|> input (i64.and full_32) cap_32)
+
+ (n.> half_32 input)
+ (|> post_32 (n.- input) .int (i.* -1))
+
+ ## else
+ (.int input)))
+
+(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
+ body)
+ (do {! meta.monad}
+ [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
+ (wrap (list (` (let [(~+ (|> vars
+ (list.zip/2 ids)
+ (list\map (function (_ [id var])
+ (list (code.local_identifier var)
+ (` (_.var (~ (code.text (format "v" (%.nat id)))))))))
+ list.concat))]
+ (~ body)))))))
+
+(syntax: (runtime: {declaration (<>.or <code>.local_identifier
+ (<code>.form (<>.and <code>.local_identifier
+ (<>.some <code>.local_identifier))))}
+ code)
+ (do meta.monad
+ [runtime_id meta.count]
+ (macro.with_gensyms [g!_]
+ (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id]))
+ runtime_name (` (_.var (~ (code.text (%.code runtime)))))]
+ (case declaration
+ (#.Left name)
+ (let [g!name (code.local_identifier name)]
+ (wrap (list (` (def: #export (~ g!name)
+ _.SVar
+ (~ runtime_name)))
+
+ (` (def: (~ (code.local_identifier (format "@" name)))
+ _.Expression
+ (_.set! (~ runtime_name) (~ code)))))))
+
+ (#.Right [name inputs])
+ (let [g!name (code.local_identifier name)
+ inputsC (list\map code.local_identifier inputs)
+ inputs_typesC (list\map (function.constant (` _.Expression))
+ inputs)]
+ (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
+ (-> (~+ inputs_typesC) _.Expression)
+ (_.apply (list (~+ inputsC)) (~ runtime_name))))
+
+ (` (def: (~ (code.local_identifier (format "@" name)))
+ _.Expression
+ (..with_vars [(~+ inputsC)]
+ (_.set! (~ runtime_name)
+ (_.function (list (~+ inputsC))
+ (~ code))))))))))))))
+
+(def: #export variant_tag_field "luxVT")
+(def: #export variant_flag_field "luxVF")
+(def: #export variant_value_field "luxVV")
+
+(def: #export (flag value)
+ (-> Bit Expression)
+ (if value
+ (_.string "")
+ _.null))
+
+(runtime: (adt::variant tag last? value)
+ (_.named_list (list [..variant_tag_field (_.as::integer tag)]
+ [..variant_flag_field last?]
+ [..variant_value_field value])))
+
+(def: #export (variant tag last? value)
+ (-> Nat Bit Expression Expression)
+ (adt::variant (_.int (.int tag))
+ (flag last?)
+ value))
+
+(def: #export none
+ Expression
+ (variant 0 #0 ..unit))
+
+(def: #export some
+ (-> Expression Expression)
+ (variant 1 #1))
+
+(def: #export left
+ (-> Expression Expression)
+ (variant 0 #0))
+
+(def: #export right
+ (-> Expression Expression)
+ (variant 1 #1))
+
+(def: high_shift (_.bit_shl (_.int +32)))
+
+(template [<name> <power>]
+ [(runtime: <name> (|> (_.as::integer (_.int +2)) (_.** (_.as::integer (_.int <power>)))))]
+
+ [f2^32 +32]
+ [f2^63 +63]
+ )
+
+(def: (as_double value)
+ (-> Expression Expression)
+ (_.apply (list value) (_.var "as.double")))
+
+(def: #export i64_high_field "luxIH")
+(def: #export i64_low_field "luxIL")
+
+(runtime: (i64::unsigned_low input)
+ (with_vars [low]
+ ($_ _.then
+ (_.set! low (|> input (_.nth (_.string ..i64_low_field))))
+ (_.if (|> low (_.>= (_.int +0)))
+ low
+ (|> low (_.+ f2^32))))))
+
+(runtime: (i64::to_float input)
+ (let [high (|> input
+ (_.nth (_.string ..i64_high_field))
+ high_shift)
+ low (|> input
+ i64::unsigned_low)]
+ (|> high (_.+ low) as_double)))
+
+(runtime: (i64::new high low)
+ (_.named_list (list [..i64_high_field (_.as::integer high)]
+ [..i64_low_field (_.as::integer low)])))
+
+(def: high_32
+ (-> Nat Nat)
+ (i64.right_shift 32))
+
+(def: low_32
+ (-> Nat Nat)
+ (|>> (i64.and (hex "FFFFFFFF"))))
+
+(def: #export (i64 value)
+ (-> Int Expression)
+ (let [value (.nat value)]
+ (i64::new (|> value ..high_32 ..cap_32 _.int)
+ (|> value ..low_32 ..cap_32 _.int))))
+
+(def: #export (lux_i64 high low)
+ (-> Int Int Int)
+ (|> high
+ (i64.left_shift 32)
+ (i64.or low)))
+
+(template [<name> <value>]
+ [(runtime: <name>
+ (..i64 <value>))]
+
+ [i64::zero +0]
+ [i64::one +1]
+ [i64::min i\bottom]
+ [i64::max i\top]
+ )
+
+(def: #export i64_high (_.nth (_.string ..i64_high_field)))
+(def: #export i64_low (_.nth (_.string ..i64_low_field)))
+
+(runtime: (i64::not input)
+ (i64::new (|> input i64_high _.bit_not)
+ (|> input i64_low _.bit_not)))
+
+(runtime: (i64::+ param subject)
+ (with_vars [sH sL pH pL
+ x00 x16 x32 x48]
+ ($_ _.then
+ (_.set! sH (|> subject i64_high))
+ (_.set! sL (|> subject i64_low))
+ (_.set! pH (|> param i64_high))
+ (_.set! pL (|> param i64_low))
+ (let [bits16 (_.manual "0xFFFF")
+ move_top_16 (_.bit_shl (_.int +16))
+ top_16 (_.bit_ushr (_.int +16))
+ bottom_16 (_.bit_and bits16)
+ split_16 (function (_ source)
+ [(|> source top_16)
+ (|> source bottom_16)])
+ split_int (function (_ high low)
+ [(split_16 high)
+ (split_16 low)])
+
+ [[s48 s32] [s16 s00]] (split_int sH sL)
+ [[p48 p32] [p16 p00]] (split_int pH pL)
+ new_half (function (_ top bottom)
+ (|> top bottom_16 move_top_16
+ (_.bit_or (bottom_16 bottom))))]
+ ($_ _.then
+ (_.set! x00 (|> s00 (_.+ p00)))
+ (_.set! x16 (|> x00 top_16 (_.+ s16) (_.+ p16)))
+ (_.set! x32 (|> x16 top_16 (_.+ s32) (_.+ p32)))
+ (_.set! x48 (|> x32 top_16 (_.+ s48) (_.+ p48)))
+ (i64::new (new_half x48 x32)
+ (new_half x16 x00)))))))
+
+(runtime: (i64::= reference sample)
+ (let [n/a? (function (_ value)
+ (_.apply (list value) (_.var "is.na")))
+ isTRUE? (function (_ value)
+ (_.apply (list value) (_.var "isTRUE")))
+ comparison (: (-> (-> Expression Expression) Expression)
+ (function (_ field)
+ (|> (|> (field sample) (_.= (field reference)))
+ (_.or (|> (n/a? (field sample))
+ (_.and (n/a? (field reference))))))))]
+ (|> (comparison i64_high)
+ (_.and (comparison i64_low))
+ isTRUE?)))
+
+(runtime: (i64::negate input)
+ (_.if (|> input (i64::= i64::min))
+ i64::min
+ (|> input i64::not (i64::+ i64::one))))
+
+(runtime: i64::-one
+ (i64::negate i64::one))
+
+(runtime: (i64::- param subject)
+ (i64::+ (i64::negate param) subject))
+
+(runtime: (i64::< reference sample)
+ (with_vars [r_? s_?]
+ ($_ _.then
+ (_.set! s_? (|> sample ..i64_high (_.< (_.int +0))))
+ (_.set! r_? (|> reference ..i64_high (_.< (_.int +0))))
+ (|> (|> s_? (_.and (_.not r_?)))
+ (_.or (|> (_.not s_?) (_.and r_?) _.not))
+ (_.or (|> sample
+ (i64::- reference)
+ ..i64_high
+ (_.< (_.int +0))))))))
+
+(runtime: (i64::from_float input)
+ (_.cond (list [(_.apply (list input) (_.var "is.nan"))
+ i64::zero]
+ [(|> input (_.<= (_.negate f2^63)))
+ i64::min]
+ [(|> input (_.+ (_.float +1.0)) (_.>= f2^63))
+ i64::max]
+ [(|> input (_.< (_.float +0.0)))
+ (|> input _.negate i64::from_float i64::negate)])
+ (i64::new (|> input (_./ f2^32))
+ (|> input (_.%% f2^32)))))
+
+(runtime: (i64::* param subject)
+ (with_vars [sH sL pH pL
+ x00 x16 x32 x48]
+ ($_ _.then
+ (_.set! sH (|> subject i64_high))
+ (_.set! pH (|> param i64_high))
+ (let [negative_subject? (|> sH (_.< (_.int +0)))
+ negative_param? (|> pH (_.< (_.int +0)))]
+ (_.cond (list [negative_subject?
+ (_.if negative_param?
+ (i64::* (i64::negate param)
+ (i64::negate subject))
+ (i64::negate (i64::* param
+ (i64::negate subject))))]
+
+ [negative_param?
+ (i64::negate (i64::* (i64::negate param)
+ subject))])
+ ($_ _.then
+ (_.set! sL (|> subject i64_low))
+ (_.set! pL (|> param i64_low))
+ (let [bits16 (_.manual "0xFFFF")
+ move_top_16 (_.bit_shl (_.int +16))
+ top_16 (_.bit_ushr (_.int +16))
+ bottom_16 (_.bit_and bits16)
+ split_16 (function (_ source)
+ [(|> source top_16)
+ (|> source bottom_16)])
+ split_int (function (_ high low)
+ [(split_16 high)
+ (split_16 low)])
+ new_half (function (_ top bottom)
+ (|> top bottom_16 move_top_16
+ (_.bit_or (bottom_16 bottom))))
+ x16_top (|> x16 top_16)
+ x32_top (|> x32 top_16)]
+ (with_vars [s48 s32 s16 s00
+ p48 p32 p16 p00]
+ (let [[[_s48 _s32] [_s16 _s00]] (split_int sH sL)
+ [[_p48 _p32] [_p16 _p00]] (split_int pH pL)
+ set_subject_chunks! ($_ _.then (_.set! s48 _s48) (_.set! s32 _s32) (_.set! s16 _s16) (_.set! s00 _s00))
+ set_param_chunks! ($_ _.then (_.set! p48 _p48) (_.set! p32 _p32) (_.set! p16 _p16) (_.set! p00 _p00))]
+ ($_ _.then
+ set_subject_chunks!
+ set_param_chunks!
+ (_.set! x00 (|> s00 (_.* p00)))
+ (_.set! x16 (|> x00 top_16 (_.+ (|> s16 (_.* p00)))))
+ (_.set! x32 x16_top)
+ (_.set! x16 (|> x16 bottom_16 (_.+ (|> s00 (_.* p16)))))
+ (_.set! x32 (|> x32 (_.+ x16_top) (_.+ (|> s32 (_.* p00)))))
+ (_.set! x48 x32_top)
+ (_.set! x32 (|> x32 bottom_16 (_.+ (|> s16 (_.* p16)))))
+ (_.set! x48 (|> x48 (_.+ x32_top)))
+ (_.set! x32 (|> x32 bottom_16 (_.+ (|> s00 (_.* p32)))))
+ (_.set! x48 (|> x48 (_.+ x32_top)
+ (_.+ (|> s48 (_.* p00)))
+ (_.+ (|> s32 (_.* p16)))
+ (_.+ (|> s16 (_.* p32)))
+ (_.+ (|> s00 (_.* p48)))))
+ (i64::new (new_half x48 x32)
+ (new_half x16 x00)))))
+ )))))))
+
+(def: (limit_shift! shift)
+ (-> SVar Expression)
+ (_.set! shift (|> shift (_.bit_and (_.as::integer (_.int +63))))))
+
+(def: (no_shift_clause shift input)
+ (-> SVar SVar [Expression Expression])
+ [(|> shift (_.= (_.int +0)))
+ input])
+
+(runtime: (i64::left_shift shift input)
+ ($_ _.then
+ (limit_shift! shift)
+ (_.cond (list (no_shift_clause shift input)
+ [(|> shift (_.< (_.int +32)))
+ (let [mid (|> (i64_low input) (_.bit_ushr (|> (_.int +32) (_.- shift))))
+ high (|> (i64_high input)
+ (_.bit_shl shift)
+ (_.bit_or mid))
+ low (|> (i64_low input)
+ (_.bit_shl shift))]
+ (i64::new high low))])
+ (let [high (|> (i64_high input)
+ (_.bit_shl (|> shift (_.- (_.int +32)))))]
+ (i64::new high (_.int +0))))))
+
+(runtime: (i64::arithmetic_right_shift_32 shift input)
+ (let [top_bit (|> input (_.bit_and (_.as::integer (_.int (hex "+80000000")))))]
+ (|> input
+ (_.bit_ushr shift)
+ (_.bit_or top_bit))))
+
+(runtime: (i64::arithmetic_right_shift shift input)
+ ($_ _.then
+ (limit_shift! shift)
+ (_.cond (list (no_shift_clause shift input)
+ [(|> shift (_.< (_.int +32)))
+ (let [mid (|> (i64_high input) (_.bit_shl (|> (_.int +32) (_.- shift))))
+ high (|> (i64_high input)
+ (i64::arithmetic_right_shift_32 shift))
+ low (|> (i64_low input)
+ (_.bit_ushr shift)
+ (_.bit_or mid))]
+ (i64::new high low))])
+ (let [low (|> (i64_high input)
+ (i64::arithmetic_right_shift_32 (|> shift (_.- (_.int +32)))))
+ high (_.if (|> (i64_high input) (_.>= (_.int +0)))
+ (_.int +0)
+ (_.int -1))]
+ (i64::new high low)))))
+
+(runtime: (i64::/ param subject)
+ (let [negative? (|>> (i64::< i64::zero))
+ valid_division_check [(|> param (i64::= i64::zero))
+ (_.stop (_.string "Cannot divide by zero!"))]
+ short_circuit_check [(|> subject (i64::= i64::zero))
+ i64::zero]]
+ (_.cond (list valid_division_check
+ short_circuit_check
+
+ [(|> subject (i64::= i64::min))
+ (_.cond (list [(|> (|> param (i64::= i64::one))
+ (_.or (|> param (i64::= i64::-one))))
+ i64::min]
+ [(|> param (i64::= i64::min))
+ i64::one])
+ (with_vars [approximation]
+ ($_ _.then
+ (_.set! approximation
+ (|> subject
+ (i64::arithmetic_right_shift (_.int +1))
+ (i64::/ param)
+ (i64::left_shift (_.int +1))))
+ (_.if (|> approximation (i64::= i64::zero))
+ (_.if (negative? param)
+ i64::one
+ i64::-one)
+ (let [remainder (i64::- (i64::* param approximation)
+ subject)]
+ (|> remainder
+ (i64::/ param)
+ (i64::+ approximation)))))))]
+ [(|> param (i64::= i64::min))
+ i64::zero]
+
+ [(negative? subject)
+ (_.if (negative? param)
+ (|> (i64::negate subject)
+ (i64::/ (i64::negate param)))
+ (|> (i64::negate subject)
+ (i64::/ param)
+ i64::negate))]
+
+ [(negative? param)
+ (|> param
+ i64::negate
+ (i64::/ subject)
+ i64::negate)])
+ (with_vars [result remainder approximate approximate_result log2 approximate_remainder]
+ ($_ _.then
+ (_.set! result i64::zero)
+ (_.set! remainder subject)
+ (_.while (|> (|> remainder (i64::< param))
+ (_.or (|> remainder (i64::= param))))
+ (let [calc_rough_estimate (_.apply (list (|> (i64::to_float remainder) (_./ (i64::to_float param))))
+ (_.var "floor"))
+ calc_approximate_result (i64::from_float approximate)
+ calc_approximate_remainder (|> approximate_result (i64::* param))
+ delta (_.if (|> (_.float +48.0) (_.<= log2))
+ (_.float +1.0)
+ (_.** (|> log2 (_.- (_.float +48.0)))
+ (_.float +2.0)))]
+ ($_ _.then
+ (_.set! approximate (_.apply (list (_.float +1.0) calc_rough_estimate)
+ (_.var "max")))
+ (_.set! log2 (let [log (function (_ input)
+ (_.apply (list input) (_.var "log")))]
+ (_.apply (list (|> (log (_.int +2))
+ (_./ (log approximate))))
+ (_.var "ceil"))))
+ (_.set! approximate_result calc_approximate_result)
+ (_.set! approximate_remainder calc_approximate_remainder)
+ (_.while (|> (negative? approximate_remainder)
+ (_.or (|> approximate_remainder (i64::< remainder))))
+ ($_ _.then
+ (_.set! approximate (|> delta (_.- approximate)))
+ (_.set! approximate_result calc_approximate_result)
+ (_.set! approximate_remainder calc_approximate_remainder)))
+ (_.set! result (|> (_.if (|> approximate_result (i64::= i64::zero))
+ i64::one
+ approximate_result)
+ (i64::+ result)))
+ (_.set! remainder (|> remainder (i64::- approximate_remainder))))))
+ result))
+ )))
+
+(runtime: (i64::% param subject)
+ (let [flat (|> subject (i64::/ param) (i64::* param))]
+ (|> subject (i64::- flat))))
+
+(runtime: (lux::try op)
+ (with_vars [error value]
+ (_.try ($_ _.then
+ (_.set! value (_.apply (list ..unit) op))
+ (..right value))
+ #.None
+ (#.Some (_.function (list error)
+ (..left (_.nth (_.string "message")
+ error))))
+ #.None)))
+
+(runtime: (lux::program_args program_args)
+ (with_vars [inputs value]
+ ($_ _.then
+ (_.set! inputs ..none)
+ (<| (_.for_in value program_args)
+ (_.set! inputs (..some (_.list (list value inputs)))))
+ inputs)))
+
+(def: runtime::lux
+ Expression
+ ($_ _.then
+ @lux::try
+ @lux::program_args
+ ))
+
+(def: current_time_float
+ Expression
+ (let [raw_time (_.apply (list) (_.var "Sys.time"))]
+ (_.apply (list raw_time) (_.var "as.numeric"))))
+
+(runtime: (io::current_time! _)
+ (|> current_time_float
+ (_.* (_.float +1,000.0))
+ i64::from_float))
+
+(def: runtime::io
+ Expression
+ ($_ _.then
+ @io::current_time!
+ ))
+
+(def: minimum_index_length
+ (-> SVar Expression)
+ (|>> (_.+ (_.int +1))))
+
+(def: (product_element product index)
+ (-> Expression Expression Expression)
+ (|> product (_.nth (|> index (_.+ (_.int +1))))))
+
+(def: (product_tail product)
+ (-> SVar Expression)
+ (|> product (_.nth (_.length product))))
+
+(def: (updated_index min_length product)
+ (-> Expression Expression Expression)
+ (|> min_length (_.- (_.length product))))
+
+(runtime: (tuple::left index product)
+ (let [$index_min_length (_.var "index_min_length")]
+ ($_ _.then
+ (_.set! $index_min_length (minimum_index_length index))
+ (_.if (|> (_.length product) (_.> $index_min_length))
+ ## No need for recursion
+ (product_element product index)
+ ## Needs recursion
+ (tuple::left (updated_index $index_min_length product)
+ (product_tail product))))))
+
+(runtime: (tuple::right index product)
+ (let [$index_min_length (_.var "index_min_length")]
+ ($_ _.then
+ (_.set! $index_min_length (minimum_index_length index))
+ (_.cond (list [## Last element.
+ (|> (_.length product) (_.= $index_min_length))
+ (product_element product index)]
+ [## Needs recursion
+ (|> (_.length product) (_.< $index_min_length))
+ (tuple::right (updated_index $index_min_length product)
+ (product_tail product))])
+ ## Must slice
+ (|> product (_.slice_from index))))))
+
+(runtime: (sum::get sum wants_last? wanted_tag)
+ (let [no_match _.null
+ sum_tag (|> sum (_.nth (_.string ..variant_tag_field)))
+ sum_flag (|> sum (_.nth (_.string ..variant_flag_field)))
+ sum_value (|> sum (_.nth (_.string ..variant_value_field)))
+ is_last? (|> sum_flag (_.= (_.string "")))
+ test_recursion (_.if is_last?
+ ## Must recurse.
+ (|> wanted_tag
+ (_.- sum_tag)
+ (sum::get sum_value wants_last?))
+ no_match)]
+ (_.cond (list [(_.= sum_tag wanted_tag)
+ (_.if (_.= wants_last? sum_flag)
+ sum_value
+ test_recursion)]
+
+ [(|> wanted_tag (_.> sum_tag))
+ test_recursion]
+
+ [(|> (|> wants_last? (_.= (_.string "")))
+ (_.and (|> wanted_tag (_.< sum_tag))))
+ (adt::variant (|> sum_tag (_.- wanted_tag)) sum_flag sum_value)])
+
+ no_match)))
+
+(def: runtime::adt
+ Expression
+ ($_ _.then
+ @tuple::left
+ @tuple::right
+ @sum::get
+ @adt::variant
+ ))
+
+(template [<name> <op>]
+ [(runtime: (<name> mask input)
+ (i64::new (<op> (i64_high mask)
+ (i64_high input))
+ (<op> (i64_low mask)
+ (i64_low input))))]
+
+ [i64::and _.bit_and]
+ [i64::or _.bit_or]
+ [i64::xor _.bit_xor]
+ )
+
+(runtime: (i64::right_shift shift input)
+ ($_ _.then
+ (limit_shift! shift)
+ (_.cond (list (no_shift_clause shift input)
+ [(|> shift (_.< (_.int +32)))
+ (with_vars [$mid]
+ (let [mid (|> (i64_high input) (_.bit_shl (|> (_.int +32) (_.- shift))))
+ high (|> (i64_high input) (_.bit_ushr shift))
+ low (|> (i64_low input)
+ (_.bit_ushr shift)
+ (_.bit_or (_.if (_.apply (list $mid) (_.var "is.na"))
+ (_.as::integer (_.int +0))
+ $mid)))]
+ ($_ _.then
+ (_.set! $mid mid)
+ (i64::new high low))))]
+ [(|> shift (_.= (_.int +32)))
+ (let [high (i64_high input)]
+ (i64::new (_.int +0) high))])
+ (let [low (|> (i64_high input) (_.bit_ushr (|> shift (_.- (_.int +32)))))]
+ (i64::new (_.int +0) low)))))
+
+(def: runtime::i64
+ Expression
+ ($_ _.then
+ @f2^32
+ @f2^63
+
+ @i64::new
+ @i64::from_float
+
+ @i64::and
+ @i64::or
+ @i64::xor
+ @i64::not
+ @i64::left_shift
+ @i64::arithmetic_right_shift_32
+ @i64::arithmetic_right_shift
+ @i64::right_shift
+
+ @i64::zero
+ @i64::one
+ @i64::min
+ @i64::max
+ @i64::=
+ @i64::<
+ @i64::+
+ @i64::-
+ @i64::negate
+ @i64::-one
+ @i64::unsigned_low
+ @i64::to_float
+ @i64::*
+ @i64::/
+ @i64::%
+ ))
+
+(runtime: (frac::decode input)
+ (with_vars [output]
+ ($_ _.then
+ (_.set! output (_.apply (list input) (_.var "as.numeric")))
+ (_.if (|> output (_.= _.n/a))
+ ..none
+ (..some output)))))
+
+(def: runtime::frac
+ Expression
+ ($_ _.then
+ @frac::decode
+ ))
+
+(def: inc
+ (-> Expression Expression)
+ (|>> (_.+ (_.int +1))))
+
+(template [<name> <top_cmp>]
+ [(def: (<name> top value)
+ (-> Expression Expression Expression)
+ (|> (|> value (_.>= (_.int +0)))
+ (_.and (|> value (<top_cmp> top)))))]
+
+ [within? _.<]
+ [up_to? _.<=]
+ )
+
+(def: (text_clip start end text)
+ (-> Expression Expression Expression Expression)
+ (_.apply (list text start end)
+ (_.var "substr")))
+
+(def: (text_length text)
+ (-> Expression Expression)
+ (_.apply (list text) (_.var "nchar")))
+
+(runtime: (text::index subject param start)
+ (with_vars [idx startF subjectL]
+ ($_ _.then
+ (_.set! startF (i64::to_float start))
+ (_.set! subjectL (text_length subject))
+ (_.if (|> startF (within? subjectL))
+ ($_ _.then
+ (_.set! idx (|> (_.apply_kw (list param (_.if (|> startF (_.= (_.int +0)))
+ subject
+ (text_clip (inc startF)
+ (inc subjectL)
+ subject)))
+ (list ["fixed" (_.bool #1)])
+ (_.var "regexpr"))
+ (_.nth (_.int +1))))
+ (_.if (|> idx (_.= (_.int -1)))
+ ..none
+ (..some (i64::from_float (|> idx (_.+ startF))))))
+ ..none))))
+
+(runtime: (text::clip text from to)
+ (with_vars [length]
+ ($_ _.then
+ (_.set! length (_.length text))
+ (_.if ($_ _.and
+ (|> to (within? length))
+ (|> from (up_to? to)))
+ (..some (text_clip (inc from) (inc to) text))
+ ..none))))
+
+(def: (char_at idx text)
+ (-> Expression Expression Expression)
+ (_.apply (list (text_clip idx idx text))
+ (_.var "utf8ToInt")))
+
+(runtime: (text::char text idx)
+ (_.if (|> idx (within? (_.length text)))
+ ($_ _.then
+ (_.set! idx (inc idx))
+ (..some (i64::from_float (char_at idx text))))
+ ..none))
+
+(def: runtime::text
+ Expression
+ ($_ _.then
+ @text::index
+ @text::clip
+ @text::char
+ ))
+
+(def: (check_index_out_of_bounds array idx body)
+ (-> Expression Expression Expression Expression)
+ (_.if (|> idx (_.<= (_.length array)))
+ body
+ (_.stop (_.string "Array index out of bounds!"))))
+
+(runtime: (array::new size)
+ (with_vars [output]
+ ($_ _.then
+ (_.set! output (_.list (list)))
+ (_.set_nth! (|> size (_.+ (_.int +1)))
+ _.null
+ output)
+ output)))
+
+(runtime: (array::get array idx)
+ (with_vars [temp]
+ (<| (check_index_out_of_bounds array idx)
+ ($_ _.then
+ (_.set! temp (|> array (_.nth (_.+ (_.int +1) idx))))
+ (_.if (|> temp (_.= _.null))
+ ..none
+ (..some temp))))))
+
+(runtime: (array::put array idx value)
+ (<| (check_index_out_of_bounds array idx)
+ ($_ _.then
+ (_.set_nth! (_.+ (_.int +1) idx) value array)
+ array)))
+
+(def: runtime::array
+ Expression
+ ($_ _.then
+ @array::new
+ @array::get
+ @array::put
+ ))
+
+(def: runtime
+ Expression
+ ($_ _.then
+ runtime::lux
+ runtime::i64
+ runtime::adt
+ runtime::frac
+ runtime::text
+ runtime::array
+ runtime::io
+ ))
+
+(def: #export generate
+ (Operation [Registry Output])
+ (do ///////phase.monad
+ [_ (/////generation.execute! ..runtime)
+ _ (/////generation.save! (%.nat ..module_id) ..runtime)]
+ (wrap [(|> artifact.empty
+ artifact.resource
+ product.right)
+ (row.row [(%.nat ..module_id)
+ (|> ..runtime
+ _.code
+ (\ utf8.codec encode))])])))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/structure.lux
new file mode 100644
index 000000000..1020cad97
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/structure.lux
@@ -0,0 +1,40 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ [collection
+ ["." list]]]
+ [target
+ ["_" r (#+ Expression)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." primitive]
+ ["///#" //// #_
+ [analysis (#+ Variant Tuple)]
+ ["#." synthesis (#+ Synthesis)]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]]]])
+
+(def: #export (tuple expression archive elemsS+)
+ (Generator (Tuple Synthesis))
+ (case elemsS+
+ #.Nil
+ (///////phase\wrap (//primitive.text /////synthesis.unit))
+
+ (#.Cons singletonS #.Nil)
+ (expression archive singletonS)
+
+ _
+ (|> elemsS+
+ (monad.map ///////phase.monad (expression archive))
+ (///////phase\map _.list))))
+
+(def: #export (variant expression archive [lefts right? valueS])
+ (Generator (Variant Synthesis))
+ (let [tag (if right?
+ (inc lefts)
+ lefts)]
+ (///////phase\map (|>> (//runtime.variant tag right?))
+ (expression archive valueS))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/reference.lux
new file mode 100644
index 000000000..8b2a907ca
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/reference.lux
@@ -0,0 +1,89 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ [data
+ [text
+ ["%" format (#+ format)]]]]]
+ ["." //// #_
+ ["." version]
+ ["#." generation (#+ Context)]
+ ["//#" /// #_
+ ["." reference (#+ Reference)
+ ["." variable (#+ Register Variable)]]
+ ["." phase ("#\." monad)]
+ [meta
+ [archive (#+ Archive)]]]])
+
+## This universe constant is for languages where one can't just turn all compiled definitions
+## into the local variables of some scoping function.
+(def: #export universe
+ (for {## In the case of Lua, there is a limit of 200 locals in a function's scope.
+ @.lua (not ("lua script universe"))
+ ## Cannot make all definitions be local variables because of limitations with JRuby.
+ @.ruby (not ("ruby script universe"))
+ ## Cannot make all definitions be local variables because of limitations with PHP itself.
+ @.php (not ("php script universe"))
+ ## Cannot make all definitions be local variables because of limitations with Kawa.
+ @.scheme (not ("scheme script universe"))}
+ #0))
+
+(def: universe_label
+ Text
+ (with_expansions [<label> (format "u" (%.nat (if ..universe 1 0)))]
+ (for {@.lua <label>
+ @.ruby <label>
+ @.php <label>
+ @.scheme <label>}
+ "")))
+
+(def: #export (artifact [module artifact])
+ (-> Context Text)
+ (format "l" (%.nat version.version)
+ ..universe_label
+ "m" (%.nat module)
+ "a" (%.nat artifact)))
+
+(interface: #export (System expression)
+ (: (-> Text expression)
+ constant)
+ (: (-> Text expression)
+ variable))
+
+(def: #export (constant system archive name)
+ (All [anchor expression directive]
+ (-> (System expression) Archive Name
+ (////generation.Operation anchor expression directive expression)))
+ (phase\map (|>> ..artifact (\ system constant))
+ (////generation.remember archive name)))
+
+(template [<sigil> <name>]
+ [(def: #export (<name> system)
+ (All [expression]
+ (-> (System expression)
+ (-> Register expression)))
+ (|>> %.nat (format <sigil>) (\ system variable)))]
+
+ ["f" foreign]
+ ["l" local]
+ )
+
+(def: #export (variable system variable)
+ (All [expression]
+ (-> (System expression) Variable expression))
+ (case variable
+ (#variable.Local register)
+ (..local system register)
+
+ (#variable.Foreign register)
+ (..foreign system register)))
+
+(def: #export (reference system archive reference)
+ (All [anchor expression directive]
+ (-> (System expression) Archive Reference (////generation.Operation anchor expression directive expression)))
+ (case reference
+ (#reference.Constant value)
+ (..constant system archive value)
+
+ (#reference.Variable value)
+ (phase\wrap (..variable system value))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby.lux
new file mode 100644
index 000000000..c891727e4
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby.lux
@@ -0,0 +1,105 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]]
+ [target
+ ["_" ruby]]]]
+ ["." / #_
+ [runtime (#+ Phase Phase!)]
+ ["#." primitive]
+ ["#." structure]
+ ["#." reference]
+ ["#." function]
+ ["#." case]
+ ["#." loop]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." extension]
+ ["/#" // #_
+ [analysis (#+)]
+ ["#." synthesis]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]
+ [reference (#+)
+ [variable (#+)]]]]]]])
+
+(def: (statement expression archive synthesis)
+ Phase!
+ (case synthesis
+ (^template [<tag>]
+ [(^ (<tag> value))
+ (//////phase\map _.return (expression archive synthesis))])
+ ([////synthesis.bit]
+ [////synthesis.i64]
+ [////synthesis.f64]
+ [////synthesis.text]
+ [////synthesis.variant]
+ [////synthesis.tuple]
+ [#////synthesis.Reference]
+ [////synthesis.branch/get]
+ [////synthesis.function/apply]
+ [#////synthesis.Extension])
+
+ (^ (////synthesis.branch/case case))
+ (/case.case! false statement expression archive case)
+
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (<generator> statement expression archive value)])
+ ([////synthesis.branch/let /case.let!]
+ [////synthesis.branch/if /case.if!]
+ [////synthesis.loop/scope /loop.scope!]
+ [////synthesis.loop/recur /loop.recur!])
+
+ (^ (////synthesis.function/abstraction abstraction))
+ (//////phase\map _.return (/function.function statement expression archive abstraction))
+ ))
+
+(exception: #export cannot-recur-as-an-expression)
+
+(def: (expression archive synthesis)
+ Phase
+ (case synthesis
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (//////phase\wrap (<generator> value))])
+ ([////synthesis.bit /primitive.bit]
+ [////synthesis.i64 /primitive.i64]
+ [////synthesis.f64 /primitive.f64]
+ [////synthesis.text /primitive.text])
+
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (<generator> expression archive value)])
+ ([////synthesis.variant /structure.variant]
+ [////synthesis.tuple /structure.tuple]
+
+ [////synthesis.branch/let /case.let]
+ [////synthesis.branch/if /case.if]
+ [////synthesis.branch/get /case.get]
+
+ [////synthesis.function/apply /function.apply])
+
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (<generator> statement expression archive value)])
+ ([////synthesis.branch/case /case.case]
+ [////synthesis.loop/scope /loop.scope]
+ [////synthesis.function/abstraction /function.function])
+
+ (^ (////synthesis.loop/recur _))
+ (//////phase.throw ..cannot-recur-as-an-expression [])
+
+ (#////synthesis.Reference value)
+ (//reference.reference /reference.system archive value)
+
+ (#////synthesis.Extension extension)
+ (///extension.apply archive expression extension)))
+
+(def: #export generate
+ Phase
+ ..expression)
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux
new file mode 100644
index 000000000..3c080ba8a
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux
@@ -0,0 +1,360 @@
+(.module:
+ [library
+ [lux (#- case let if)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ [exception (#+ exception:)]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." set]]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]]]
+ [target
+ ["_" ruby (#+ Expression LVar Statement)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator Phase! Generator!)]
+ ["#." reference]
+ ["#." primitive]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ [synthesis
+ ["." case]]
+ ["/#" // #_
+ ["#." synthesis (#+ Member Synthesis Path)]
+ ["#." generation]
+ ["//#" /// #_
+ [reference
+ ["#." variable (#+ Register)]]
+ ["#." phase ("#\." monad)]
+ [meta
+ [archive (#+ Archive)]]]]]]])
+
+(def: #export (gensym prefix)
+ (-> Text (Operation LVar))
+ (///////phase\map (|>> %.nat (format prefix) _.local) /////generation.next))
+
+(def: #export register
+ (-> Register LVar)
+ (|>> (///reference.local //reference.system) :assume))
+
+(def: #export capture
+ (-> Register LVar)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: #export (let expression archive [valueS register bodyS])
+ (Generator [Synthesis Register Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)
+ bodyO (expression archive bodyS)]
+ ## TODO: Find some way to do 'let' without paying the price of the closure.
+ (wrap (|> bodyO
+ _.return
+ (_.lambda #.None (list (..register register)))
+ (_.apply_lambda/* (list valueO))))))
+
+(def: #export (let! statement expression archive [valueS register bodyS])
+ (Generator! [Synthesis Register Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)
+ bodyO (statement expression archive bodyS)]
+ (wrap ($_ _.then
+ (_.set (list (..register register)) valueO)
+ bodyO))))
+
+(def: #export (if expression archive [testS thenS elseS])
+ (Generator [Synthesis Synthesis Synthesis])
+ (do ///////phase.monad
+ [testO (expression archive testS)
+ thenO (expression archive thenS)
+ elseO (expression archive elseS)]
+ (wrap (_.? testO thenO elseO))))
+
+(def: #export (if! statement expression archive [testS thenS elseS])
+ (Generator! [Synthesis Synthesis Synthesis])
+ (do ///////phase.monad
+ [test! (expression archive testS)
+ then! (statement expression archive thenS)
+ else! (statement expression archive elseS)]
+ (wrap (_.if test!
+ then!
+ else!))))
+
+(def: #export (get expression archive [pathP valueS])
+ (Generator [(List Member) Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)]
+ (wrap (list\fold (function (_ side source)
+ (.let [method (.case side
+ (^template [<side> <accessor>]
+ [(<side> lefts)
+ (<accessor> (_.int (.int lefts)))])
+ ([#.Left //runtime.tuple//left]
+ [#.Right //runtime.tuple//right]))]
+ (method source)))
+ valueO
+ (list.reverse pathP)))))
+
+(def: @savepoint (_.local "lux_pm_savepoint"))
+(def: @cursor (_.local "lux_pm_cursor"))
+(def: @temp (_.local "lux_pm_temp"))
+
+(def: (push! value)
+ (-> Expression Statement)
+ (_.statement (|> @cursor (_.do "push" (list value)))))
+
+(def: peek_and_pop
+ Expression
+ (|> @cursor (_.do "pop" (list))))
+
+(def: pop!
+ Statement
+ (_.statement ..peek_and_pop))
+
+(def: peek
+ Expression
+ (_.nth (_.int -1) @cursor))
+
+(def: save!
+ Statement
+ (.let [cursor (_.array_range (_.int +0) (_.int -1) @cursor)]
+ (_.statement (|> @savepoint (_.do "push" (list cursor))))))
+
+(def: restore!
+ Statement
+ (_.set (list @cursor) (|> @savepoint (_.do "pop" (list)))))
+
+(def: fail! _.break)
+
+(def: (multi_pop! pops)
+ (-> Nat Statement)
+ (_.statement (_.do "slice!" (list (_.int (i.* -1 (.int pops)))
+ (_.int (.int pops)))
+ @cursor)))
+
+(template [<name> <flag> <prep>]
+ [(def: (<name> simple? idx)
+ (-> Bit Nat Statement)
+ ($_ _.then
+ (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>)))
+ (.if simple?
+ (_.when (_.= _.nil @temp)
+ fail!)
+ (_.if (_.= _.nil @temp)
+ fail!
+ (..push! @temp)))))]
+
+ [left_choice _.nil (<|)]
+ [right_choice (_.string "") inc]
+ )
+
+(def: (with_looping in_closure? g!once g!continue? body!)
+ (-> Bit LVar LVar Statement Statement)
+ (.if in_closure?
+ ($_ _.then
+ (_.while (_.bool true)
+ body!))
+ ($_ _.then
+ (_.set (list g!once) (_.bool true))
+ (_.set (list g!continue?) (_.bool false))
+ (<| (_.while (_.bool true))
+ (_.if g!once
+ ($_ _.then
+ (_.set (list g!once) (_.bool false))
+ body!)
+ ($_ _.then
+ (_.set (list g!continue?) (_.bool true))
+ _.break)))
+ (_.when g!continue?
+ _.next))))
+
+(def: (alternation in_closure? g!once g!continue? pre! post!)
+ (-> Bit LVar LVar Statement Statement Statement)
+ ($_ _.then
+ (with_looping in_closure? g!once g!continue?
+ ($_ _.then
+ ..save!
+ pre!))
+ ..restore!
+ post!))
+
+(def: (primitive_pattern_matching recur pathP)
+ (-> (-> Path (Operation Statement))
+ (-> Path (Operation (Maybe Statement))))
+ (.case pathP
+ (#/////synthesis.Bit_Fork when thenP elseP)
+ (do {! ///////phase.monad}
+ [then! (recur thenP)
+ else! (.case elseP
+ (#.Some elseP)
+ (recur elseP)
+
+ #.None
+ (wrap ..fail!))]
+ (wrap (#.Some (.if when
+ (_.if ..peek
+ then!
+ else!)
+ (_.if ..peek
+ else!
+ then!)))))
+
+ (^template [<tag> <format>]
+ [(<tag> cons)
+ (do {! ///////phase.monad}
+ [clauses (monad.map ! (function (_ [match then])
+ (\ ! map
+ (|>> [(_.= (|> match <format>)
+ ..peek)])
+ (recur then)))
+ (#.Cons cons))]
+ (wrap (#.Some (_.cond clauses
+ ..fail!))))])
+ ([#/////synthesis.I64_Fork (<| //primitive.i64 .int)]
+ [#/////synthesis.F64_Fork (<| //primitive.f64)]
+ [#/////synthesis.Text_Fork (<| //primitive.text)])
+
+ _
+ (\ ///////phase.monad wrap #.None)))
+
+(def: (pattern_matching' in_closure? statement expression archive)
+ (-> Bit (Generator! Path))
+ (function (recur pathP)
+ (do ///////phase.monad
+ [?output (primitive_pattern_matching recur pathP)]
+ (.case ?output
+ (#.Some output)
+ (wrap output)
+
+ #.None
+ (.case pathP
+ (#/////synthesis.Then bodyS)
+ (statement expression archive bodyS)
+
+ #/////synthesis.Pop
+ (///////phase\wrap ..pop!)
+
+ (#/////synthesis.Bind register)
+ (///////phase\wrap (_.set (list (..register register)) ..peek))
+
+ (#/////synthesis.Bit_Fork when thenP elseP)
+ (do {! ///////phase.monad}
+ [then! (recur thenP)
+ else! (.case elseP
+ (#.Some elseP)
+ (recur elseP)
+
+ #.None
+ (wrap ..fail!))]
+ (wrap (.if when
+ (_.if ..peek
+ then!
+ else!)
+ (_.if ..peek
+ else!
+ then!))))
+
+ (^template [<tag> <format>]
+ [(<tag> cons)
+ (do {! ///////phase.monad}
+ [clauses (monad.map ! (function (_ [match then])
+ (\ ! map
+ (|>> [(_.= (|> match <format>)
+ ..peek)])
+ (recur then)))
+ (#.Cons cons))]
+ (wrap (_.cond clauses
+ ..fail!)))])
+ ([#/////synthesis.I64_Fork (<| //primitive.i64 .int)]
+ [#/////synthesis.F64_Fork (<| //primitive.f64)]
+ [#/////synthesis.Text_Fork (<| //primitive.text)])
+
+ (^template [<complex> <simple> <choice>]
+ [(^ (<complex> idx))
+ (///////phase\wrap (<choice> false idx))
+
+ (^ (<simple> idx nextP))
+ (|> nextP
+ recur
+ (///////phase\map (_.then (<choice> true idx))))])
+ ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice]
+ [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice])
+
+ (^ (/////synthesis.member/left 0))
+ (///////phase\wrap (|> ..peek (_.nth (_.int +0)) ..push!))
+
+ (^template [<pm> <getter>]
+ [(^ (<pm> lefts))
+ (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))])
+ ([/////synthesis.member/left //runtime.tuple//left]
+ [/////synthesis.member/right //runtime.tuple//right])
+
+ (^ (/////synthesis.!bind_top register thenP))
+ (do ///////phase.monad
+ [then! (recur thenP)]
+ (///////phase\wrap ($_ _.then
+ (_.set (list (..register register)) ..peek_and_pop)
+ then!)))
+
+ (^ (/////synthesis.!multi_pop nextP))
+ (.let [[extra_pops nextP'] (case.count_pops nextP)]
+ (do ///////phase.monad
+ [next! (recur nextP')]
+ (///////phase\wrap ($_ _.then
+ (..multi_pop! (n.+ 2 extra_pops))
+ next!))))
+
+ (^ (/////synthesis.path/seq preP postP))
+ (do ///////phase.monad
+ [pre! (recur preP)
+ post! (recur postP)]
+ (wrap ($_ _.then
+ pre!
+ post!)))
+
+ (^ (/////synthesis.path/alt preP postP))
+ (do ///////phase.monad
+ [pre! (recur preP)
+ post! (recur postP)
+ g!once (..gensym "once")
+ g!continue? (..gensym "continue")]
+ (wrap (..alternation in_closure? g!once g!continue? pre! post!)))
+
+ _
+ (undefined))))))
+
+(def: (pattern_matching in_closure? statement expression archive pathP)
+ (-> Bit (Generator! Path))
+ (do ///////phase.monad
+ [pattern_matching! (pattern_matching' in_closure? statement expression archive pathP)
+ g!once (..gensym "once")
+ g!continue? (..gensym "continue")]
+ (wrap ($_ _.then
+ (..with_looping in_closure? g!once g!continue?
+ pattern_matching!)
+ (_.statement (_.raise (_.string case.pattern_matching_error)))))))
+
+(def: #export (case! in_closure? statement expression archive [valueS pathP])
+ (-> Bit (Generator! [Synthesis Path]))
+ (do ///////phase.monad
+ [stack_init (expression archive valueS)
+ pattern_matching! (pattern_matching in_closure? statement expression archive pathP)]
+ (wrap ($_ _.then
+ (_.set (list @cursor) (_.array (list stack_init)))
+ (_.set (list @savepoint) (_.array (list)))
+ pattern_matching!
+ ))))
+
+(def: #export (case statement expression archive case)
+ (-> Phase! (Generator [Synthesis Path]))
+ (|> case
+ (case! true statement expression archive)
+ (\ ///////phase.monad map
+ (|>> (_.lambda #.None (list))
+ (_.apply_lambda/* (list))))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux
new file mode 100644
index 000000000..af7906c9c
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux
@@ -0,0 +1,112 @@
+(.module:
+ [library
+ [lux (#- function)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [target
+ ["_" ruby (#+ LVar GVar Expression Statement)]]]]
+ ["." // #_
+ [runtime (#+ Operation Phase Generator Phase! Generator!)]
+ ["#." reference]
+ ["#." case]
+ ["#." loop]
+ ["/#" // #_
+ ["#." reference]
+ ["//#" /// #_
+ [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)]
+ [synthesis (#+ Synthesis)]
+ ["#." generation (#+ Context)]
+ ["//#" /// #_
+ [arity (#+ Arity)]
+ ["#." phase]
+ [reference
+ [variable (#+ Register Variable)]]
+ [meta
+ [archive (#+ Archive)
+ ["." artifact]]]]]]])
+
+(def: #export (apply expression archive [functionS argsS+])
+ (Generator (Application Synthesis))
+ (do {! ///////phase.monad}
+ [functionO (expression archive functionS)
+ argsO+ (monad.map ! (expression archive) argsS+)]
+ (wrap (_.apply_lambda/* argsO+ functionO))))
+
+(def: #export capture
+ (-> Register LVar)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: (with_closure inits self function_definition)
+ (-> (List Expression) Text Expression [Statement Expression])
+ (case inits
+ #.Nil
+ (let [@self (_.global self)]
+ [(_.set (list @self) function_definition)
+ @self])
+
+ _
+ (let [@self (_.local self)]
+ [(_.function @self
+ (|> (list.enumeration inits)
+ (list\map (|>> product.left ..capture)))
+ ($_ _.then
+ (_.set (list @self) function_definition)
+ (_.return @self)))
+ (_.apply/* inits @self)])))
+
+(def: input
+ (|>> inc //case.register))
+
+(def: #export (function statement expression archive [environment arity bodyS])
+ (-> Phase! (Generator (Abstraction Synthesis)))
+ (do {! ///////phase.monad}
+ [[[function_module function_artifact] body!] (/////generation.with_new_context archive
+ (/////generation.with_anchor 1
+ (statement expression archive bodyS)))
+ closureO+ (monad.map ! (expression archive) environment)
+ #let [function_name (///reference.artifact [function_module function_artifact])
+ @curried (_.local "curried")
+ arityO (|> arity .int _.int)
+ limitO (|> arity dec .int _.int)
+ @num_args (_.local "num_args")
+ @self (_.local function_name)
+ initialize_self! (_.set (list (//case.register 0)) @self)
+ initialize! (list\fold (.function (_ post pre!)
+ ($_ _.then
+ pre!
+ (_.set (list (..input post)) (_.nth (|> post .int _.int) @curried))))
+ initialize_self!
+ (list.indices arity))
+ [declaration instatiation] (with_closure closureO+ function_name
+ (_.lambda (#.Some @self) (list (_.variadic @curried))
+ ($_ _.then
+ (_.set (list @num_args) (_.the "length" @curried))
+ (_.cond (list [(|> @num_args (_.= arityO))
+ (<| (_.then initialize!)
+ //loop.with_scope
+ body!)]
+ [(|> @num_args (_.> arityO))
+ (let [slice (.function (_ from to)
+ (_.array_range from to @curried))
+ arity_args (_.splat (slice (_.int +0) limitO))
+ output_func_args (_.splat (slice arityO @num_args))]
+ (_.return (|> @self
+ (_.apply_lambda/* (list arity_args))
+ (_.apply_lambda/* (list output_func_args)))))])
+ ## (|> @num_args (_.< arityO))
+ (let [@missing (_.local "missing")]
+ (_.return (_.lambda #.None (list (_.variadic @missing))
+ (_.return (|> @self
+ (_.apply_lambda/* (list (_.splat (|> (_.array (list))
+ (_.do "concat" (list @curried))
+ (_.do "concat" (list @missing))))))))))))
+ )))]
+ _ (/////generation.execute! declaration)
+ _ (/////generation.save! function_artifact declaration)]
+ (wrap instatiation)))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux
new file mode 100644
index 000000000..c1639df6a
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux
@@ -0,0 +1,96 @@
+(.module:
+ [library
+ [lux (#- Scope)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." set]]]
+ [math
+ [number
+ ["n" nat]]]
+ [target
+ ["_" ruby (#+ Expression LVar Statement)]]]]
+ ["." // #_
+ [runtime (#+ Operation Phase Generator Phase! Generator!)]
+ ["#." case]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ [synthesis
+ ["." case]]
+ ["/#" // #_
+ ["." synthesis (#+ Scope Synthesis)]
+ ["#." generation]
+ ["//#" /// #_
+ ["#." phase]
+ [reference
+ ["#." variable (#+ Register)]]]]]]])
+
+(def: (setup offset bindings body)
+ (-> Register (List Expression) Statement Statement)
+ (|> bindings
+ list.enumeration
+ (list\map (function (_ [register value])
+ (_.set (list (//case.register (n.+ offset register)))
+ value)))
+ list.reverse
+ (list\fold _.then body)))
+
+(def: symbol
+ (_.symbol "lux_continue"))
+
+(def: #export with_scope
+ (-> Statement Statement)
+ (_.while (_.bool true)))
+
+(def: #export (scope! statement expression archive [start initsS+ bodyS])
+ (Generator! (Scope Synthesis))
+ (case initsS+
+ ## function/false/non-independent loop
+ #.Nil
+ (statement expression archive bodyS)
+
+ ## true loop
+ _
+ (do {! ///////phase.monad}
+ [initsO+ (monad.map ! (expression archive) initsS+)
+ body! (/////generation.with_anchor start
+ (statement expression archive bodyS))]
+ (wrap (<| (..setup start initsO+)
+ ..with_scope
+ body!)))))
+
+(def: #export (scope statement expression archive [start initsS+ bodyS])
+ (-> Phase! (Generator (Scope Synthesis)))
+ (case initsS+
+ ## function/false/non-independent loop
+ #.Nil
+ (expression archive bodyS)
+
+ ## true loop
+ _
+ (do {! ///////phase.monad}
+ [body! (scope! statement expression archive [start initsS+ bodyS])]
+ (wrap (|> body!
+ (_.lambda #.None (list))
+ (_.apply_lambda/* (list)))))))
+
+(def: #export (recur! statement expression archive argsS+)
+ (Generator! (List Synthesis))
+ (do {! ///////phase.monad}
+ [offset /////generation.anchor
+ @temp (//case.gensym "lux_recur_values")
+ argsO+ (monad.map ! (expression archive) argsS+)
+ #let [re_binds (|> argsO+
+ list.enumeration
+ (list\map (function (_ [idx _])
+ (_.nth (_.int (.int idx)) @temp))))]]
+ (wrap ($_ _.then
+ (_.set (list @temp) (_.array argsO+))
+ (..setup offset re_binds
+ _.next)))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux
new file mode 100644
index 000000000..0f01d2455
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux
@@ -0,0 +1,16 @@
+(.module:
+ [library
+ [lux (#- i64)
+ [target
+ ["_" ruby (#+ Literal)]]]])
+
+(template [<type> <name> <implementation>]
+ [(def: #export <name>
+ (-> <type> Literal)
+ <implementation>)]
+
+ [Bit bit _.bool]
+ [(I64 Any) i64 (|>> .int _.int)]
+ [Frac f64 _.float]
+ [Text text _.string]
+ )
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux
new file mode 100644
index 000000000..a54e6da57
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux
@@ -0,0 +1,13 @@
+(.module:
+ [library
+ [lux #*
+ [target
+ ["_" ruby (#+ Expression)]]]]
+ [///
+ [reference (#+ System)]])
+
+(implementation: #export system
+ (System Expression)
+
+ (def: constant _.global)
+ (def: variable _.local))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux
new file mode 100644
index 000000000..2ce60a9a1
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux
@@ -0,0 +1,403 @@
+(.module:
+ [library
+ [lux (#- inc)
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<.>" code]]]
+ [data
+ ["." product]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." row]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number (#+ hex)
+ ["." i64]]]
+ ["@" target
+ ["_" ruby (#+ Expression LVar Computation Literal Statement)]]]]
+ ["." /// #_
+ ["#." reference]
+ ["//#" /// #_
+ ["$" version]
+ ["#." synthesis (#+ Synthesis)]
+ ["#." generation]
+ ["//#" ///
+ ["#." phase]
+ [reference
+ [variable (#+ Register)]]
+ [meta
+ [archive (#+ Output Archive)
+ ["." artifact (#+ Registry)]]]]]])
+
+(template [<name> <base>]
+ [(type: #export <name>
+ (<base> Register Expression Statement))]
+
+ [Operation /////generation.Operation]
+ [Phase /////generation.Phase]
+ [Handler /////generation.Handler]
+ [Bundle /////generation.Bundle]
+ )
+
+(type: #export (Generator i)
+ (-> Phase Archive i (Operation Expression)))
+
+(type: #export Phase!
+ (-> Phase Archive Synthesis (Operation Statement)))
+
+(type: #export (Generator! i)
+ (-> Phase! Phase Archive i (Operation Statement)))
+
+(def: #export unit
+ (_.string /////synthesis.unit))
+
+(def: (flag value)
+ (-> Bit Literal)
+ (if value
+ ..unit
+ _.nil))
+
+(def: (feature name definition)
+ (-> LVar (-> LVar Statement) Statement)
+ (definition name))
+
+(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
+ body)
+ (do {! meta.monad}
+ [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
+ (wrap (list (` (let [(~+ (|> vars
+ (list.zip/2 ids)
+ (list\map (function (_ [id var])
+ (list (code.local_identifier var)
+ (` (_.local (~ (code.text (format "v" (%.nat id)))))))))
+ list.concat))]
+ (~ body)))))))
+
+(def: module_id
+ 0)
+
+(syntax: (runtime: {declaration (<>.or <code>.local_identifier
+ (<code>.form (<>.and <code>.local_identifier
+ (<>.some <code>.local_identifier))))}
+ code)
+ (do meta.monad
+ [runtime_id meta.count]
+ (macro.with_gensyms [g!_]
+ (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id]))
+ runtime_name (` (_.local (~ (code.text (%.code runtime)))))]
+ (case declaration
+ (#.Left name)
+ (macro.with_gensyms [g!_]
+ (let [g!name (code.local_identifier name)]
+ (wrap (list (` (def: #export (~ g!name) LVar (~ runtime_name)))
+ (` (def: (~ (code.local_identifier (format "@" name)))
+ Statement
+ (..feature (~ runtime_name)
+ (function ((~ g!_) (~ g!name))
+ (_.set (list (~ g!name)) (~ code))))))))))
+
+ (#.Right [name inputs])
+ (macro.with_gensyms [g!_]
+ (let [g!name (code.local_identifier name)
+ inputsC (list\map code.local_identifier inputs)
+ inputs_typesC (list\map (function.constant (` _.Expression))
+ inputs)]
+ (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
+ (-> (~+ inputs_typesC) Computation)
+ (_.apply/* (list (~+ inputsC)) (~ runtime_name))))
+
+ (` (def: (~ (code.local_identifier (format "@" name)))
+ Statement
+ (..feature (~ runtime_name)
+ (function ((~ g!_) (~ g!_))
+ (..with_vars [(~+ inputsC)]
+ (_.function (~ g!_) (list (~+ inputsC))
+ (~ code))))))))))))))))
+
+(def: tuple_size
+ (_.the "length"))
+
+(def: last_index
+ (|>> ..tuple_size (_.- (_.int +1))))
+
+(with_expansions [<recur> (as_is ($_ _.then
+ (_.set (list lefts) (_.- last_index_right lefts))
+ (_.set (list tuple) (_.nth last_index_right tuple))))]
+ (runtime: (tuple//left lefts tuple)
+ (with_vars [last_index_right]
+ (<| (_.while (_.bool true))
+ ($_ _.then
+ (_.set (list last_index_right) (..last_index tuple))
+ (_.if (_.> lefts last_index_right)
+ ## No need for recursion
+ (_.return (_.nth lefts tuple))
+ ## Needs recursion
+ <recur>)))))
+
+ (runtime: (tuple//right lefts tuple)
+ (with_vars [last_index_right right_index]
+ (<| (_.while (_.bool true))
+ ($_ _.then
+ (_.set (list last_index_right) (..last_index tuple))
+ (_.set (list right_index) (_.+ (_.int +1) lefts))
+ (_.cond (list [(_.= last_index_right right_index)
+ (_.return (_.nth right_index tuple))]
+ [(_.> last_index_right right_index)
+ ## Needs recursion.
+ <recur>])
+ (_.return (_.array_range right_index (..tuple_size tuple) tuple)))
+ )))))
+
+(def: #export variant_tag_field "_lux_tag")
+(def: #export variant_flag_field "_lux_flag")
+(def: #export variant_value_field "_lux_value")
+
+(runtime: (sum//make tag last? value)
+ (_.return (_.hash (list [(_.string ..variant_tag_field) tag]
+ [(_.string ..variant_flag_field) last?]
+ [(_.string ..variant_value_field) value]))))
+
+(def: #export (variant tag last? value)
+ (-> Nat Bit Expression Computation)
+ (sum//make (_.int (.int tag)) (..flag last?) value))
+
+(def: #export none
+ Computation
+ (..variant 0 #0 ..unit))
+
+(def: #export some
+ (-> Expression Computation)
+ (..variant 1 #1))
+
+(def: #export left
+ (-> Expression Computation)
+ (..variant 0 #0))
+
+(def: #export right
+ (-> Expression Computation)
+ (..variant 1 #1))
+
+(runtime: (sum//get sum wantsLast wantedTag)
+ (let [no_match! (_.return _.nil)
+ sum_tag (_.nth (_.string ..variant_tag_field) sum)
+ sum_flag (_.nth (_.string ..variant_flag_field) sum)
+ sum_value (_.nth (_.string ..variant_value_field) sum)
+ is_last? (_.= ..unit sum_flag)
+ test_recursion! (_.if is_last?
+ ## Must recurse.
+ ($_ _.then
+ (_.set (list wantedTag) (_.- sum_tag wantedTag))
+ (_.set (list sum) sum_value))
+ no_match!)]
+ (<| (_.while (_.bool true))
+ (_.cond (list [(_.= sum_tag wantedTag)
+ (_.if (_.= wantsLast sum_flag)
+ (_.return sum_value)
+ test_recursion!)]
+
+ [(_.< wantedTag sum_tag)
+ test_recursion!]
+
+ [(_.= ..unit wantsLast)
+ (_.return (sum//make (_.- wantedTag sum_tag) sum_flag sum_value))])
+
+ no_match!))))
+
+(def: runtime//adt
+ Statement
+ ($_ _.then
+ @tuple//left
+ @tuple//right
+ @sum//make
+ @sum//get
+ ))
+
+(runtime: (lux//try risky)
+ (with_vars [error value]
+ (_.begin ($_ _.then
+ (_.set (list value) (_.apply_lambda/* (list ..unit) risky))
+ (_.return (..right value)))
+ (list [(list) error
+ (_.return (..left (_.the "message" error)))]))))
+
+(runtime: (lux//program_args raw)
+ (with_vars [tail head]
+ ($_ _.then
+ (_.set (list tail) ..none)
+ (<| (_.for_in head raw)
+ (_.set (list tail) (..some (_.array (list head tail)))))
+ (_.return tail))))
+
+(def: runtime//lux
+ Statement
+ ($_ _.then
+ @lux//try
+ @lux//program_args
+ ))
+
+(def: i64//+limit (_.manual "+0x7FFFFFFFFFFFFFFF"))
+(def: i64//-limit (_.manual "-0x8000000000000000"))
+(def: i64//+iteration (_.manual "+0x10000000000000000"))
+(def: i64//-iteration (_.manual "-0x10000000000000000"))
+(def: i64//+cap (_.manual "+0x8000000000000000"))
+(def: i64//-cap (_.manual "-0x8000000000000001"))
+
+(runtime: (i64//64 input)
+ (with_vars [temp]
+ (`` (<| (~~ (template [<scenario> <iteration> <cap> <entrance>]
+ [(_.if (|> input <scenario>)
+ ($_ _.then
+ (_.set (list temp) (_.% <iteration> input))
+ (_.return (_.? (|> temp <scenario>)
+ (|> temp (_.- <cap>) (_.+ <entrance>))
+ temp))))]
+
+ [(_.> ..i64//+limit) ..i64//+iteration ..i64//+cap ..i64//-limit]
+ [(_.< ..i64//-limit) ..i64//-iteration ..i64//-cap ..i64//+limit]
+ ))
+ (_.return input)))))
+
+(runtime: i64//nat_top
+ (|> (_.int +1)
+ (_.bit_shl (_.int +64))
+ (_.- (_.int +1))))
+
+(def: as_nat
+ (_.% (_.manual "0x10000000000000000")))
+
+(runtime: (i64//left_shift param subject)
+ (_.return (|> subject
+ (_.bit_shl (_.% (_.int +64) param))
+ ..i64//64)))
+
+(runtime: (i64//right_shift param subject)
+ ($_ _.then
+ (_.set (list param) (_.% (_.int +64) param))
+ (_.return (_.? (_.= (_.int +0) param)
+ subject
+ (|> subject
+ ..as_nat
+ (_.bit_shr param))))))
+
+(template [<runtime> <host>]
+ [(runtime: (<runtime> left right)
+ (_.return (..i64//64 (<host> (..as_nat left) (..as_nat right)))))]
+
+ [i64//and _.bit_and]
+ [i64//or _.bit_or]
+ [i64//xor _.bit_xor]
+ )
+
+(runtime: (i64//division parameter subject)
+ (let [extra (_.do "remainder" (list parameter) subject)]
+ (_.return (|> subject
+ (_.- extra)
+ (_./ parameter)))))
+
+(def: runtime//i64
+ Statement
+ ($_ _.then
+ @i64//64
+ @i64//nat_top
+ @i64//left_shift
+ @i64//right_shift
+ @i64//and
+ @i64//or
+ @i64//xor
+ @i64//division
+ ))
+
+(runtime: (f64//decode inputG)
+ (with_vars [@input @temp]
+ ($_ _.then
+ (_.set (list @input) inputG)
+ (_.set (list @temp) (_.do "to_f" (list) @input))
+ (_.if ($_ _.or
+ (_.not (_.= (_.float +0.0) @temp))
+ (_.= (_.string "0") @input)
+ (_.= (_.string ".0") @input)
+ (_.= (_.string "0.0") @input))
+ (_.return (..some @temp))
+ (_.return ..none)))))
+
+(def: runtime//f64
+ Statement
+ ($_ _.then
+ @f64//decode
+ ))
+
+(runtime: (text//index subject param start)
+ (with_vars [idx]
+ ($_ _.then
+ (_.set (list idx) (|> subject (_.do "index" (list param start))))
+ (_.if (_.= _.nil idx)
+ (_.return ..none)
+ (_.return (..some idx))))))
+
+(def: (within? top value)
+ (-> Expression Expression Computation)
+ (_.and (|> value (_.>= (_.int +0)))
+ (|> value (_.< top))))
+
+(runtime: (text//clip offset length text)
+ (_.if (_.= (_.int +0) length)
+ (_.return (_.string ""))
+ (_.return (_.array_range offset (_.+ offset (_.- (_.int +1) length)) text))))
+
+(runtime: (text//char idx text)
+ (_.if (|> idx (within? (_.the "length" text)))
+ (_.return (|> text (_.array_range idx idx) (_.do "ord" (list))))
+ (_.statement (_.raise (_.string "[Lux Error] Cannot get char from text.")))))
+
+(def: runtime//text
+ Statement
+ ($_ _.then
+ @text//index
+ @text//clip
+ @text//char
+ ))
+
+(runtime: (array//write idx value array)
+ ($_ _.then
+ (_.set (list (_.nth idx array)) value)
+ (_.return array)))
+
+(def: runtime//array
+ Statement
+ ($_ _.then
+ @array//write
+ ))
+
+(def: runtime
+ Statement
+ ($_ _.then
+ runtime//adt
+ runtime//lux
+ runtime//i64
+ runtime//f64
+ runtime//text
+ runtime//array
+ ))
+
+(def: #export generate
+ (Operation [Registry Output])
+ (do ///////phase.monad
+ [_ (/////generation.execute! ..runtime)
+ _ (/////generation.save! ..module_id ..runtime)]
+ (wrap [(|> artifact.empty
+ artifact.resource
+ product.right)
+ (row.row [..module_id
+ (|> ..runtime
+ _.code
+ (\ utf8.codec encode))])])))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux
new file mode 100644
index 000000000..c172b43b8
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux
@@ -0,0 +1,37 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [target
+ ["_" ruby (#+ Expression)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." primitive]
+ ["///#" //// #_
+ [analysis (#+ Variant Tuple)]
+ ["#." synthesis (#+ Synthesis)]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]]]])
+
+(def: #export (tuple generate archive elemsS+)
+ (Generator (Tuple Synthesis))
+ (case elemsS+
+ #.Nil
+ (///////phase\wrap (//primitive.text /////synthesis.unit))
+
+ (#.Cons singletonS #.Nil)
+ (generate archive singletonS)
+
+ _
+ (|> elemsS+
+ (monad.map ///////phase.monad (generate archive))
+ (///////phase\map _.array))))
+
+(def: #export (variant generate archive [lefts right? valueS])
+ (Generator (Variant Synthesis))
+ (let [tag (if right?
+ (inc lefts)
+ lefts)]
+ (///////phase\map (//runtime.variant tag right?)
+ (generate archive valueS))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme.lux
new file mode 100644
index 000000000..98f7b88bb
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme.lux
@@ -0,0 +1,59 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [target
+ ["_" scheme]]]]
+ ["." / #_
+ [runtime (#+ Phase)]
+ ["#." primitive]
+ ["#." structure]
+ ["#." reference]
+ ["#." case]
+ ["#." loop]
+ ["#." function]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." extension]
+ ["/#" // #_
+ [analysis (#+)]
+ ["#." synthesis]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]
+ [reference (#+)
+ [variable (#+)]]]]]]])
+
+(def: #export (generate archive synthesis)
+ Phase
+ (case synthesis
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (//////phase\wrap (<generator> value))])
+ ([////synthesis.bit /primitive.bit]
+ [////synthesis.i64 /primitive.i64]
+ [////synthesis.f64 /primitive.f64]
+ [////synthesis.text /primitive.text])
+
+ (#////synthesis.Reference value)
+ (//reference.reference /reference.system archive value)
+
+ (^template [<tag> <generator>]
+ [(^ (<tag> value))
+ (<generator> generate archive value)])
+ ([////synthesis.variant /structure.variant]
+ [////synthesis.tuple /structure.tuple]
+ [////synthesis.branch/let /case.let]
+ [////synthesis.branch/if /case.if]
+ [////synthesis.branch/get /case.get]
+ [////synthesis.function/apply /function.apply]
+
+ [////synthesis.branch/case /case.case]
+ [////synthesis.loop/scope /loop.scope]
+ [////synthesis.loop/recur /loop.recur]
+ [////synthesis.function/abstraction /function.function])
+
+ (#////synthesis.Extension extension)
+ (///extension.apply archive generate extension)
+ ))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux
new file mode 100644
index 000000000..99d115b9d
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux
@@ -0,0 +1,223 @@
+(.module:
+ [library
+ [lux (#- case let if)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." set]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["i" int]]]
+ [target
+ ["_" scheme (#+ Expression Computation Var)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." reference]
+ ["#." primitive]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ ["#." synthesis #_
+ ["#/." case]]
+ ["/#" // #_
+ ["#." synthesis (#+ Member Synthesis Path)]
+ ["#." generation]
+ ["//#" /// #_
+ [reference
+ ["#." variable (#+ Register)]]
+ ["#." phase ("#\." monad)]
+ [meta
+ [archive (#+ Archive)]]]]]]])
+
+(def: #export register
+ (-> Register Var)
+ (|>> (///reference.local //reference.system) :assume))
+
+(def: #export capture
+ (-> Register Var)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: #export (let expression archive [valueS register bodyS])
+ (Generator [Synthesis Register Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)
+ bodyO (expression archive bodyS)]
+ (wrap (_.let (list [(..register register) valueO])
+ bodyO))))
+
+(def: #export (if expression archive [testS thenS elseS])
+ (Generator [Synthesis Synthesis Synthesis])
+ (do ///////phase.monad
+ [testO (expression archive testS)
+ thenO (expression archive thenS)
+ elseO (expression archive elseS)]
+ (wrap (_.if testO thenO elseO))))
+
+(def: #export (get expression archive [pathP valueS])
+ (Generator [(List Member) Synthesis])
+ (do ///////phase.monad
+ [valueO (expression archive valueS)]
+ (wrap (list\fold (function (_ side source)
+ (.let [method (.case side
+ (^template [<side> <accessor>]
+ [(<side> lefts)
+ (<accessor> (_.int (.int lefts)))])
+ ([#.Left //runtime.tuple//left]
+ [#.Right //runtime.tuple//right]))]
+ (method source)))
+ valueO
+ (list.reverse pathP)))))
+
+(def: @savepoint (_.var "lux_pm_cursor_savepoint"))
+(def: @cursor (_.var "lux_pm_cursor"))
+(def: @temp (_.var "lux_pm_temp"))
+(def: @alt_error (_.var "alt_error"))
+
+(def: (push! value var)
+ (-> Expression Var Computation)
+ (_.set! var (_.cons/2 value var)))
+
+(def: (push_cursor! value)
+ (-> Expression Computation)
+ (push! value @cursor))
+
+(def: (pop! var)
+ (-> Var Computation)
+ (_.set! var (_.cdr/1 var)))
+
+(def: save_cursor!
+ Computation
+ (push! @cursor @savepoint))
+
+(def: restore_cursor!
+ Computation
+ (_.begin (list (_.set! @cursor (_.car/1 @savepoint))
+ (_.set! @savepoint (_.cdr/1 @savepoint)))))
+
+(def: peek
+ Computation
+ (_.car/1 @cursor))
+
+(def: pop_cursor!
+ Computation
+ (pop! @cursor))
+
+(def: pm_error
+ (_.string (template.with_locals [pm_error]
+ (template.text [pm_error]))))
+
+(def: fail!
+ (_.raise/1 pm_error))
+
+(def: (try_pm on_failure happy_path)
+ (-> Expression Expression Computation)
+ (_.guard @alt_error
+ (list [(_.and (list (_.string?/1 @alt_error)
+ (_.string=?/2 ..pm_error @alt_error)))
+ on_failure])
+ #.None
+ happy_path))
+
+(def: (pattern_matching' expression archive)
+ (Generator Path)
+ (function (recur pathP)
+ (.case pathP
+ (#/////synthesis.Then bodyS)
+ (expression archive bodyS)
+
+ #/////synthesis.Pop
+ (///////phase\wrap pop_cursor!)
+
+ (#/////synthesis.Bind register)
+ (///////phase\wrap (_.define_constant (..register register) ..peek))
+
+ (#/////synthesis.Bit_Fork when thenP elseP)
+ (do {! ///////phase.monad}
+ [then! (recur thenP)
+ else! (.case elseP
+ (#.Some elseP)
+ (recur elseP)
+
+ #.None
+ (wrap ..fail!))]
+ (wrap (.if when
+ (_.if ..peek
+ then!
+ else!)
+ (_.if ..peek
+ else!
+ then!))))
+
+ (^template [<tag> <format> <=>]
+ [(<tag> cons)
+ (do {! ///////phase.monad}
+ [clauses (monad.map ! (function (_ [match then])
+ (do !
+ [then! (recur then)]
+ (wrap [(<=> (|> match <format>)
+ ..peek)
+ then!])))
+ (#.Cons cons))]
+ (wrap (list\fold (function (_ [when then] else)
+ (_.if when then else))
+ ..fail!
+ clauses)))])
+ ([#/////synthesis.I64_Fork //primitive.i64 _.=/2]
+ [#/////synthesis.F64_Fork //primitive.f64 _.=/2]
+ [#/////synthesis.Text_Fork //primitive.text _.string=?/2])
+
+ (^template [<pm> <flag> <prep>]
+ [(^ (<pm> idx))
+ (///////phase\wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek (_.bool <flag>)))])
+ (_.if (_.null?/1 @temp)
+ ..fail!
+ (push_cursor! @temp))))])
+ ([/////synthesis.side/left false (<|)]
+ [/////synthesis.side/right true inc])
+
+ (^ (/////synthesis.member/left 0))
+ (///////phase\wrap (..push_cursor! (_.vector-ref/2 ..peek (_.int +0))))
+
+ (^template [<pm> <getter>]
+ [(^ (<pm> lefts))
+ (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push_cursor!))])
+ ([/////synthesis.member/left //runtime.tuple//left]
+ [/////synthesis.member/right //runtime.tuple//right])
+
+ (^ (/////synthesis.path/seq leftP rightP))
+ (do ///////phase.monad
+ [leftO (recur leftP)
+ rightO (recur rightP)]
+ (wrap (_.begin (list leftO
+ rightO))))
+
+ (^ (/////synthesis.path/alt leftP rightP))
+ (do {! ///////phase.monad}
+ [leftO (recur leftP)
+ rightO (recur rightP)]
+ (wrap (try_pm (_.begin (list restore_cursor!
+ rightO))
+ (_.begin (list save_cursor!
+ leftO)))))
+ )))
+
+(def: (pattern_matching expression archive pathP)
+ (Generator Path)
+ (\ ///////phase.monad map
+ (try_pm (_.raise/1 (_.string "Invalid expression for pattern-matching.")))
+ (pattern_matching' expression archive pathP)))
+
+(def: #export (case expression archive [valueS pathP])
+ (Generator [Synthesis Path])
+ (do {! ///////phase.monad}
+ [valueO (expression archive valueS)]
+ (<| (\ ! map (_.let (list [@cursor (_.list/* (list valueO))]
+ [@savepoint (_.list/* (list))])))
+ (pattern_matching expression archive pathP))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux
new file mode 100644
index 000000000..1880d7700
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux
@@ -0,0 +1,14 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]]
+ [//
+ [runtime (#+ Bundle)]]
+ [/
+ ["." common]])
+
+(def: #export bundle
+ Bundle
+ common.bundle)
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux
new file mode 100644
index 000000000..0275e8cd9
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux
@@ -0,0 +1,223 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["ex" exception (#+ exception:)]
+ [parser
+ ["s" code]]]
+ [data
+ ["." product]
+ ["." text]
+ [number (#+ hex)
+ ["f" frac]]
+ [collection
+ ["." list ("#\." functor)]
+ ["dict" dictionary (#+ Dictionary)]]]
+ ["." macro (#+ with-gensyms)
+ ["." code]
+ [syntax (#+ syntax:)]]
+ [target
+ ["_" scheme (#+ Expression Computation)]]]]
+ ["." /// #_
+ ["#." runtime (#+ Operation Phase Handler Bundle)]
+ ["#//" ///
+ ["#." extension
+ ["." bundle]]
+ ["#/" // #_
+ ["#." synthesis (#+ Synthesis)]]]])
+
+(syntax: (Vector {size s.nat} elemT)
+ (wrap (list (` [(~+ (list.repeat size elemT))]))))
+
+(type: #export Nullary (-> (Vector 0 Expression) Computation))
+(type: #export Unary (-> (Vector 1 Expression) Computation))
+(type: #export Binary (-> (Vector 2 Expression) Computation))
+(type: #export Trinary (-> (Vector 3 Expression) Computation))
+(type: #export Variadic (-> (List Expression) Computation))
+
+(syntax: (arity: {name s.local-identifier} {arity s.nat})
+ (with-gensyms [g!_ g!extension g!name g!phase g!inputs]
+ (do {! macro.monad}
+ [g!input+ (monad.seq ! (list.repeat arity (macro.gensym "input")))]
+ (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension))
+ (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation)
+ Handler)
+ (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs))
+ (case (~ g!inputs)
+ (^ (list (~+ g!input+)))
+ (do /////.monad
+ [(~+ (|> g!input+
+ (list\map (function (_ g!input)
+ (list g!input (` ((~ g!phase) (~ g!input))))))
+ list.concat))]
+ ((~' wrap) ((~ g!extension) [(~+ g!input+)])))
+
+ (~' _)
+ (/////.throw /////extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))]))))))))))
+
+(arity: nullary 0)
+(arity: unary 1)
+(arity: binary 2)
+(arity: trinary 3)
+
+(def: #export (variadic extension)
+ (-> Variadic Handler)
+ (function (_ extension-name)
+ (function (_ phase inputsS)
+ (do {! /////.monad}
+ [inputsI (monad.map ! phase inputsS)]
+ (wrap (extension inputsI))))))
+
+(def: bundle::lux
+ Bundle
+ (|> bundle.empty
+ (bundle.install "is?" (binary (product.uncurry _.eq?/2)))
+ (bundle.install "try" (unary ///runtime.lux//try))))
+
+(template [<name> <op>]
+ [(def: (<name> [subjectO paramO])
+ Binary
+ (<op> paramO subjectO))]
+
+ [i64::and _.bit-and/2]
+ [i64::or _.bit-or/2]
+ [i64::xor _.bit-xor/2]
+ )
+
+(def: (i64::left-shift [subjectO paramO])
+ Binary
+ (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO)
+ subjectO))
+
+(def: (i64::arithmetic-right-shift [subjectO paramO])
+ Binary
+ (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1)))
+ subjectO))
+
+(def: (i64::logical-right-shift [subjectO paramO])
+ Binary
+ (///runtime.i64//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO))
+
+(template [<name> <op>]
+ [(def: (<name> [subjectO paramO])
+ Binary
+ (|> subjectO (<op> paramO)))]
+
+ [i64::+ _.+/2]
+ [i64::- _.-/2]
+ [i64::* _.*/2]
+ [i64::/ _.quotient/2]
+ [i64::% _.remainder/2]
+ )
+
+(template [<name> <op>]
+ [(def: (<name> [subjectO paramO])
+ Binary
+ (<op> paramO subjectO))]
+
+ [f64::+ _.+/2]
+ [f64::- _.-/2]
+ [f64::* _.*/2]
+ [f64::/ _.//2]
+ [f64::% _.mod/2]
+ [f64::= _.=/2]
+ [f64::< _.</2]
+
+ [text::= _.string=?/2]
+ [text::< _.string<?/2]
+ )
+
+(template [<name> <cmp>]
+ [(def: (<name> [subjectO paramO])
+ Binary
+ (<cmp> paramO subjectO))]
+
+ [i64::= _.=/2]
+ [i64::< _.</2]
+ )
+
+(def: i64::char (|>> _.integer->char/1 _.string/1))
+
+(def: bundle::i64
+ Bundle
+ (<| (bundle.prefix "i64")
+ (|> bundle.empty
+ (bundle.install "and" (binary i64::and))
+ (bundle.install "or" (binary i64::or))
+ (bundle.install "xor" (binary i64::xor))
+ (bundle.install "left-shift" (binary i64::left-shift))
+ (bundle.install "logical-right-shift" (binary i64::logical-right-shift))
+ (bundle.install "arithmetic-right-shift" (binary i64::arithmetic-right-shift))
+ (bundle.install "+" (binary i64::+))
+ (bundle.install "-" (binary i64::-))
+ (bundle.install "*" (binary i64::*))
+ (bundle.install "/" (binary i64::/))
+ (bundle.install "%" (binary i64::%))
+ (bundle.install "=" (binary i64::=))
+ (bundle.install "<" (binary i64::<))
+ (bundle.install "f64" (unary (|>> (_.//2 (_.float +1.0)))))
+ (bundle.install "char" (unary i64::char)))))
+
+(def: bundle::f64
+ Bundle
+ (<| (bundle.prefix "f64")
+ (|> bundle.empty
+ (bundle.install "+" (binary f64::+))
+ (bundle.install "-" (binary f64::-))
+ (bundle.install "*" (binary f64::*))
+ (bundle.install "/" (binary f64::/))
+ (bundle.install "%" (binary f64::%))
+ (bundle.install "=" (binary f64::=))
+ (bundle.install "<" (binary f64::<))
+ (bundle.install "i64" (unary _.exact/1))
+ (bundle.install "encode" (unary _.number->string/1))
+ (bundle.install "decode" (unary ///runtime.frac//decode)))))
+
+(def: (text::char [subjectO paramO])
+ Binary
+ (_.string/1 (_.string-ref/2 subjectO paramO)))
+
+(def: (text::clip [subjectO startO endO])
+ Trinary
+ (_.substring/3 subjectO startO endO))
+
+(def: bundle::text
+ Bundle
+ (<| (bundle.prefix "text")
+ (|> bundle.empty
+ (bundle.install "=" (binary text::=))
+ (bundle.install "<" (binary text::<))
+ (bundle.install "concat" (binary (product.uncurry _.string-append/2)))
+ (bundle.install "size" (unary _.string-length/1))
+ (bundle.install "char" (binary text::char))
+ (bundle.install "clip" (trinary text::clip)))))
+
+(def: (io::log input)
+ Unary
+ (_.begin (list (_.display/1 input)
+ _.newline/0)))
+
+(def: (void code)
+ (-> Expression Computation)
+ (_.begin (list code (_.string //////synthesis.unit))))
+
+(def: bundle::io
+ Bundle
+ (<| (bundle.prefix "io")
+ (|> bundle.empty
+ (bundle.install "log" (unary (|>> io::log ..void)))
+ (bundle.install "error" (unary _.raise/1))
+ (bundle.install "exit" (unary _.exit/1))
+ (bundle.install "current-time" (nullary (function (_ _) (///runtime.io//current-time (_.string //////synthesis.unit))))))))
+
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "lux")
+ (|> bundle::lux
+ (dict.merge bundle::i64)
+ (dict.merge bundle::f64)
+ (dict.merge bundle::text)
+ (dict.merge bundle::io)
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux
new file mode 100644
index 000000000..b12ddcde3
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux
@@ -0,0 +1,101 @@
+(.module:
+ [library
+ [lux (#- function)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ pipe]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [target
+ ["_" scheme (#+ Expression Computation Var)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." reference]
+ ["#." case]
+ ["/#" // #_
+ ["#." reference]
+ ["//#" /// #_
+ [analysis (#+ Variant Tuple Abstraction Application Analysis)]
+ [synthesis (#+ Synthesis)]
+ ["#." generation (#+ Context)]
+ ["//#" /// #_
+ [arity (#+ Arity)]
+ ["#." phase ("#\." monad)]
+ [reference
+ [variable (#+ Register Variable)]]]]]])
+
+(def: #export (apply expression archive [functionS argsS+])
+ (Generator (Application Synthesis))
+ (do {! ///////phase.monad}
+ [functionO (expression archive functionS)
+ argsO+ (monad.map ! (expression archive) argsS+)]
+ (wrap (_.apply/* argsO+ functionO))))
+
+(def: capture
+ (-> Register Var)
+ (|>> (///reference.foreign //reference.system) :assume))
+
+(def: (with_closure inits function_definition)
+ (-> (List Expression) Computation (Operation Computation))
+ (///////phase\wrap
+ (case inits
+ #.Nil
+ function_definition
+
+ _
+ (|> function_definition
+ (_.lambda [(|> (list.enumeration inits)
+ (list\map (|>> product.left ..capture)))
+ #.None])
+ (_.apply/* inits)))))
+
+(def: @curried (_.var "curried"))
+(def: @missing (_.var "missing"))
+
+(def: input
+ (|>> inc //case.register))
+
+(def: #export (function expression archive [environment arity bodyS])
+ (Generator (Abstraction Synthesis))
+ (do {! ///////phase.monad}
+ [[function_name bodyO] (/////generation.with_new_context archive
+ (do !
+ [@self (\ ! map (|>> ///reference.artifact _.var)
+ (/////generation.context archive))]
+ (/////generation.with_anchor @self
+ (expression archive bodyS))))
+ closureO+ (monad.map ! (expression archive) environment)
+ #let [arityO (|> arity .int _.int)
+ apply_poly (.function (_ args func)
+ (_.apply/2 (_.var "apply") func args))
+ @num_args (_.var "num_args")
+ @self (_.var (///reference.artifact function_name))]]
+ (with_closure closureO+
+ (_.letrec (list [@self (_.lambda [(list) (#.Some @curried)]
+ (_.let (list [@num_args (_.length/1 @curried)])
+ (<| (_.if (|> @num_args (_.=/2 arityO))
+ (<| (_.let (list [(//case.register 0) @self]))
+ (_.let_values (list [[(|> (list.indices arity)
+ (list\map ..input))
+ #.None]
+ (_.apply/2 (_.var "apply") (_.var "values") @curried)]))
+ bodyO))
+ (_.if (|> @num_args (_.>/2 arityO))
+ (let [arity_args (//runtime.slice (_.int +0) arityO @curried)
+ output_func_args (//runtime.slice arityO
+ (|> @num_args (_.-/2 arityO))
+ @curried)]
+ (_.begin (list (|> @self
+ (apply_poly arity_args)
+ (apply_poly output_func_args))))))
+ ## (|> @num_args (_.</2 arityO))
+ (_.lambda [(list) (#.Some @missing)]
+ (|> @self
+ (apply_poly (_.append/2 @curried @missing)))))
+ ))])
+ @self))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux
new file mode 100644
index 000000000..23718bfc5
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux
@@ -0,0 +1,64 @@
+(.module:
+ [library
+ [lux (#- Scope)
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." set (#+ Set)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [target
+ ["_" scheme]]]]
+ ["." // #_
+ [runtime (#+ Operation Phase Generator)]
+ ["#." case]
+ ["/#" // #_
+ ["#." reference]
+ ["/#" // #_
+ [synthesis
+ ["." case]]
+ ["/#" // #_
+ ["."synthesis (#+ Scope Synthesis)]
+ ["#." generation]
+ ["//#" /// #_
+ ["#." phase]
+ [meta
+ [archive (#+ Archive)]]
+ [reference
+ [variable (#+ Register)]]]]]]])
+
+(def: @scope
+ (_.var "scope"))
+
+(def: #export (scope expression archive [start initsS+ bodyS])
+ (Generator (Scope Synthesis))
+ (case initsS+
+ ## function/false/non-independent loop
+ #.Nil
+ (expression archive bodyS)
+
+ ## true loop
+ _
+ (do {! ///////phase.monad}
+ [initsO+ (monad.map ! (expression archive) initsS+)
+ bodyO (/////generation.with_anchor @scope
+ (expression archive bodyS))]
+ (wrap (_.letrec (list [@scope (_.lambda [(|> initsS+
+ list.enumeration
+ (list\map (|>> product.left (n.+ start) //case.register)))
+ #.None]
+ bodyO)])
+ (_.apply/* initsO+ @scope))))))
+
+(def: #export (recur expression archive argsS+)
+ (Generator (List Synthesis))
+ (do {! ///////phase.monad}
+ [@scope /////generation.anchor
+ argsO+ (monad.map ! (expression archive) argsS+)]
+ (wrap (_.apply/* argsO+ @scope))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux
new file mode 100644
index 000000000..a7c2b81b6
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux
@@ -0,0 +1,16 @@
+(.module:
+ [library
+ [lux (#- i64)
+ [target
+ ["_" scheme (#+ Expression)]]]])
+
+(template [<name> <type> <code>]
+ [(def: #export <name>
+ (-> <type> Expression)
+ <code>)]
+
+ [bit Bit _.bool]
+ [i64 (I64 Any) (|>> .int _.int)]
+ [f64 Frac _.float]
+ [text Text _.string]
+ )
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux
new file mode 100644
index 000000000..19d46ba19
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux
@@ -0,0 +1,13 @@
+(.module:
+ [library
+ [lux #*
+ [target
+ ["_" scheme (#+ Expression)]]]]
+ [///
+ [reference (#+ System)]])
+
+(implementation: #export system
+ (System Expression)
+
+ (def: constant _.var)
+ (def: variable _.var))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux
new file mode 100644
index 000000000..ec3def7fd
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux
@@ -0,0 +1,370 @@
+(.module:
+ [library
+ [lux (#- Location inc)
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["<>" parser
+ ["<.>" code]]]
+ [data
+ ["." product]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." row]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number (#+ hex)
+ ["." i64]]]
+ ["@" target
+ ["_" scheme (#+ Expression Computation Var)]]]]
+ ["." /// #_
+ ["#." reference]
+ ["//#" /// #_
+ [analysis (#+ Variant)]
+ ["#." synthesis (#+ Synthesis)]
+ ["#." generation]
+ ["//#" ///
+ ["#." phase]
+ [reference
+ [variable (#+ Register)]]
+ [meta
+ [archive (#+ Output Archive)
+ ["." artifact (#+ Registry)]]]]]])
+
+(def: module_id
+ 0)
+
+(template [<name> <base>]
+ [(type: #export <name>
+ (<base> Var Expression Expression))]
+
+ [Operation /////generation.Operation]
+ [Phase /////generation.Phase]
+ [Handler /////generation.Handler]
+ [Bundle /////generation.Bundle]
+ )
+
+(type: #export (Generator i)
+ (-> Phase Archive i (Operation Expression)))
+
+(def: #export unit
+ (_.string /////synthesis.unit))
+
+(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
+ body)
+ (do {! meta.monad}
+ [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
+ (wrap (list (` (let [(~+ (|> vars
+ (list.zip/2 ids)
+ (list\map (function (_ [id var])
+ (list (code.local_identifier var)
+ (` (_.var (~ (code.text (format "v" (%.nat id)))))))))
+ list.concat))]
+ (~ body)))))))
+
+(syntax: (runtime: {declaration (<>.or <code>.local_identifier
+ (<code>.form (<>.and <code>.local_identifier
+ (<>.some <code>.local_identifier))))}
+ code)
+ (do meta.monad
+ [runtime_id meta.count]
+ (macro.with_gensyms [g!_]
+ (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id]))
+ runtime_name (` (_.var (~ (code.text (%.code runtime)))))]
+ (case declaration
+ (#.Left name)
+ (let [g!name (code.local_identifier name)]
+ (wrap (list (` (def: #export (~ g!name)
+ Var
+ (~ runtime_name)))
+
+ (` (def: (~ (code.local_identifier (format "@" name)))
+ _.Computation
+ (_.define_constant (~ runtime_name) (~ code)))))))
+
+ (#.Right [name inputs])
+ (let [g!name (code.local_identifier name)
+ inputsC (list\map code.local_identifier inputs)
+ inputs_typesC (list\map (function.constant (` _.Expression))
+ inputs)]
+ (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
+ (-> (~+ inputs_typesC) _.Computation)
+ (_.apply/* (list (~+ inputsC)) (~ runtime_name))))
+
+ (` (def: (~ (code.local_identifier (format "@" name)))
+ _.Computation
+ (..with_vars [(~+ inputsC)]
+ (_.define_function (~ runtime_name) [(list (~+ inputsC)) #.None]
+ (~ code)))))))))))))
+
+(def: last_index
+ (-> Expression Computation)
+ (|>> _.length/1 (_.-/2 (_.int +1))))
+
+(runtime: (tuple//left lefts tuple)
+ (with_vars [last_index_right]
+ (_.begin
+ (list (_.define_constant last_index_right (..last_index tuple))
+ (_.if (_.>/2 lefts last_index_right)
+ ## No need for recursion
+ (_.vector-ref/2 tuple lefts)
+ ## Needs recursion
+ (tuple//left (_.-/2 last_index_right lefts)
+ (_.vector-ref/2 tuple last_index_right)))))))
+
+(runtime: (tuple//right lefts tuple)
+ (with_vars [last_index_right right_index @slice]
+ (_.begin
+ (list (_.define_constant last_index_right (..last_index tuple))
+ (_.define_constant right_index (_.+/2 (_.int +1) lefts))
+ (<| (_.if (_.=/2 last_index_right right_index)
+ (_.vector-ref/2 tuple right_index))
+ (_.if (_.>/2 last_index_right right_index)
+ ## Needs recursion.
+ (tuple//right (_.-/2 last_index_right lefts)
+ (_.vector-ref/2 tuple last_index_right)))
+ (_.begin
+ (list (_.define_constant @slice (_.make-vector/1 (_.-/2 right_index (_.length/1 tuple))))
+ (_.vector-copy!/5 @slice (_.int +0) tuple right_index (_.length/1 tuple))
+ @slice))))
+ )))
+
+(def: (variant' tag last? value)
+ (-> Expression Expression Expression Computation)
+ ($_ _.cons/2
+ tag
+ last?
+ value))
+
+(runtime: (sum//make tag last? value)
+ (variant' tag last? value))
+
+(def: #export (variant [lefts right? value])
+ (-> (Variant Expression) Computation)
+ (..sum//make (_.int (.int lefts)) (_.bool right?) value))
+
+(runtime: (sum//get sum last? wanted_tag)
+ (with_vars [sum_tag sum_flag sum_value sum_temp sum_dump]
+ (let [no_match _.nil
+ test_recursion (_.if sum_flag
+ ## Must recurse.
+ (sum//get sum_value
+ last?
+ (|> wanted_tag (_.-/2 sum_tag)))
+ no_match)]
+ (<| (_.let (list [sum_tag (_.car/1 sum)]
+ [sum_temp (_.cdr/1 sum)]))
+ (_.let (list [sum_flag (_.car/1 sum_temp)]
+ [sum_value (_.cdr/1 sum_temp)]))
+ (_.if (_.=/2 wanted_tag sum_tag)
+ (_.if (_.eqv?/2 last? sum_flag)
+ sum_value
+ test_recursion))
+ (_.if (_.</2 wanted_tag sum_tag)
+ test_recursion)
+ (_.if last?
+ (variant' (|> sum_tag (_.-/2 wanted_tag)) sum_flag sum_value))
+ no_match))))
+
+(def: runtime//adt
+ Computation
+ (_.begin (list @tuple//left
+ @tuple//right
+ @sum//get
+ @sum//make)))
+
+(def: #export none
+ Computation
+ (|> ..unit [0 #0] variant))
+
+(def: #export some
+ (-> Expression Computation)
+ (|>> [1 #1] ..variant))
+
+(def: #export left
+ (-> Expression Computation)
+ (|>> [0 #0] ..variant))
+
+(def: #export right
+ (-> Expression Computation)
+ (|>> [1 #1] ..variant))
+
+(runtime: (slice offset length list)
+ (<| (_.if (_.null?/1 list)
+ list)
+ (_.if (|> offset (_.>/2 (_.int +0)))
+ (slice (|> offset (_.-/2 (_.int +1)))
+ length
+ (_.cdr/1 list)))
+ (_.if (|> length (_.>/2 (_.int +0)))
+ (_.cons/2 (_.car/1 list)
+ (slice offset
+ (|> length (_.-/2 (_.int +1)))
+ (_.cdr/1 list))))
+ _.nil))
+
+(runtime: (lux//try op)
+ (with_vars [error]
+ (_.with_exception_handler
+ (_.lambda [(list error) #.None]
+ (..left error))
+ (_.lambda [(list) #.None]
+ (..right (_.apply/* (list ..unit) op))))))
+
+(runtime: (lux//program_args program_args)
+ (with_vars [@loop @input @output]
+ (_.letrec (list [@loop (_.lambda [(list @input @output) #.None]
+ (_.if (_.null?/1 @input)
+ @output
+ (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))])
+ (_.apply/2 @loop (_.reverse/1 program_args) ..none))))
+
+(def: runtime//lux
+ Computation
+ (_.begin (list @lux//try
+ @lux//program_args)))
+
+(def: i64//+limit (_.manual "+9223372036854775807"
+ ## "+0x7FFFFFFFFFFFFFFF"
+ ))
+(def: i64//-limit (_.manual "-9223372036854775808"
+ ## "-0x8000000000000000"
+ ))
+(def: i64//+iteration (_.manual "+18446744073709551616"
+ ## "+0x10000000000000000"
+ ))
+(def: i64//-iteration (_.manual "-18446744073709551616"
+ ## "-0x10000000000000000"
+ ))
+(def: i64//+cap (_.manual "+9223372036854775808"
+ ## "+0x8000000000000000"
+ ))
+(def: i64//-cap (_.manual "-9223372036854775809"
+ ## "-0x8000000000000001"
+ ))
+
+(runtime: (i64//64 input)
+ (with_vars [temp]
+ (`` (<| (~~ (template [<scenario> <iteration> <cap> <entrance>]
+ [(_.if (|> input <scenario>)
+ (_.let (list [temp (_.remainder/2 <iteration> input)])
+ (_.if (|> temp <scenario>)
+ (|> temp (_.-/2 <cap>) (_.+/2 <entrance>))
+ temp)))]
+
+ [(_.>/2 ..i64//+limit) ..i64//+iteration ..i64//+cap ..i64//-limit]
+ [(_.</2 ..i64//-limit) ..i64//-iteration ..i64//-cap ..i64//+limit]
+ ))
+ input))))
+
+(runtime: (i64//left_shift param subject)
+ (|> subject
+ (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) param))
+ ..i64//64))
+
+(def: as_nat
+ (_.remainder/2 ..i64//+iteration))
+
+(runtime: (i64//right_shift shift subject)
+ (_.let (list [shift (_.remainder/2 (_.int +64) shift)])
+ (_.if (_.=/2 (_.int +0) shift)
+ subject
+ (|> subject
+ ..as_nat
+ (_.arithmetic-shift/2 (_.-/2 shift (_.int +0)))))))
+
+(template [<runtime> <host>]
+ [(runtime: (<runtime> left right)
+ (..i64//64 (<host> (..as_nat left) (..as_nat right))))]
+
+ [i64//or _.bitwise-ior/2]
+ [i64//xor _.bitwise-xor/2]
+ [i64//and _.bitwise-and/2]
+ )
+
+(runtime: (i64//division param subject)
+ (|> subject (_.//2 param) _.truncate/1 ..i64//64))
+
+(def: runtime//i64
+ Computation
+ (_.begin (list @i64//64
+ @i64//left_shift
+ @i64//right_shift
+ @i64//or
+ @i64//xor
+ @i64//and
+ @i64//division)))
+
+(runtime: (f64//decode input)
+ (with_vars [@output]
+ (let [output_is_not_a_number? (_.not/1 (_.=/2 @output @output))
+ input_is_not_a_number? (_.string=?/2 (_.string "+nan.0") input)]
+ (_.let (list [@output (_.string->number/1 input)])
+ (_.if (_.and (list output_is_not_a_number?
+ (_.not/1 input_is_not_a_number?)))
+ ..none
+ (..some @output))))))
+
+(def: runtime//f64
+ Computation
+ (_.begin (list @f64//decode)))
+
+(runtime: (text//index offset sub text)
+ (with_vars [index]
+ (_.let (list [index (_.string-contains/3 text sub offset)])
+ (_.if index
+ (..some index)
+ ..none))))
+
+(runtime: (text//clip offset length text)
+ (_.substring/3 text offset (_.+/2 offset length)))
+
+(runtime: (text//char index text)
+ (_.char->integer/1 (_.string-ref/2 text index)))
+
+(def: runtime//text
+ (_.begin (list @text//index
+ @text//clip
+ @text//char)))
+
+(runtime: (array//write idx value array)
+ (_.begin (list (_.vector-set!/3 array idx value)
+ array)))
+
+(def: runtime//array
+ Computation
+ ($_ _.then
+ @array//write
+ ))
+
+(def: runtime
+ Computation
+ (_.begin (list @slice
+ runtime//lux
+ runtime//i64
+ runtime//adt
+ runtime//f64
+ runtime//text
+ runtime//array
+ )))
+
+(def: #export generate
+ (Operation [Registry Output])
+ (do ///////phase.monad
+ [_ (/////generation.execute! ..runtime)
+ _ (/////generation.save! (%.nat ..module_id) ..runtime)]
+ (wrap [(|> artifact.empty
+ artifact.resource
+ product.right)
+ (row.row [(%.nat ..module_id)
+ (|> ..runtime
+ _.code
+ (\ utf8.codec encode))])])))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux
new file mode 100644
index 000000000..50a8357f7
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux
@@ -0,0 +1,40 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ [collection
+ ["." list]]]
+ [target
+ ["_" scheme (#+ Expression)]]]]
+ ["." // #_
+ ["#." runtime (#+ Operation Phase Generator)]
+ ["#." primitive]
+ ["///#" //// #_
+ [analysis (#+ Variant Tuple)]
+ ["#." synthesis (#+ Synthesis)]
+ ["//#" /// #_
+ ["#." phase ("#\." monad)]]]])
+
+(def: #export (tuple expression archive elemsS+)
+ (Generator (Tuple Synthesis))
+ (case elemsS+
+ #.Nil
+ (///////phase\wrap (//primitive.text /////synthesis.unit))
+
+ (#.Cons singletonS #.Nil)
+ (expression archive singletonS)
+
+ _
+ (|> elemsS+
+ (monad.map ///////phase.monad (expression archive))
+ (///////phase\map _.vector/*))))
+
+(def: #export (variant expression archive [lefts right? valueS])
+ (Generator (Variant Synthesis))
+ (let [tag (if right?
+ (inc lefts)
+ lefts)]
+ (///////phase\map (|>> [tag right?] //runtime.variant)
+ (expression archive valueS))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis.lux
new file mode 100644
index 000000000..47260c0fc
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis.lux
@@ -0,0 +1,104 @@
+(.module:
+ [library
+ [lux (#- primitive)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]]
+ [data
+ ["." maybe]
+ [collection
+ ["." list ("#\." functor)]
+ ["." dictionary (#+ Dictionary)]]]]]
+ ["." / #_
+ ["#." function]
+ ["#." case]
+ ["#." variable]
+ ["/#" // #_
+ ["#." extension]
+ ["/#" // #_
+ ["#." analysis (#+ Analysis)]
+ ["/" synthesis (#+ Synthesis Phase)]
+ [///
+ ["." phase ("#\." monad)]
+ [reference (#+)
+ [variable (#+)]]]]]])
+
+(def: (primitive analysis)
+ (-> ///analysis.Primitive /.Primitive)
+ (case analysis
+ #///analysis.Unit
+ (#/.Text /.unit)
+
+ (^template [<analysis> <synthesis>]
+ [(<analysis> value)
+ (<synthesis> value)])
+ ([#///analysis.Bit #/.Bit]
+ [#///analysis.Frac #/.F64]
+ [#///analysis.Text #/.Text])
+
+ (^template [<analysis> <synthesis>]
+ [(<analysis> value)
+ (<synthesis> (.i64 value))])
+ ([#///analysis.Nat #/.I64]
+ [#///analysis.Int #/.I64]
+ [#///analysis.Rev #/.I64])))
+
+(def: (optimization archive)
+ Phase
+ (function (optimization' analysis)
+ (case analysis
+ (#///analysis.Primitive analysis')
+ (phase\wrap (#/.Primitive (..primitive analysis')))
+
+ (#///analysis.Reference reference)
+ (phase\wrap (#/.Reference reference))
+
+ (#///analysis.Structure structure)
+ (/.with_currying? false
+ (case structure
+ (#///analysis.Variant variant)
+ (do phase.monad
+ [valueS (optimization' (get@ #///analysis.value variant))]
+ (wrap (/.variant (set@ #///analysis.value valueS variant))))
+
+ (#///analysis.Tuple tuple)
+ (|> tuple
+ (monad.map phase.monad optimization')
+ (phase\map (|>> /.tuple)))))
+
+ (#///analysis.Case inputA branchesAB+)
+ (/.with_currying? false
+ (/case.synthesize optimization branchesAB+ archive inputA))
+
+ (^ (///analysis.no_op value))
+ (optimization' value)
+
+ (#///analysis.Apply _)
+ (/.with_currying? false
+ (/function.apply optimization archive analysis))
+
+ (#///analysis.Function environmentA bodyA)
+ (/function.abstraction optimization environmentA archive bodyA)
+
+ (#///analysis.Extension name args)
+ (/.with_currying? false
+ (function (_ state)
+ (|> (//extension.apply archive optimization [name args])
+ (phase.run' state)
+ (case> (#try.Success output)
+ (#try.Success output)
+
+ (#try.Failure _)
+ (|> args
+ (monad.map phase.monad optimization')
+ (phase\map (|>> [name] #/.Extension))
+ (phase.run' state))))))
+ )))
+
+(def: #export (phase archive analysis)
+ Phase
+ (do phase.monad
+ [synthesis (..optimization archive analysis)]
+ (phase.lift (/variable.optimization synthesis))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/case.lux
new file mode 100644
index 000000000..02938eb7a
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/case.lux
@@ -0,0 +1,430 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ ["." monad (#+ do)]]
+ [control
+ [pipe (#+ when> new> case>)]]
+ [data
+ ["." product]
+ ["." bit ("#\." equivalence)]
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." list ("#\." functor fold monoid)]
+ ["." set (#+ Set)]]]
+ [math
+ [number
+ ["n" nat]
+ ["." i64]
+ ["." frac ("#\." equivalence)]]]]]
+ ["." /// #_
+ [//
+ ["#." analysis (#+ Pattern Match Analysis)]
+ ["/" synthesis (#+ Path Synthesis Operation Phase)]
+ [///
+ ["#" phase ("#\." monad)]
+ ["#." reference
+ ["#/." variable (#+ Register Variable)]]
+ [meta
+ [archive (#+ Archive)]]]]])
+
+(def: clean_up
+ (-> Path Path)
+ (|>> (#/.Seq #/.Pop)))
+
+(def: (path' pattern end? thenC)
+ (-> Pattern Bit (Operation Path) (Operation Path))
+ (case pattern
+ (#///analysis.Simple simple)
+ (case simple
+ #///analysis.Unit
+ thenC
+
+ (#///analysis.Bit when)
+ (///\map (function (_ then)
+ (#/.Bit_Fork when then #.None))
+ thenC)
+
+ (^template [<from> <to> <conversion>]
+ [(<from> test)
+ (///\map (function (_ then)
+ (<to> [(<conversion> test) then] (list)))
+ thenC)])
+ ([#///analysis.Nat #/.I64_Fork .i64]
+ [#///analysis.Int #/.I64_Fork .i64]
+ [#///analysis.Rev #/.I64_Fork .i64]
+ [#///analysis.Frac #/.F64_Fork |>]
+ [#///analysis.Text #/.Text_Fork |>]))
+
+ (#///analysis.Bind register)
+ (<| (\ ///.monad map (|>> (#/.Seq (#/.Bind register))))
+ /.with_new_local
+ thenC)
+
+ (#///analysis.Complex (#///analysis.Variant [lefts right? value_pattern]))
+ (<| (///\map (|>> (#/.Seq (#/.Access (#/.Side (if right?
+ (#.Right lefts)
+ (#.Left lefts)))))))
+ (path' value_pattern end?)
+ (when> [(new> (not end?) [])] [(///\map ..clean_up)])
+ thenC)
+
+ (#///analysis.Complex (#///analysis.Tuple tuple))
+ (let [tuple::last (dec (list.size tuple))]
+ (list\fold (function (_ [tuple::lefts tuple::member] nextC)
+ (.case tuple::member
+ (#///analysis.Simple #///analysis.Unit)
+ nextC
+
+ _
+ (let [right? (n.= tuple::last tuple::lefts)
+ end?' (and end? right?)]
+ (<| (///\map (|>> (#/.Seq (#/.Access (#/.Member (if right?
+ (#.Right (dec tuple::lefts))
+ (#.Left tuple::lefts)))))))
+ (path' tuple::member end?')
+ (when> [(new> (not end?') [])] [(///\map ..clean_up)])
+ nextC))))
+ thenC
+ (list.reverse (list.enumeration tuple))))
+ ))
+
+(def: (path archive synthesize pattern bodyA)
+ (-> Archive Phase Pattern Analysis (Operation Path))
+ (path' pattern true (///\map (|>> #/.Then) (synthesize archive bodyA))))
+
+(def: (weave_branch weave equivalence [new_test new_then] [[old_test old_then] old_tail])
+ (All [a] (-> (-> Path Path Path) (Equivalence a) [a Path] (/.Fork a Path)
+ (/.Fork a Path)))
+ (if (\ equivalence = new_test old_test)
+ [[old_test (weave new_then old_then)] old_tail]
+ [[old_test old_then]
+ (case old_tail
+ #.Nil
+ (list [new_test new_then])
+
+ (#.Cons old_cons)
+ (#.Cons (weave_branch weave equivalence [new_test new_then] old_cons)))]))
+
+(def: (weave_fork weave equivalence new_fork old_fork)
+ (All [a] (-> (-> Path Path Path) (Equivalence a) (/.Fork a Path) (/.Fork a Path)
+ (/.Fork a Path)))
+ (list\fold (..weave_branch weave equivalence) old_fork (#.Cons new_fork)))
+
+(def: (weave new old)
+ (-> Path Path Path)
+ (with_expansions [<default> (as_is (#/.Alt old new))]
+ (case [new old]
+ [_
+ (#/.Alt old_left old_right)]
+ (#/.Alt old_left
+ (weave new old_right))
+
+ [(#/.Seq preN postN)
+ (#/.Seq preO postO)]
+ (case (weave preN preO)
+ (#/.Alt _)
+ <default>
+
+ woven
+ (#/.Seq woven (weave postN postO)))
+
+ [#/.Pop #/.Pop]
+ old
+
+ [(#/.Bit_Fork new_when new_then new_else)
+ (#/.Bit_Fork old_when old_then old_else)]
+ (if (bit\= new_when old_when)
+ (#/.Bit_Fork old_when
+ (weave new_then old_then)
+ (case [new_else old_else]
+ [#.None #.None]
+ #.None
+
+ (^or [(#.Some woven_then) #.None]
+ [#.None (#.Some woven_then)])
+ (#.Some woven_then)
+
+ [(#.Some new_else) (#.Some old_else)]
+ (#.Some (weave new_else old_else))))
+ (#/.Bit_Fork old_when
+ (case new_else
+ #.None
+ old_then
+
+ (#.Some new_else)
+ (weave new_else old_then))
+ (#.Some (case old_else
+ #.None
+ new_then
+
+ (#.Some old_else)
+ (weave new_then old_else)))))
+
+ (^template [<tag> <equivalence>]
+ [[(<tag> new_fork) (<tag> old_fork)]
+ (<tag> (..weave_fork weave <equivalence> new_fork old_fork))])
+ ([#/.I64_Fork i64.equivalence]
+ [#/.F64_Fork frac.equivalence]
+ [#/.Text_Fork text.equivalence])
+
+ (^template [<access> <side>]
+ [[(#/.Access (<access> (<side> newL)))
+ (#/.Access (<access> (<side> oldL)))]
+ (if (n.= newL oldL)
+ old
+ <default>)])
+ ([#/.Side #.Left]
+ [#/.Side #.Right]
+ [#/.Member #.Left]
+ [#/.Member #.Right])
+
+ [(#/.Bind newR) (#/.Bind oldR)]
+ (if (n.= newR oldR)
+ old
+ <default>)
+
+ _
+ <default>)))
+
+(def: (get patterns @selection)
+ (-> (///analysis.Tuple ///analysis.Pattern) Register (List /.Member))
+ (loop [lefts 0
+ patterns patterns]
+ (with_expansions [<failure> (as_is (list))
+ <continue> (as_is (recur (inc lefts)
+ tail))
+ <member> (as_is (if (list.empty? tail)
+ (#.Right (dec lefts))
+ (#.Left lefts)))]
+ (case patterns
+ #.Nil
+ <failure>
+
+ (#.Cons head tail)
+ (case head
+ (#///analysis.Simple #///analysis.Unit)
+ <continue>
+
+ (#///analysis.Bind register)
+ (if (n.= @selection register)
+ (list <member>)
+ <continue>)
+
+ (#///analysis.Complex (#///analysis.Tuple sub_patterns))
+ (case (get sub_patterns @selection)
+ #.Nil
+ <continue>
+
+ sub_members
+ (list& <member> sub_members))
+
+ _
+ <failure>)))))
+
+(def: #export (synthesize_case synthesize archive input [[headP headA] tailPA+])
+ (-> Phase Archive Synthesis Match (Operation Synthesis))
+ (do {! ///.monad}
+ [headSP (path archive synthesize headP headA)
+ tailSP+ (monad.map ! (product.uncurry (path archive synthesize)) tailPA+)]
+ (wrap (/.branch/case [input (list\fold weave headSP tailSP+)]))))
+
+(template: (!masking <variable> <output>)
+ [[(#///analysis.Bind <variable>)
+ (#///analysis.Reference (///reference.local <output>))]
+ (list)])
+
+(def: #export (synthesize_let synthesize archive input @variable body)
+ (-> Phase Archive Synthesis Register Analysis (Operation Synthesis))
+ (do ///.monad
+ [body (/.with_new_local
+ (synthesize archive body))]
+ (wrap (/.branch/let [input @variable body]))))
+
+(def: #export (synthesize_masking synthesize archive input @variable @output)
+ (-> Phase Archive Synthesis Register Register (Operation Synthesis))
+ (if (n.= @variable @output)
+ (///\wrap input)
+ (..synthesize_let synthesize archive input @variable (#///analysis.Reference (///reference.local @output)))))
+
+(def: #export (synthesize_if synthesize archive test then else)
+ (-> Phase Archive Synthesis Analysis Analysis (Operation Synthesis))
+ (do ///.monad
+ [then (synthesize archive then)
+ else (synthesize archive else)]
+ (wrap (/.branch/if [test then else]))))
+
+(template: (!get <patterns> <output>)
+ [[(///analysis.pattern/tuple <patterns>)
+ (#///analysis.Reference (///reference.local <output>))]
+ (.list)])
+
+(def: #export (synthesize_get synthesize archive input patterns @member)
+ (-> Phase Archive Synthesis (///analysis.Tuple ///analysis.Pattern) Register (Operation Synthesis))
+ (case (..get patterns @member)
+ #.Nil
+ (..synthesize_case synthesize archive input (!get patterns @member))
+
+ path
+ (case input
+ (^ (/.branch/get [sub_path sub_input]))
+ (///\wrap (/.branch/get [(list\compose path sub_path) sub_input]))
+
+ _
+ (///\wrap (/.branch/get [path input])))))
+
+(def: #export (synthesize synthesize^ [headB tailB+] archive inputA)
+ (-> Phase Match Phase)
+ (do {! ///.monad}
+ [inputS (synthesize^ archive inputA)]
+ (case [headB tailB+]
+ (^ (!masking @variable @output))
+ (..synthesize_masking synthesize^ archive inputS @variable @output)
+
+ [[(#///analysis.Bind @variable) body]
+ #.Nil]
+ (..synthesize_let synthesize^ archive inputS @variable body)
+
+ (^or (^ [[(///analysis.pattern/bit #1) then]
+ (list [(///analysis.pattern/bit #0) else])])
+ (^ [[(///analysis.pattern/bit #1) then]
+ (list [(///analysis.pattern/unit) else])])
+
+ (^ [[(///analysis.pattern/bit #0) else]
+ (list [(///analysis.pattern/bit #1) then])])
+ (^ [[(///analysis.pattern/bit #0) else]
+ (list [(///analysis.pattern/unit) then])]))
+ (..synthesize_if synthesize^ archive inputS then else)
+
+ (^ (!get patterns @member))
+ (..synthesize_get synthesize^ archive inputS patterns @member)
+
+ match
+ (..synthesize_case synthesize^ archive inputS match))))
+
+(def: #export (count_pops path)
+ (-> Path [Nat Path])
+ (case path
+ (^ (/.path/seq #/.Pop path'))
+ (let [[pops post_pops] (count_pops path')]
+ [(inc pops) post_pops])
+
+ _
+ [0 path]))
+
+(def: #export pattern_matching_error
+ "Invalid expression for pattern-matching.")
+
+(type: #export Storage
+ {#bindings (Set Register)
+ #dependencies (Set Variable)})
+
+(def: empty
+ Storage
+ {#bindings (set.new n.hash)
+ #dependencies (set.new ///reference/variable.hash)})
+
+## TODO: Use this to declare all local variables at the beginning of
+## script functions.
+## That way, it should be possible to do cheap "let" expressions,
+## since the variable will exist beforehand, so no closure will need
+## to be created for it.
+## Apply this trick to JS, Python et al.
+(def: #export (storage path)
+ (-> Path Storage)
+ (loop for_path
+ [path path
+ path_storage ..empty]
+ (case path
+ (^or #/.Pop (#/.Access Access))
+ path_storage
+
+ (^ (/.path/bind register))
+ (update@ #bindings (set.add register)
+ path_storage)
+
+ (#/.Bit_Fork _ default otherwise)
+ (|> (case otherwise
+ #.None
+ path_storage
+
+ (#.Some otherwise)
+ (for_path otherwise path_storage))
+ (for_path default))
+
+ (^or (#/.I64_Fork forks)
+ (#/.F64_Fork forks)
+ (#/.Text_Fork forks))
+ (|> (#.Cons forks)
+ (list\map product.right)
+ (list\fold for_path path_storage))
+
+ (^or (^ (/.path/seq left right))
+ (^ (/.path/alt left right)))
+ (list\fold for_path path_storage (list left right))
+
+ (^ (/.path/then bodyS))
+ (loop for_synthesis
+ [bodyS bodyS
+ synthesis_storage path_storage]
+ (case bodyS
+ (^ (/.variant [lefts right? valueS]))
+ (for_synthesis valueS synthesis_storage)
+
+ (^ (/.tuple members))
+ (list\fold for_synthesis synthesis_storage members)
+
+ (#/.Reference (#///reference.Variable (#///reference/variable.Local register)))
+ (if (set.member? (get@ #bindings synthesis_storage) register)
+ synthesis_storage
+ (update@ #dependencies (set.add (#///reference/variable.Local register)) synthesis_storage))
+
+ (#/.Reference (#///reference.Variable var))
+ (update@ #dependencies (set.add var) synthesis_storage)
+
+ (^ (/.function/apply [functionS argsS]))
+ (list\fold for_synthesis synthesis_storage (#.Cons functionS argsS))
+
+ (^ (/.function/abstraction [environment arity bodyS]))
+ (list\fold for_synthesis synthesis_storage environment)
+
+ (^ (/.branch/case [inputS pathS]))
+ (update@ #dependencies
+ (set.union (get@ #dependencies (for_path pathS synthesis_storage)))
+ (for_synthesis inputS synthesis_storage))
+
+ (^ (/.branch/let [inputS register exprS]))
+ (update@ #dependencies
+ (set.union (|> synthesis_storage
+ (update@ #bindings (set.add register))
+ (for_synthesis exprS)
+ (get@ #dependencies)))
+ (for_synthesis inputS synthesis_storage))
+
+ (^ (/.branch/if [testS thenS elseS]))
+ (list\fold for_synthesis synthesis_storage (list testS thenS elseS))
+
+ (^ (/.branch/get [access whole]))
+ (for_synthesis whole synthesis_storage)
+
+ (^ (/.loop/scope [start initsS+ iterationS]))
+ (update@ #dependencies
+ (set.union (|> synthesis_storage
+ (update@ #bindings (set.union (|> initsS+
+ list.enumeration
+ (list\map (|>> product.left (n.+ start)))
+ (set.from_list n.hash))))
+ (for_synthesis iterationS)
+ (get@ #dependencies)))
+ (list\fold for_synthesis synthesis_storage initsS+))
+
+ (^ (/.loop/recur replacementsS+))
+ (list\fold for_synthesis synthesis_storage replacementsS+)
+
+ (#/.Extension [extension argsS])
+ (list\fold for_synthesis synthesis_storage argsS)
+
+ _
+ synthesis_storage))
+ )))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/function.lux
new file mode 100644
index 000000000..2b0319266
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/function.lux
@@ -0,0 +1,277 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]
+ ["." enum]]
+ [control
+ [pipe (#+ case>)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." maybe ("#\." functor)]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor monoid fold)]]]
+ [math
+ [number
+ ["n" nat]]]]]
+ ["." // #_
+ ["#." loop (#+ Transform)]
+ ["//#" /// #_
+ ["#." analysis (#+ Environment Analysis)]
+ ["/" synthesis (#+ Path Abstraction Synthesis Operation Phase)]
+ [///
+ [arity (#+ Arity)]
+ ["#." reference
+ ["#/." variable (#+ Register Variable)]]
+ ["." phase ("#\." monad)]]]])
+
+(exception: #export (cannot_find_foreign_variable_in_environment {foreign Register} {environment (Environment Synthesis)})
+ (exception.report
+ ["Foreign" (%.nat foreign)]
+ ["Environment" (exception.enumerate /.%synthesis environment)]))
+
+(def: arity_arguments
+ (-> Arity (List Synthesis))
+ (|>> dec
+ (enum.range n.enum 1)
+ (list\map (|>> /.variable/local))))
+
+(template: #export (self_reference)
+ (/.variable/local 0))
+
+(def: (expanded_nested_self_reference arity)
+ (-> Arity Synthesis)
+ (/.function/apply [(..self_reference) (arity_arguments arity)]))
+
+(def: #export (apply phase)
+ (-> Phase Phase)
+ (function (_ archive exprA)
+ (let [[funcA argsA] (////analysis.application exprA)]
+ (do {! phase.monad}
+ [funcS (phase archive funcA)
+ argsS (monad.map ! (phase archive) argsA)]
+ (with_expansions [<apply> (as_is (/.function/apply [funcS argsS]))]
+ (case funcS
+ (^ (/.function/abstraction functionS))
+ (if (n.= (get@ #/.arity functionS)
+ (list.size argsS))
+ (do !
+ [locals /.locals]
+ (wrap (|> functionS
+ (//loop.optimization true locals argsS)
+ (maybe\map (: (-> [Nat (List Synthesis) Synthesis] Synthesis)
+ (function (_ [start inits iteration])
+ (case iteration
+ (^ (/.loop/scope [start' inits' output]))
+ (if (and (n.= start start')
+ (list.empty? inits'))
+ (/.loop/scope [start inits output])
+ (/.loop/scope [start inits iteration]))
+
+ _
+ (/.loop/scope [start inits iteration])))))
+ (maybe.default <apply>))))
+ (wrap <apply>))
+
+ (^ (/.function/apply [funcS' argsS']))
+ (wrap (/.function/apply [funcS' (list\compose argsS' argsS)]))
+
+ _
+ (wrap <apply>)))))))
+
+(def: (find_foreign environment register)
+ (-> (Environment Synthesis) Register (Operation Synthesis))
+ (case (list.nth register environment)
+ (#.Some aliased)
+ (phase\wrap aliased)
+
+ #.None
+ (phase.throw ..cannot_find_foreign_variable_in_environment [register environment])))
+
+(def: (grow_path grow path)
+ (-> (-> Synthesis (Operation Synthesis)) Path (Operation Path))
+ (case path
+ (#/.Bind register)
+ (phase\wrap (#/.Bind (inc register)))
+
+ (^template [<tag>]
+ [(<tag> left right)
+ (do phase.monad
+ [left' (grow_path grow left)
+ right' (grow_path grow right)]
+ (wrap (<tag> left' right')))])
+ ([#/.Alt] [#/.Seq])
+
+ (#/.Bit_Fork when then else)
+ (do {! phase.monad}
+ [then (grow_path grow then)
+ else (case else
+ (#.Some else)
+ (\ ! map (|>> #.Some) (grow_path grow else))
+
+ #.None
+ (wrap #.None))]
+ (wrap (#/.Bit_Fork when then else)))
+
+ (^template [<tag>]
+ [(<tag> [[test then] elses])
+ (do {! phase.monad}
+ [then (grow_path grow then)
+ elses (monad.map ! (function (_ [else_test else_then])
+ (do !
+ [else_then (grow_path grow else_then)]
+ (wrap [else_test else_then])))
+ elses)]
+ (wrap (<tag> [[test then] elses])))])
+ ([#/.I64_Fork]
+ [#/.F64_Fork]
+ [#/.Text_Fork])
+
+ (#/.Then thenS)
+ (|> thenS
+ grow
+ (phase\map (|>> #/.Then)))
+
+ _
+ (phase\wrap path)))
+
+(def: (grow environment expression)
+ (-> (Environment Synthesis) Synthesis (Operation Synthesis))
+ (case expression
+ (#/.Structure structure)
+ (case structure
+ (#////analysis.Variant [lefts right? subS])
+ (|> subS
+ (grow environment)
+ (phase\map (|>> [lefts right?] /.variant)))
+
+ (#////analysis.Tuple membersS+)
+ (|> membersS+
+ (monad.map phase.monad (grow environment))
+ (phase\map (|>> /.tuple))))
+
+ (^ (..self_reference))
+ (phase\wrap (/.function/apply [expression (list (/.variable/local 1))]))
+
+ (#/.Reference reference)
+ (case reference
+ (#////reference.Variable variable)
+ (case variable
+ (#////reference/variable.Local register)
+ (phase\wrap (/.variable/local (inc register)))
+
+ (#////reference/variable.Foreign register)
+ (..find_foreign environment register))
+
+ (#////reference.Constant constant)
+ (phase\wrap expression))
+
+ (#/.Control control)
+ (case control
+ (#/.Branch branch)
+ (case branch
+ (#/.Let [inputS register bodyS])
+ (do phase.monad
+ [inputS' (grow environment inputS)
+ bodyS' (grow environment bodyS)]
+ (wrap (/.branch/let [inputS' (inc register) bodyS'])))
+
+ (#/.If [testS thenS elseS])
+ (do phase.monad
+ [testS' (grow environment testS)
+ thenS' (grow environment thenS)
+ elseS' (grow environment elseS)]
+ (wrap (/.branch/if [testS' thenS' elseS'])))
+
+ (#/.Get members inputS)
+ (do phase.monad
+ [inputS' (grow environment inputS)]
+ (wrap (/.branch/get [members inputS'])))
+
+ (#/.Case [inputS pathS])
+ (do phase.monad
+ [inputS' (grow environment inputS)
+ pathS' (grow_path (grow environment) pathS)]
+ (wrap (/.branch/case [inputS' pathS']))))
+
+ (#/.Loop loop)
+ (case loop
+ (#/.Scope [start initsS+ iterationS])
+ (do {! phase.monad}
+ [initsS+' (monad.map ! (grow environment) initsS+)
+ iterationS' (grow environment iterationS)]
+ (wrap (/.loop/scope [(inc start) initsS+' iterationS'])))
+
+ (#/.Recur argumentsS+)
+ (|> argumentsS+
+ (monad.map phase.monad (grow environment))
+ (phase\map (|>> /.loop/recur))))
+
+ (#/.Function function)
+ (case function
+ (#/.Abstraction [_env _arity _body])
+ (do {! phase.monad}
+ [_env' (monad.map !
+ (|>> (case> (#/.Reference (#////reference.Variable (#////reference/variable.Foreign register)))
+ (..find_foreign environment register)
+
+ captured
+ (grow environment captured)))
+ _env)]
+ (wrap (/.function/abstraction [_env' _arity _body])))
+
+ (#/.Apply funcS argsS+)
+ (do {! phase.monad}
+ [funcS (grow environment funcS)
+ argsS+ (monad.map ! (grow environment) argsS+)]
+ (wrap (/.function/apply (case funcS
+ (^ (/.function/apply [(..self_reference) pre_argsS+]))
+ [(..self_reference)
+ (list\compose pre_argsS+ argsS+)]
+
+ _
+ [funcS
+ argsS+]))))))
+
+ (#/.Extension name argumentsS+)
+ (|> argumentsS+
+ (monad.map phase.monad (grow environment))
+ (phase\map (|>> (#/.Extension name))))
+
+ (#/.Primitive _)
+ (phase\wrap expression)))
+
+(def: #export (abstraction phase environment archive bodyA)
+ (-> Phase (Environment Analysis) Phase)
+ (do {! phase.monad}
+ [currying? /.currying?
+ environment (monad.map ! (phase archive) environment)
+ bodyS (/.with_currying? true
+ (/.with_locals 2
+ (phase archive bodyA)))
+ abstraction (: (Operation Abstraction)
+ (case bodyS
+ (^ (/.function/abstraction [env' down_arity' bodyS']))
+ (|> bodyS'
+ (grow env')
+ (\ ! map (function (_ body)
+ {#/.environment environment
+ #/.arity (inc down_arity')
+ #/.body body})))
+
+ _
+ (wrap {#/.environment environment
+ #/.arity 1
+ #/.body bodyS})))]
+ (wrap (if currying?
+ (/.function/abstraction abstraction)
+ (case (//loop.optimization false 1 (list) abstraction)
+ (#.Some [startL initsL bodyL])
+ (/.function/abstraction {#/.environment environment
+ #/.arity (get@ #/.arity abstraction)
+ #/.body (/.loop/scope [startL initsL bodyL])})
+
+ #.None
+ (/.function/abstraction abstraction))))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/loop.lux
new file mode 100644
index 000000000..ed5381e02
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/loop.lux
@@ -0,0 +1,187 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." maybe ("#\." monad)]
+ [collection
+ ["." list]]]
+ [math
+ [number
+ ["n" nat]]]]]
+ [////
+ ["." analysis (#+ Environment)]
+ ["/" synthesis (#+ Path Abstraction Synthesis)]
+ [///
+ [arity (#+ Arity)]
+ ["." reference
+ ["." variable (#+ Register Variable)]]]])
+
+(type: #export (Transform a)
+ (-> a (Maybe a)))
+
+(def: #export (register_optimization offset)
+ (-> Register (-> Register Register))
+ (|>> dec (n.+ offset)))
+
+(def: (path_optimization body_optimization offset)
+ (-> (Transform Synthesis) Register (Transform Path))
+ (function (recur path)
+ (case path
+ (#/.Bind register)
+ (#.Some (#/.Bind (register_optimization offset register)))
+
+ (^template [<tag>]
+ [(<tag> left right)
+ (do maybe.monad
+ [left' (recur left)
+ right' (recur right)]
+ (wrap (<tag> left' right')))])
+ ([#/.Alt] [#/.Seq])
+
+ (#/.Bit_Fork when then else)
+ (do {! maybe.monad}
+ [then (recur then)
+ else (case else
+ (#.Some else)
+ (\ ! map (|>> #.Some) (recur else))
+
+ #.None
+ (wrap #.None))]
+ (wrap (#/.Bit_Fork when then else)))
+
+ (^template [<tag>]
+ [(<tag> [[test then] elses])
+ (do {! maybe.monad}
+ [then (recur then)
+ elses (monad.map ! (function (_ [else_test else_then])
+ (do !
+ [else_then (recur else_then)]
+ (wrap [else_test else_then])))
+ elses)]
+ (wrap (<tag> [[test then] elses])))])
+ ([#/.I64_Fork]
+ [#/.F64_Fork]
+ [#/.Text_Fork])
+
+ (#/.Then body)
+ (|> body
+ body_optimization
+ (maybe\map (|>> #/.Then)))
+
+ _
+ (#.Some path))))
+
+(def: (body_optimization true_loop? offset scope_environment arity expr)
+ (-> Bit Register (Environment Synthesis) Arity (Transform Synthesis))
+ (loop [return? true
+ expr expr]
+ (case expr
+ (#/.Primitive _)
+ (#.Some expr)
+
+ (#/.Structure structure)
+ (case structure
+ (#analysis.Variant variant)
+ (do maybe.monad
+ [value' (|> variant (get@ #analysis.value) (recur false))]
+ (wrap (|> variant
+ (set@ #analysis.value value')
+ /.variant)))
+
+ (#analysis.Tuple tuple)
+ (|> tuple
+ (monad.map maybe.monad (recur false))
+ (maybe\map (|>> /.tuple))))
+
+ (#/.Reference reference)
+ (case reference
+ (^ (#reference.Variable (variable.self)))
+ (if true_loop?
+ #.None
+ (#.Some expr))
+
+ (^ (reference.constant constant))
+ (#.Some expr)
+
+ (^ (reference.local register))
+ (#.Some (#/.Reference (reference.local (register_optimization offset register))))
+
+ (^ (reference.foreign register))
+ (if true_loop?
+ (list.nth register scope_environment)
+ (#.Some expr)))
+
+ (^ (/.branch/case [input path]))
+ (do maybe.monad
+ [input' (recur false input)
+ path' (path_optimization (recur return?) offset path)]
+ (wrap (|> path' [input'] /.branch/case)))
+
+ (^ (/.branch/let [input register body]))
+ (do maybe.monad
+ [input' (recur false input)
+ body' (recur return? body)]
+ (wrap (/.branch/let [input' (register_optimization offset register) body'])))
+
+ (^ (/.branch/if [input then else]))
+ (do maybe.monad
+ [input' (recur false input)
+ then' (recur return? then)
+ else' (recur return? else)]
+ (wrap (/.branch/if [input' then' else'])))
+
+ (^ (/.branch/get [path record]))
+ (do maybe.monad
+ [record (recur false record)]
+ (wrap (/.branch/get [path record])))
+
+ (^ (/.loop/scope scope))
+ (do {! maybe.monad}
+ [inits' (|> scope
+ (get@ #/.inits)
+ (monad.map ! (recur false)))
+ iteration' (recur return? (get@ #/.iteration scope))]
+ (wrap (/.loop/scope {#/.start (|> scope (get@ #/.start) (register_optimization offset))
+ #/.inits inits'
+ #/.iteration iteration'})))
+
+ (^ (/.loop/recur args))
+ (|> args
+ (monad.map maybe.monad (recur false))
+ (maybe\map (|>> /.loop/recur)))
+
+ (^ (/.function/abstraction [environment arity body]))
+ (do {! maybe.monad}
+ [environment' (monad.map ! (recur false) environment)]
+ (wrap (/.function/abstraction [environment' arity body])))
+
+ (^ (/.function/apply [abstraction arguments]))
+ (do {! maybe.monad}
+ [arguments' (monad.map maybe.monad (recur false) arguments)]
+ (with_expansions [<application> (as_is (do !
+ [abstraction' (recur false abstraction)]
+ (wrap (/.function/apply [abstraction' arguments']))))]
+ (case abstraction
+ (^ (#/.Reference (#reference.Variable (variable.self))))
+ (if (and return?
+ (n.= arity (list.size arguments)))
+ (wrap (/.loop/recur arguments'))
+ (if true_loop?
+ #.None
+ <application>))
+
+ _
+ <application>)))
+
+ (#/.Extension [name args])
+ (|> args
+ (monad.map maybe.monad (recur false))
+ (maybe\map (|>> [name] #/.Extension))))))
+
+(def: #export (optimization true_loop? offset inits functionS)
+ (-> Bit Register (List Synthesis) Abstraction (Maybe [Register (List Synthesis) Synthesis]))
+ (|> (get@ #/.body functionS)
+ (body_optimization true_loop? offset (get@ #/.environment functionS) (get@ #/.arity functionS))
+ (maybe\map (|>> [offset inits]))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/variable.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/variable.lux
new file mode 100644
index 000000000..07e7a54b9
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/variable.lux
@@ -0,0 +1,443 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." product]
+ ["." maybe ("#\." functor)]
+ ["." text
+ ["%" format]]
+ [collection
+ ["." dictionary (#+ Dictionary)]
+ ["." list ("#\." functor fold)]
+ ["." set]]]
+ [math
+ [number
+ ["n" nat]]]]]
+ [////
+ ["/" synthesis (#+ Path Synthesis)]
+ ["." analysis]
+ [///
+ [arity (#+ Arity)]
+ ["." reference
+ ["." variable (#+ Register Variable)]]]])
+
+(def: (prune redundant register)
+ (-> Register Register Register)
+ (if (n.> redundant register)
+ (dec register)
+ register))
+
+(type: (Remover a)
+ (-> Register (-> a a)))
+
+(def: (remove_local_from_path remove_local redundant)
+ (-> (Remover Synthesis) (Remover Path))
+ (function (recur path)
+ (case path
+ (#/.Seq (#/.Bind register)
+ post)
+ (if (n.= redundant register)
+ (recur post)
+ (#/.Seq (#/.Bind (if (n.> redundant register)
+ (dec register)
+ register))
+ (recur post)))
+
+ (^or (#/.Seq (#/.Access (#/.Member member))
+ (#/.Seq (#/.Bind register)
+ post))
+ ## This alternative form should never occur in practice.
+ ## Yet, it is "technically" possible to construct it.
+ (#/.Seq (#/.Seq (#/.Access (#/.Member member))
+ (#/.Bind register))
+ post))
+ (if (n.= redundant register)
+ (recur post)
+ (#/.Seq (#/.Access (#/.Member member))
+ (#/.Seq (#/.Bind (if (n.> redundant register)
+ (dec register)
+ register))
+ (recur post))))
+
+ (^template [<tag>]
+ [(<tag> left right)
+ (<tag> (recur left) (recur right))])
+ ([#/.Seq]
+ [#/.Alt])
+
+ (#/.Bit_Fork when then else)
+ (#/.Bit_Fork when (recur then) (maybe\map recur else))
+
+ (^template [<tag>]
+ [(<tag> [[test then] tail])
+ (<tag> [[test (recur then)]
+ (list\map (function (_ [test' then'])
+ [test' (recur then')])
+ tail)])])
+ ([#/.I64_Fork]
+ [#/.F64_Fork]
+ [#/.Text_Fork])
+
+ (^or #/.Pop
+ (#/.Access _))
+ path
+
+ (#/.Bind register)
+ (undefined)
+
+ (#/.Then then)
+ (#/.Then (remove_local redundant then))
+ )))
+
+(def: (remove_local_from_variable redundant variable)
+ (Remover Variable)
+ (case variable
+ (#variable.Local register)
+ (#variable.Local (..prune redundant register))
+
+ (#variable.Foreign register)
+ variable))
+
+(def: (remove_local redundant)
+ (Remover Synthesis)
+ (function (recur synthesis)
+ (case synthesis
+ (#/.Primitive _)
+ synthesis
+
+ (#/.Structure structure)
+ (#/.Structure (case structure
+ (#analysis.Variant [lefts right value])
+ (#analysis.Variant [lefts right (recur value)])
+
+ (#analysis.Tuple tuple)
+ (#analysis.Tuple (list\map recur tuple))))
+
+ (#/.Reference reference)
+ (case reference
+ (#reference.Variable variable)
+ (/.variable (..remove_local_from_variable redundant variable))
+
+ (#reference.Constant constant)
+ synthesis)
+
+ (#/.Control control)
+ (#/.Control (case control
+ (#/.Branch branch)
+ (#/.Branch (case branch
+ (#/.Let input register output)
+ (#/.Let (recur input)
+ (..prune redundant register)
+ (recur output))
+
+ (#/.If test then else)
+ (#/.If (recur test) (recur then) (recur else))
+
+ (#/.Get path record)
+ (#/.Get path (recur record))
+
+ (#/.Case input path)
+ (#/.Case (recur input) (remove_local_from_path remove_local redundant path))))
+
+ (#/.Loop loop)
+ (#/.Loop (case loop
+ (#/.Scope [start inits iteration])
+ (#/.Scope [(..prune redundant start)
+ (list\map recur inits)
+ (recur iteration)])
+
+ (#/.Recur resets)
+ (#/.Recur (list\map recur resets))))
+
+ (#/.Function function)
+ (#/.Function (case function
+ (#/.Abstraction [environment arity body])
+ (#/.Abstraction [(list\map recur environment)
+ arity
+ body])
+
+ (#/.Apply abstraction inputs)
+ (#/.Apply (recur abstraction) (list\map recur inputs))))))
+
+ (#/.Extension name inputs)
+ (#/.Extension name (list\map recur inputs)))))
+
+(type: Redundancy
+ (Dictionary Register Bit))
+
+(def: initial
+ Redundancy
+ (dictionary.new n.hash))
+
+(def: redundant! true)
+(def: necessary! false)
+
+(def: (extended offset amount redundancy)
+ (-> Register Nat Redundancy [(List Register) Redundancy])
+ (let [extension (|> amount list.indices (list\map (n.+ offset)))]
+ [extension
+ (list\fold (function (_ register redundancy)
+ (dictionary.put register ..necessary! redundancy))
+ redundancy
+ extension)]))
+
+(def: (default arity)
+ (-> Arity Redundancy)
+ (product.right (..extended 0 (inc arity) ..initial)))
+
+(type: (Optimization a)
+ (-> [Redundancy a] (Try [Redundancy a])))
+
+(def: (list_optimization optimization)
+ (All [a] (-> (Optimization a) (Optimization (List a))))
+ (function (recur [redundancy values])
+ (case values
+ #.Nil
+ (#try.Success [redundancy
+ values])
+
+ (#.Cons head tail)
+ (do try.monad
+ [[redundancy head] (optimization [redundancy head])
+ [redundancy tail] (recur [redundancy tail])]
+ (wrap [redundancy
+ (#.Cons head tail)])))))
+
+(template [<name>]
+ [(exception: #export (<name> {register Register})
+ (exception.report
+ ["Register" (%.nat register)]))]
+
+ [redundant_declaration]
+ [unknown_register]
+ )
+
+(def: (declare register redundancy)
+ (-> Register Redundancy (Try Redundancy))
+ (case (dictionary.get register redundancy)
+ #.None
+ (#try.Success (dictionary.put register ..redundant! redundancy))
+
+ (#.Some _)
+ (exception.throw ..redundant_declaration [register])))
+
+(def: (observe register redundancy)
+ (-> Register Redundancy (Try Redundancy))
+ (case (dictionary.get register redundancy)
+ #.None
+ (exception.throw ..unknown_register [register])
+
+ (#.Some _)
+ (#try.Success (dictionary.put register ..necessary! redundancy))))
+
+(def: (format redundancy)
+ (%.Format Redundancy)
+ (|> redundancy
+ dictionary.entries
+ (list\map (function (_ [register redundant?])
+ (%.format (%.nat register) ": " (%.bit redundant?))))
+ (text.join_with ", ")))
+
+(def: (path_optimization optimization)
+ (-> (Optimization Synthesis) (Optimization Path))
+ (function (recur [redundancy path])
+ (case path
+ (^or #/.Pop
+ (#/.Access _))
+ (#try.Success [redundancy
+ path])
+
+ (#/.Bit_Fork when then else)
+ (do {! try.monad}
+ [[redundancy then] (recur [redundancy then])
+ [redundancy else] (case else
+ (#.Some else)
+ (\ ! map
+ (function (_ [redundancy else])
+ [redundancy (#.Some else)])
+ (recur [redundancy else]))
+
+ #.None
+ (wrap [redundancy #.None]))]
+ (wrap [redundancy (#/.Bit_Fork when then else)]))
+
+ (^template [<tag> <type>]
+ [(<tag> [[test then] elses])
+ (do {! try.monad}
+ [[redundancy then] (recur [redundancy then])
+ [redundancy elses] (..list_optimization (: (Optimization [<type> Path])
+ (function (_ [redundancy [else_test else_then]])
+ (do !
+ [[redundancy else_then] (recur [redundancy else_then])]
+ (wrap [redundancy [else_test else_then]]))))
+ [redundancy elses])]
+ (wrap [redundancy (<tag> [[test then] elses])]))])
+ ([#/.I64_Fork (I64 Any)]
+ [#/.F64_Fork Frac]
+ [#/.Text_Fork Text])
+
+ (#/.Bind register)
+ (do try.monad
+ [redundancy (..declare register redundancy)]
+ (wrap [redundancy
+ path]))
+
+ (#/.Alt left right)
+ (do try.monad
+ [[redundancy left] (recur [redundancy left])
+ [redundancy right] (recur [redundancy right])]
+ (wrap [redundancy (#/.Alt left right)]))
+
+ (#/.Seq pre post)
+ (do try.monad
+ [#let [baseline (|> redundancy
+ dictionary.keys
+ (set.from_list n.hash))]
+ [redundancy pre] (recur [redundancy pre])
+ #let [bindings (|> redundancy
+ dictionary.keys
+ (set.from_list n.hash)
+ (set.difference baseline))]
+ [redundancy post] (recur [redundancy post])
+ #let [redundants (|> redundancy
+ dictionary.entries
+ (list.filter (function (_ [register redundant?])
+ (and (set.member? bindings register)
+ redundant?)))
+ (list\map product.left))]]
+ (wrap [(list\fold dictionary.remove redundancy (set.to_list bindings))
+ (|> redundants
+ (list.sort n.>)
+ (list\fold (..remove_local_from_path ..remove_local) (#/.Seq pre post)))]))
+
+ (#/.Then then)
+ (do try.monad
+ [[redundancy then] (optimization [redundancy then])]
+ (wrap [redundancy (#/.Then then)]))
+ )))
+
+(def: (optimization' [redundancy synthesis])
+ (Optimization Synthesis)
+ (with_expansions [<no_op> (as_is (#try.Success [redundancy
+ synthesis]))]
+ (case synthesis
+ (#/.Primitive _)
+ <no_op>
+
+ (#/.Structure structure)
+ (case structure
+ (#analysis.Variant [lefts right value])
+ (do try.monad
+ [[redundancy value] (optimization' [redundancy value])]
+ (wrap [redundancy
+ (#/.Structure (#analysis.Variant [lefts right value]))]))
+
+ (#analysis.Tuple tuple)
+ (do try.monad
+ [[redundancy tuple] (..list_optimization optimization' [redundancy tuple])]
+ (wrap [redundancy
+ (#/.Structure (#analysis.Tuple tuple))])))
+
+ (#/.Reference reference)
+ (case reference
+ (#reference.Variable variable)
+ (case variable
+ (#variable.Local register)
+ (do try.monad
+ [redundancy (..observe register redundancy)]
+ <no_op>)
+
+ (#variable.Foreign register)
+ <no_op>)
+
+ (#reference.Constant constant)
+ <no_op>)
+
+ (#/.Control control)
+ (case control
+ (#/.Branch branch)
+ (case branch
+ (#/.Let input register output)
+ (do try.monad
+ [[redundancy input] (optimization' [redundancy input])
+ redundancy (..declare register redundancy)
+ [redundancy output] (optimization' [redundancy output])
+ #let [redundant? (|> redundancy
+ (dictionary.get register)
+ (maybe.default ..necessary!))]]
+ (wrap [(dictionary.remove register redundancy)
+ (#/.Control (if redundant?
+ (#/.Branch (#/.Case input
+ (#/.Seq #/.Pop
+ (#/.Then (..remove_local register output)))))
+ (#/.Branch (#/.Let input register output))))]))
+
+ (#/.If test then else)
+ (do try.monad
+ [[redundancy test] (optimization' [redundancy test])
+ [redundancy then] (optimization' [redundancy then])
+ [redundancy else] (optimization' [redundancy else])]
+ (wrap [redundancy
+ (#/.Control (#/.Branch (#/.If test then else)))]))
+
+ (#/.Get path record)
+ (do try.monad
+ [[redundancy record] (optimization' [redundancy record])]
+ (wrap [redundancy
+ (#/.Control (#/.Branch (#/.Get path record)))]))
+
+ (#/.Case input path)
+ (do try.monad
+ [[redundancy input] (optimization' [redundancy input])
+ [redundancy path] (..path_optimization optimization' [redundancy path])]
+ (wrap [redundancy
+ (#/.Control (#/.Branch (#/.Case input path)))])))
+
+ (#/.Loop loop)
+ (case loop
+ (#/.Scope [start inits iteration])
+ (do try.monad
+ [[redundancy inits] (..list_optimization optimization' [redundancy inits])
+ #let [[extension redundancy] (..extended start (list.size inits) redundancy)]
+ [redundancy iteration] (optimization' [redundancy iteration])]
+ (wrap [(list\fold dictionary.remove redundancy extension)
+ (#/.Control (#/.Loop (#/.Scope [start inits iteration])))]))
+
+ (#/.Recur resets)
+ (do try.monad
+ [[redundancy resets] (..list_optimization optimization' [redundancy resets])]
+ (wrap [redundancy
+ (#/.Control (#/.Loop (#/.Recur resets)))])))
+
+ (#/.Function function)
+ (case function
+ (#/.Abstraction [environment arity body])
+ (do {! try.monad}
+ [[redundancy environment] (..list_optimization optimization' [redundancy environment])
+ [_ body] (optimization' [(..default arity) body])]
+ (wrap [redundancy
+ (#/.Control (#/.Function (#/.Abstraction [environment arity body])))]))
+
+ (#/.Apply abstraction inputs)
+ (do try.monad
+ [[redundancy abstraction] (optimization' [redundancy abstraction])
+ [redundancy inputs] (..list_optimization optimization' [redundancy inputs])]
+ (wrap [redundancy
+ (#/.Control (#/.Function (#/.Apply abstraction inputs)))]))))
+
+ (#/.Extension name inputs)
+ (do try.monad
+ [[redundancy inputs] (..list_optimization optimization' [redundancy inputs])]
+ (wrap [redundancy
+ (#/.Extension name inputs)])))))
+
+(def: #export optimization
+ (-> Synthesis (Try Synthesis))
+ (|>> [..initial]
+ optimization'
+ (\ try.monad map product.right)))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/program.lux b/stdlib/source/library/lux/tool/compiler/language/lux/program.lux
new file mode 100644
index 000000000..f33831904
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/program.lux
@@ -0,0 +1,57 @@
+(.module:
+ [library
+ [lux (#- Module)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." product]
+ ["." maybe]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]]]]]
+ [//
+ [generation (#+ Context)]
+ [///
+ [meta
+ ["." archive (#+ Archive)
+ ["." descriptor (#+ Module)]
+ ["." artifact]]]]])
+
+(type: #export (Program expression directive)
+ (-> Context expression directive))
+
+(def: #export name
+ Text
+ "")
+
+(exception: #export (cannot-find-program {modules (List Module)})
+ (exception.report
+ ["Modules" (exception.enumerate %.text modules)]))
+
+(def: #export (context archive)
+ (-> Archive (Try Context))
+ (do {! try.monad}
+ [registries (|> archive
+ archive.archived
+ (monad.map !
+ (function (_ module)
+ (do !
+ [id (archive.id module archive)
+ [descriptor document] (archive.find module archive)]
+ (wrap [[module id] (get@ #descriptor.registry descriptor)])))))]
+ (case (list.one (function (_ [[module module-id] registry])
+ (do maybe.monad
+ [program-id (artifact.remember ..name registry)]
+ (wrap [module-id program-id])))
+ registries)
+ (#.Some program-context)
+ (wrap program-context)
+
+ #.None
+ (|> registries
+ (list\map (|>> product.left product.left))
+ (exception.throw ..cannot-find-program)))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/syntax.lux b/stdlib/source/library/lux/tool/compiler/language/lux/syntax.lux
new file mode 100644
index 000000000..e41cd0f79
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/syntax.lux
@@ -0,0 +1,584 @@
+## This is LuxC's parser.
+## It takes the source code of a Lux file in raw text form and
+## extracts the syntactic structure of the code from it.
+## It only produces Lux Code nodes, and thus removes any white-space
+## and comments while processing its inputs.
+
+## Another important aspect of the parser is that it keeps track of
+## its position within the input data.
+## That is, the parser takes into account the line and column
+## information in the input text (it doesn't really touch the
+## file-name aspect of the location, leaving it intact in whatever
+## base-line location it is given).
+
+## This particular piece of functionality is not located in one
+## function, but it is instead scattered throughout several parsers,
+## since the logic for how to update the location varies, depending on
+## what is being parsed, and the rules involved.
+
+## You will notice that several parsers have a "where" parameter, that
+## tells them the location position prior to the parser being run.
+## They are supposed to produce some parsed output, alongside an
+## updated location pointing to the end position, after the parser was run.
+
+## Lux Code nodes/tokens are annotated with location meta-data
+## [file-name, line, column] to keep track of their provenance and
+## location, which is helpful for documentation and debugging.
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ [abstract
+ monad]
+ [control
+ ["." exception (#+ exception:)]
+ [parser
+ [text (#+ Offset)]]]
+ [data
+ ["." maybe]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list]
+ ["." dictionary (#+ Dictionary)]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["n" nat]
+ ["." int]
+ ["." rev]
+ ["." frac]]]]])
+
+(template: (inline: <declaration> <type> <body>)
+ (for {@.python (def: <declaration> <type> <body>)}
+ (template: <declaration> <body>)))
+
+## TODO: Implement "lux syntax char case!" as a custom extension.
+## That way, it should be possible to obtain the char without wrapping
+## it into a java.lang.Long, thereby improving performance.
+
+## TODO: Make an extension to take advantage of java/lang/String::indexOf<int,int>
+## to get better performance than the current "lux text index" extension.
+
+## TODO: Instead of always keeping a "where" location variable, keep the
+## individual components (i.e. file, line and column) separate, so
+## that updated the "where" only involved updating the components, and
+## producing the locations only involved building them, without any need
+## for pattern-matching and de-structuring.
+
+(type: Char
+ Nat)
+
+(template [<name> <extension> <diff>]
+ [(template: (<name> value)
+ (<extension> <diff> value))]
+
+ [!inc "lux i64 +" 1]
+ [!inc/2 "lux i64 +" 2]
+ [!dec "lux i64 -" 1]
+ )
+
+(template: (!clip from to text)
+ ("lux text clip" from (n.- from to) text))
+
+(template [<name> <extension>]
+ [(template: (<name> reference subject)
+ (<extension> reference subject))]
+
+ [!n/= "lux i64 ="]
+ [!i/< "lux i64 <"]
+ )
+
+(template [<name> <extension>]
+ [(template: (<name> param subject)
+ (<extension> param subject))]
+
+ [!n/+ "lux i64 +"]
+ [!n/- "lux i64 -"]
+ )
+
+(type: #export Aliases
+ (Dictionary Text Text))
+
+(def: #export no_aliases
+ Aliases
+ (dictionary.new text.hash))
+
+(def: #export prelude
+ .prelude_module)
+
+(def: #export text_delimiter text.double_quote)
+
+(template [<char> <definition>]
+ [(def: #export <definition> <char>)]
+
+ ## Form delimiters
+ ["(" open_form]
+ [")" close_form]
+
+ ## Tuple delimiters
+ ["[" open_tuple]
+ ["]" close_tuple]
+
+ ## Record delimiters
+ ["{" open_record]
+ ["}" close_record]
+
+ ["#" sigil]
+
+ ["," digit_separator]
+
+ ["+" positive_sign]
+ ["-" negative_sign]
+
+ ["." frac_separator]
+
+ ## The parts of a name are separated by a single mark.
+ ## E.g. module.short.
+ ## Only one such mark may be used in an name, since there
+ ## can only be 2 parts to a name (the module [before the
+ ## mark], and the short [after the mark]).
+ ## There are also some extra rules regarding name syntax,
+ ## encoded in the parser.
+ ["." name_separator]
+ )
+
+(exception: #export (end_of_file {module Text})
+ (exception.report
+ ["Module" (%.text module)]))
+
+(def: amount_of_input_shown 64)
+
+(inline: (input_at start input)
+ (-> Offset Text Text)
+ (let [end (|> start (!n/+ amount_of_input_shown) (n.min ("lux text size" input)))]
+ (!clip start end input)))
+
+(exception: #export (unrecognized_input {[file line column] Location} {context Text} {input Text} {offset Offset})
+ (exception.report
+ ["File" file]
+ ["Line" (%.nat line)]
+ ["Column" (%.nat column)]
+ ["Context" (%.text context)]
+ ["Input" (input_at offset input)]))
+
+(exception: #export (text_cannot_contain_new_lines {text Text})
+ (exception.report
+ ["Text" (%.text text)]))
+
+(template: (!failure parser where offset source_code)
+ (#.Left [[where offset source_code]
+ (exception.construct ..unrecognized_input [where (%.name (name_of parser)) source_code offset])]))
+
+(template: (!end_of_file where offset source_code current_module)
+ (#.Left [[where offset source_code]
+ (exception.construct ..end_of_file current_module)]))
+
+(type: (Parser a)
+ (-> Source (Either [Source Text] [Source a])))
+
+(template: (!with_char+ @source_code_size @source_code @offset @char @else @body)
+ (if (!i/< (:as Int @source_code_size)
+ (:as Int @offset))
+ (let [@char ("lux text char" @offset @source_code)]
+ @body)
+ @else))
+
+(template: (!with_char @source_code @offset @char @else @body)
+ (!with_char+ ("lux text size" @source_code) @source_code @offset @char @else @body))
+
+(template: (!letE <binding> <computation> <body>)
+ (case <computation>
+ (#.Right <binding>)
+ <body>
+
+ ## (#.Left error)
+ <<otherwise>>
+ (:assume <<otherwise>>)))
+
+(template: (!horizontal where offset source_code)
+ [(update@ #.column inc where)
+ (!inc offset)
+ source_code])
+
+(inline: (!new_line where)
+ (-> Location Location)
+ (let [[where::file where::line where::column] where]
+ [where::file (!inc where::line) 0]))
+
+(inline: (!forward length where)
+ (-> Nat Location Location)
+ (let [[where::file where::line where::column] where]
+ [where::file where::line (!n/+ length where::column)]))
+
+(template: (!vertical where offset source_code)
+ [(!new_line where)
+ (!inc offset)
+ source_code])
+
+(template [<name> <close> <tag>]
+ [(inline: (<name> parse where offset source_code)
+ (-> (Parser Code) Location Offset Text
+ (Either [Source Text] [Source Code]))
+ (loop [source (: Source [(!forward 1 where) offset source_code])
+ stack (: (List Code) #.Nil)]
+ (case (parse source)
+ (#.Right [source' top])
+ (recur source' (#.Cons top stack))
+
+ (#.Left [source' error])
+ (if (is? <close> error)
+ (#.Right [source'
+ [where (<tag> (list.reverse stack))]])
+ (#.Left [source' error])))))]
+
+ ## Form and tuple syntax is mostly the same, differing only in the
+ ## delimiters involved.
+ ## They may have an arbitrary number of arbitrary Code nodes as elements.
+ [parse_form ..close_form #.Form]
+ [parse_tuple ..close_tuple #.Tuple]
+ )
+
+(inline: (parse_record parse where offset source_code)
+ (-> (Parser Code) Location Offset Text
+ (Either [Source Text] [Source Code]))
+ (loop [source (: Source [(!forward 1 where) offset source_code])
+ stack (: (List [Code Code]) #.Nil)]
+ (case (parse source)
+ (#.Right [sourceF field])
+ (!letE [sourceFV value] (parse sourceF)
+ (recur sourceFV (#.Cons [field value] stack)))
+
+ (#.Left [source' error])
+ (if (is? ..close_record error)
+ (#.Right [source'
+ [where (#.Record (list.reverse stack))]])
+ (#.Left [source' error])))))
+
+(template: (!guarantee_no_new_lines where offset source_code content body)
+ (case ("lux text index" 0 (static text.new_line) content)
+ #.None
+ body
+
+ g!_
+ (#.Left [[where offset source_code]
+ (exception.construct ..text_cannot_contain_new_lines content)])))
+
+(def: (parse_text where offset source_code)
+ (-> Location Offset Text (Either [Source Text] [Source Code]))
+ (case ("lux text index" offset (static ..text_delimiter) source_code)
+ (#.Some g!end)
+ (<| (let [g!content (!clip offset g!end source_code)])
+ (!guarantee_no_new_lines where offset source_code g!content)
+ (#.Right [[(let [size (!n/- offset g!end)]
+ (update@ #.column (|>> (!n/+ size) (!n/+ 2)) where))
+ (!inc g!end)
+ source_code]
+ [where
+ (#.Text g!content)]]))
+
+ _
+ (!failure ..parse_text where offset source_code)))
+
+(with_expansions [<digits> (as_is "0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
+ <non_name_chars> (template [<char>]
+ [(~~ (static <char>))]
+
+ [text.space]
+ [text.new_line] [text.carriage_return]
+ [..name_separator]
+ [..open_form] [..close_form]
+ [..open_tuple] [..close_tuple]
+ [..open_record] [..close_record]
+ [..text_delimiter]
+ [..sigil])
+ <digit_separator> (static ..digit_separator)]
+ (template: (!if_digit? @char @then @else)
+ ("lux syntax char case!" @char
+ [[<digits>]
+ @then]
+
+ ## else
+ @else))
+
+ (template: (!if_digit?+ @char @then @else_options @else)
+ (`` ("lux syntax char case!" @char
+ [[<digits> <digit_separator>]
+ @then
+
+ (~~ (template.splice @else_options))]
+
+ ## else
+ @else)))
+
+ (`` (template: (!if_name_char?|tail @char @then @else)
+ ("lux syntax char case!" @char
+ [[<non_name_chars>]
+ @else]
+
+ ## else
+ @then)))
+
+ (`` (template: (!if_name_char?|head @char @then @else)
+ ("lux syntax char case!" @char
+ [[<non_name_chars> <digits>]
+ @else]
+
+ ## else
+ @then)))
+ )
+
+(template: (!number_output <source_code> <start> <end> <codec> <tag>)
+ (case (|> <source_code>
+ (!clip <start> <end>)
+ (text.replace_all ..digit_separator "")
+ (\ <codec> decode))
+ (#.Right output)
+ (#.Right [[(let [[where::file where::line where::column] where]
+ [where::file where::line (!n/+ (!n/- <start> <end>) where::column)])
+ <end>
+ <source_code>]
+ [where (<tag> output)]])
+
+ (#.Left error)
+ (#.Left [[where <start> <source_code>]
+ error])))
+
+(def: no_exponent Offset 0)
+
+(with_expansions [<int_output> (as_is (!number_output source_code start end int.decimal #.Int))
+ <frac_output> (as_is (!number_output source_code start end frac.decimal #.Frac))
+ <failure> (!failure ..parse_frac where offset source_code)
+ <frac_separator> (static ..frac_separator)
+ <signs> (template [<sign>]
+ [(~~ (static <sign>))]
+
+ [..positive_sign]
+ [..negative_sign])]
+ (inline: (parse_frac source_code//size start where offset source_code)
+ (-> Nat Nat Location Offset Text
+ (Either [Source Text] [Source Code]))
+ (loop [end offset
+ exponent (static ..no_exponent)]
+ (<| (!with_char+ source_code//size source_code end char/0 <frac_output>)
+ (!if_digit?+ char/0
+ (recur (!inc end) exponent)
+
+ [["e" "E"]
+ (if (is? (static ..no_exponent) exponent)
+ (<| (!with_char+ source_code//size source_code (!inc end) char/1 <failure>)
+ (`` ("lux syntax char case!" char/1
+ [[<signs>]
+ (<| (!with_char+ source_code//size source_code (!n/+ 2 end) char/2 <failure>)
+ (!if_digit?+ char/2
+ (recur (!n/+ 3 end) char/0)
+ []
+ <failure>))]
+ ## else
+ <failure>)))
+ <frac_output>)]
+
+ <frac_output>))))
+
+ (inline: (parse_signed source_code//size start where offset source_code)
+ (-> Nat Nat Location Offset Text
+ (Either [Source Text] [Source Code]))
+ (loop [end offset]
+ (<| (!with_char+ source_code//size source_code end char <int_output>)
+ (!if_digit?+ char
+ (recur (!inc end))
+
+ [[<frac_separator>]
+ (parse_frac source_code//size start where (!inc end) source_code)]
+
+ <int_output>))))
+ )
+
+(template [<parser> <codec> <tag>]
+ [(inline: (<parser> source_code//size start where offset source_code)
+ (-> Nat Nat Location Offset Text
+ (Either [Source Text] [Source Code]))
+ (loop [g!end offset]
+ (<| (!with_char+ source_code//size source_code g!end g!char (!number_output source_code start g!end <codec> <tag>))
+ (!if_digit?+ g!char
+ (recur (!inc g!end))
+ []
+ (!number_output source_code start g!end <codec> <tag>)))))]
+
+ [parse_nat n.decimal #.Nat]
+ [parse_rev rev.decimal #.Rev]
+ )
+
+(template: (!parse_signed source_code//size offset where source_code @aliases @end)
+ (<| (let [g!offset/1 (!inc offset)])
+ (!with_char+ source_code//size source_code g!offset/1 g!char/1 @end)
+ (!if_digit? g!char/1
+ (parse_signed source_code//size offset where (!inc/2 offset) source_code)
+ (!parse_full_name offset [where (!inc offset) source_code] where @aliases #.Identifier))))
+
+(with_expansions [<output> (#.Right [[(update@ #.column (|>> (!n/+ (!n/- start end))) where)
+ end
+ source_code]
+ (!clip start end source_code)])]
+ (inline: (parse_name_part start where offset source_code)
+ (-> Nat Location Offset Text
+ (Either [Source Text] [Source Text]))
+ (let [source_code//size ("lux text size" source_code)]
+ (loop [end offset]
+ (<| (!with_char+ source_code//size source_code end char <output>)
+ (!if_name_char?|tail char
+ (recur (!inc end))
+ <output>))))))
+
+(template: (!parse_half_name @offset @char @module)
+ (!if_name_char?|head @char
+ (!letE [source' name] (..parse_name_part @offset where (!inc @offset) source_code)
+ (#.Right [source' [@module name]]))
+ (!failure ..!parse_half_name where @offset source_code)))
+
+(`` (def: (parse_short_name source_code//size current_module [where offset/0 source_code])
+ (-> Nat Text (Parser Name))
+ (<| (!with_char+ source_code//size source_code offset/0 char/0
+ (!end_of_file where offset/0 source_code current_module))
+ (if (!n/= (char (~~ (static ..name_separator))) char/0)
+ (<| (let [offset/1 (!inc offset/0)])
+ (!with_char+ source_code//size source_code offset/1 char/1
+ (!end_of_file where offset/1 source_code current_module))
+ (!parse_half_name offset/1 char/1 current_module))
+ (!parse_half_name offset/0 char/0 (static ..prelude))))))
+
+(template: (!parse_short_name source_code//size @current_module @source @where @tag)
+ (!letE [source' name] (..parse_short_name source_code//size @current_module @source)
+ (#.Right [source' [@where (@tag name)]])))
+
+(with_expansions [<simple> (as_is (#.Right [source' ["" simple]]))]
+ (`` (def: (parse_full_name aliases start source)
+ (-> Aliases Offset (Parser Name))
+ (<| (!letE [source' simple] (let [[where offset source_code] source]
+ (..parse_name_part start where offset source_code)))
+ (let [[where' offset' source_code'] source'])
+ (!with_char source_code' offset' char/separator <simple>)
+ (if (!n/= (char (~~ (static ..name_separator))) char/separator)
+ (<| (let [offset'' (!inc offset')])
+ (!letE [source'' complex] (..parse_name_part offset'' (!forward 1 where') offset'' source_code'))
+ (if ("lux text =" "" complex)
+ (let [[where offset source_code] source]
+ (!failure ..parse_full_name where offset source_code))
+ (#.Right [source'' [(|> aliases
+ (dictionary.get simple)
+ (maybe.default simple))
+ complex]])))
+ <simple>)))))
+
+(template: (!parse_full_name @offset @source @where @aliases @tag)
+ (!letE [source' full_name] (..parse_full_name @aliases @offset @source)
+ (#.Right [source' [@where (@tag full_name)]])))
+
+## TODO: Grammar macro for specifying syntax.
+## (grammar: lux_grammar
+## [expression ...]
+## [form "(" [#* expression] ")"])
+
+(with_expansions [<consume_1> (as_is where (!inc offset/0) source_code)
+ <move_1> (as_is [(!forward 1 where) (!inc offset/0) source_code])
+ <move_2> (as_is [(!forward 1 where) (!inc/2 offset/0) source_code])
+ <recur> (as_is (parse current_module aliases source_code//size))
+ <horizontal_move> (as_is (recur (!horizontal where offset/0 source_code)))]
+
+ (template: (!close closer)
+ (#.Left [<move_1> closer]))
+
+ (def: #export (parse current_module aliases source_code//size)
+ (-> Text Aliases Nat (Parser Code))
+ ## The "exec []" is only there to avoid function fusion.
+ ## This is to preserve the loop as much as possible and keep it tight.
+ (exec []
+ (function (recur [where offset/0 source_code])
+ (<| (!with_char+ source_code//size source_code offset/0 char/0
+ (!end_of_file where offset/0 source_code current_module))
+ (with_expansions [<composites> (template [<open> <close> <parser>]
+ [[(~~ (static <open>))]
+ (<parser> <recur> <consume_1>)
+
+ [(~~ (static <close>))]
+ (!close <close>)]
+
+ [..open_form ..close_form parse_form]
+ [..open_tuple ..close_tuple parse_tuple]
+ [..open_record ..close_record parse_record]
+ )]
+ (`` ("lux syntax char case!" char/0
+ [[(~~ (static text.space))
+ (~~ (static text.carriage_return))]
+ <horizontal_move>
+
+ ## New line
+ [(~~ (static text.new_line))]
+ (recur (!vertical where offset/0 source_code))
+
+ <composites>
+
+ ## Text
+ [(~~ (static ..text_delimiter))]
+ (parse_text where (!inc offset/0) source_code)
+
+ ## Special code
+ [(~~ (static ..sigil))]
+ (<| (let [offset/1 (!inc offset/0)])
+ (!with_char+ source_code//size source_code offset/1 char/1
+ (!end_of_file where offset/1 source_code current_module))
+ ("lux syntax char case!" char/1
+ [[(~~ (static ..name_separator))]
+ (!parse_short_name source_code//size current_module <move_2> where #.Tag)
+
+ ## Single_line comment
+ [(~~ (static ..sigil))]
+ (case ("lux text index" (!inc offset/1) (static text.new_line) source_code)
+ (#.Some end)
+ (recur (!vertical where end source_code))
+
+ _
+ (!end_of_file where offset/1 source_code current_module))
+
+ (~~ (template [<char> <bit>]
+ [[<char>]
+ (#.Right [[(update@ #.column (|>> !inc/2) where)
+ (!inc offset/1)
+ source_code]
+ [where (#.Bit <bit>)]])]
+
+ ["0" #0]
+ ["1" #1]))]
+
+ ## else
+ (!if_name_char?|head char/1
+ ## Tag
+ (!parse_full_name offset/1 <move_2> where aliases #.Tag)
+ (!failure ..parse where offset/0 source_code))))
+
+ ## Coincidentally (= ..name_separator ..frac_separator)
+ [(~~ (static ..name_separator))
+ ## (~~ (static ..frac_separator))
+ ]
+ (<| (let [offset/1 (!inc offset/0)])
+ (!with_char+ source_code//size source_code offset/1 char/1
+ (!end_of_file where offset/1 source_code current_module))
+ (!if_digit? char/1
+ (parse_rev source_code//size offset/0 where (!inc offset/1) source_code)
+ (!parse_short_name source_code//size current_module [where offset/1 source_code] where #.Identifier)))
+
+ [(~~ (static ..positive_sign))
+ (~~ (static ..negative_sign))]
+ (!parse_signed source_code//size offset/0 where source_code aliases
+ (!end_of_file where offset/0 source_code current_module))]
+
+ ## else
+ (!if_digit? char/0
+ ## Natural number
+ (parse_nat source_code//size offset/0 where (!inc offset/0) source_code)
+ ## Identifier
+ (!parse_full_name offset/0 [<consume_1>] where aliases #.Identifier))
+ )))
+ )))
+ ))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/synthesis.lux
new file mode 100644
index 000000000..cec608916
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/synthesis.lux
@@ -0,0 +1,809 @@
+(.module:
+ [library
+ [lux (#- i64 Scope)
+ [abstract
+ [monad (#+ do)]
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]]
+ [control
+ [pipe (#+ case>)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." sum]
+ ["." product]
+ ["." maybe]
+ ["." bit ("#\." equivalence)]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ Format format)]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." dictionary (#+ Dictionary)]]]
+ [math
+ [number
+ ["." i64]
+ ["n" nat]
+ ["i" int]
+ ["f" frac]]]]]
+ [//
+ ["." analysis (#+ Environment Composite Analysis)]
+ [phase
+ ["." extension (#+ Extension)]]
+ [///
+ [arity (#+ Arity)]
+ ["." phase]
+ ["." reference (#+ Reference)
+ ["." variable (#+ Register Variable)]]]])
+
+(type: #export Resolver
+ (Dictionary Variable Variable))
+
+(type: #export State
+ {#locals Nat
+ ## https://en.wikipedia.org/wiki/Currying
+ #currying? Bit})
+
+(def: #export fresh_resolver
+ Resolver
+ (dictionary.new variable.hash))
+
+(def: #export init
+ State
+ {#locals 0
+ #currying? false})
+
+(type: #export Primitive
+ (#Bit Bit)
+ (#I64 (I64 Any))
+ (#F64 Frac)
+ (#Text Text))
+
+(type: #export Side
+ (Either Nat Nat))
+
+(type: #export Member
+ (Either Nat Nat))
+
+(type: #export Access
+ (#Side Side)
+ (#Member Member))
+
+(type: #export (Fork value next)
+ [[value next] (List [value next])])
+
+(type: #export (Path' s)
+ #Pop
+ (#Access Access)
+ (#Bind Register)
+ (#Bit_Fork Bit (Path' s) (Maybe (Path' s)))
+ (#I64_Fork (Fork (I64 Any) (Path' s)))
+ (#F64_Fork (Fork Frac (Path' s)))
+ (#Text_Fork (Fork Text (Path' s)))
+ (#Alt (Path' s) (Path' s))
+ (#Seq (Path' s) (Path' s))
+ (#Then s))
+
+(type: #export (Abstraction' s)
+ {#environment (Environment s)
+ #arity Arity
+ #body s})
+
+(type: #export (Apply' s)
+ {#function s
+ #arguments (List s)})
+
+(type: #export (Branch s)
+ (#Let s Register s)
+ (#If s s s)
+ (#Get (List Member) s)
+ (#Case s (Path' s)))
+
+(type: #export (Scope s)
+ {#start Register
+ #inits (List s)
+ #iteration s})
+
+(type: #export (Loop s)
+ (#Scope (Scope s))
+ (#Recur (List s)))
+
+(type: #export (Function s)
+ (#Abstraction (Abstraction' s))
+ (#Apply s (List s)))
+
+(type: #export (Control s)
+ (#Branch (Branch s))
+ (#Loop (Loop s))
+ (#Function (Function s)))
+
+(type: #export #rec Synthesis
+ (#Primitive Primitive)
+ (#Structure (Composite Synthesis))
+ (#Reference Reference)
+ (#Control (Control Synthesis))
+ (#Extension (Extension Synthesis)))
+
+(template [<special> <general>]
+ [(type: #export <special>
+ (<general> ..State Analysis Synthesis))]
+
+ [State+ extension.State]
+ [Operation extension.Operation]
+ [Phase extension.Phase]
+ [Handler extension.Handler]
+ [Bundle extension.Bundle]
+ )
+
+(type: #export Path
+ (Path' Synthesis))
+
+(def: #export path/pop
+ Path
+ #Pop)
+
+(template [<name> <kind>]
+ [(template: #export (<name> content)
+ (.<| #..Access
+ <kind>
+ content))]
+
+ [path/side #..Side]
+ [path/member #..Member]
+ )
+
+(template [<name> <kind> <side>]
+ [(template: #export (<name> content)
+ (.<| #..Access
+ <kind>
+ <side>
+ content))]
+
+ [side/left #..Side #.Left]
+ [side/right #..Side #.Right]
+ [member/left #..Member #.Left]
+ [member/right #..Member #.Right]
+ )
+
+(template [<name> <tag>]
+ [(template: #export (<name> content)
+ (<tag> content))]
+
+ [path/bind #..Bind]
+ [path/then #..Then]
+ )
+
+(template [<name> <tag>]
+ [(template: #export (<name> left right)
+ (<tag> [left right]))]
+
+ [path/alt #..Alt]
+ [path/seq #..Seq]
+ )
+
+(type: #export Abstraction
+ (Abstraction' Synthesis))
+
+(type: #export Apply
+ (Apply' Synthesis))
+
+(def: #export unit Text "")
+
+(template [<with> <query> <tag> <type>]
+ [(def: #export (<with> value)
+ (-> <type> (All [a] (-> (Operation a) (Operation a))))
+ (extension.temporary (set@ <tag> value)))
+
+ (def: #export <query>
+ (Operation <type>)
+ (extension.read (get@ <tag>)))]
+
+ [with_locals locals #locals Nat]
+ [with_currying? currying? #currying? Bit]
+ )
+
+(def: #export with_new_local
+ (All [a] (-> (Operation a) (Operation a)))
+ (<<| (do phase.monad
+ [locals ..locals])
+ (..with_locals (inc locals))))
+
+(template [<name> <tag>]
+ [(template: #export (<name> content)
+ (#..Primitive (<tag> content)))]
+
+ [bit #..Bit]
+ [i64 #..I64]
+ [f64 #..F64]
+ [text #..Text]
+ )
+
+(template [<name> <tag>]
+ [(template: #export (<name> content)
+ (<| #..Structure
+ <tag>
+ content))]
+
+ [variant #analysis.Variant]
+ [tuple #analysis.Tuple]
+ )
+
+(template [<name> <tag>]
+ [(template: #export (<name> content)
+ (.<| #..Reference
+ <tag>
+ content))]
+
+ [variable reference.variable]
+ [constant reference.constant]
+ [variable/local reference.local]
+ [variable/foreign reference.foreign]
+ )
+
+(template [<name> <family> <tag>]
+ [(template: #export (<name> content)
+ (.<| #..Control
+ <family>
+ <tag>
+ content))]
+
+ [branch/case #..Branch #..Case]
+ [branch/let #..Branch #..Let]
+ [branch/if #..Branch #..If]
+ [branch/get #..Branch #..Get]
+
+ [loop/recur #..Loop #..Recur]
+ [loop/scope #..Loop #..Scope]
+
+ [function/abstraction #..Function #..Abstraction]
+ [function/apply #..Function #..Apply]
+ )
+
+(def: #export (%path' %then value)
+ (All [a] (-> (Format a) (Format (Path' a))))
+ (case value
+ #Pop
+ "_"
+
+ (#Bit_Fork when then else)
+ (format "(?"
+ " " (%.bit when) " " (%path' %then then)
+ (case else
+ (#.Some else)
+ (format " " (%.bit (not when)) " " (%path' %then else))
+
+ #.None
+ "")
+ ")")
+
+ (^template [<tag> <format>]
+ [(<tag> cons)
+ (|> (#.Cons cons)
+ (list\map (function (_ [test then])
+ (format (<format> test) " " (%path' %then then))))
+ (text.join_with " ")
+ (text.enclose ["(? " ")"]))])
+ ([#I64_Fork (|>> .int %.int)]
+ [#F64_Fork %.frac]
+ [#Text_Fork %.text])
+
+ (#Access access)
+ (case access
+ (#Side side)
+ (case side
+ (#.Left lefts)
+ (format "(" (%.nat lefts) " #0" ")")
+
+ (#.Right lefts)
+ (format "(" (%.nat lefts) " #1" ")"))
+
+ (#Member member)
+ (case member
+ (#.Left lefts)
+ (format "[" (%.nat lefts) " #0" "]")
+
+ (#.Right lefts)
+ (format "[" (%.nat lefts) " #1" "]")))
+
+ (#Bind register)
+ (format "(@ " (%.nat register) ")")
+
+ (#Alt left right)
+ (format "(| " (%path' %then left) " " (%path' %then right) ")")
+
+ (#Seq left right)
+ (format "(& " (%path' %then left) " " (%path' %then right) ")")
+
+ (#Then then)
+ (|> (%then then)
+ (text.enclose ["(! " ")"]))))
+
+(def: #export (%synthesis value)
+ (Format Synthesis)
+ (case value
+ (#Primitive primitive)
+ (case primitive
+ (^template [<pattern> <format>]
+ [(<pattern> value)
+ (<format> value)])
+ ([#Bit %.bit]
+ [#F64 %.frac]
+ [#Text %.text])
+
+ (#I64 value)
+ (%.int (.int value)))
+
+ (#Structure structure)
+ (case structure
+ (#analysis.Variant [lefts right? content])
+ (|> (%synthesis content)
+ (format (%.nat lefts) " " (%.bit right?) " ")
+ (text.enclose ["(" ")"]))
+
+ (#analysis.Tuple members)
+ (|> members
+ (list\map %synthesis)
+ (text.join_with " ")
+ (text.enclose ["[" "]"])))
+
+ (#Reference reference)
+ (reference.format reference)
+
+ (#Control control)
+ (case control
+ (#Function function)
+ (case function
+ (#Abstraction [environment arity body])
+ (let [environment' (|> environment
+ (list\map %synthesis)
+ (text.join_with " ")
+ (text.enclose ["[" "]"]))]
+ (|> (format environment' " " (%.nat arity) " " (%synthesis body))
+ (text.enclose ["(#function " ")"])))
+
+ (#Apply func args)
+ (|> args
+ (list\map %synthesis)
+ (text.join_with " ")
+ (format (%synthesis func) " ")
+ (text.enclose ["(" ")"])))
+
+ (#Branch branch)
+ (case branch
+ (#Let input register body)
+ (|> (format (%.nat register) " " (%synthesis input) " " (%synthesis body))
+ (text.enclose ["(#let " ")"]))
+
+ (#If test then else)
+ (|> (format (%synthesis test) " " (%synthesis then) " " (%synthesis else))
+ (text.enclose ["(#if " ")"]))
+
+ (#Get members record)
+ (|> (format (%.list (%path' %synthesis)
+ (list\map (|>> #Member #Access) members))
+ " " (%synthesis record))
+ (text.enclose ["(#get " ")"]))
+
+ (#Case input path)
+ (|> (format (%synthesis input) " " (%path' %synthesis path))
+ (text.enclose ["(#case " ")"])))
+
+ (#Loop loop)
+ (case loop
+ (#Scope scope)
+ (|> (format (%.nat (get@ #start scope))
+ " " (|> (get@ #inits scope)
+ (list\map %synthesis)
+ (text.join_with " ")
+ (text.enclose ["[" "]"]))
+ " " (%synthesis (get@ #iteration scope)))
+ (text.enclose ["(#loop " ")"]))
+
+ (#Recur args)
+ (|> args
+ (list\map %synthesis)
+ (text.join_with " ")
+ (text.enclose ["(#recur " ")"]))))
+
+ (#Extension [name args])
+ (|> (list\map %synthesis args)
+ (text.join_with " ")
+ (format (%.text name) " ")
+ (text.enclose ["(" ")"]))))
+
+(def: #export %path
+ (Format Path)
+ (%path' %synthesis))
+
+(implementation: #export primitive_equivalence
+ (Equivalence Primitive)
+
+ (def: (= reference sample)
+ (case [reference sample]
+ (^template [<tag> <eq> <format>]
+ [[(<tag> reference') (<tag> sample')]
+ (<eq> reference' sample')])
+ ([#Bit bit\= %.bit]
+ [#F64 f.= %.frac]
+ [#Text text\= %.text])
+
+ [(#I64 reference') (#I64 sample')]
+ (i.= (.int reference') (.int sample'))
+
+ _
+ false)))
+
+(implementation: primitive_hash
+ (Hash Primitive)
+
+ (def: &equivalence ..primitive_equivalence)
+
+ (def: hash
+ (|>> (case> (^template [<tag> <hash>]
+ [(<tag> value')
+ (\ <hash> hash value')])
+ ([#Bit bit.hash]
+ [#F64 f.hash]
+ [#Text text.hash]
+ [#I64 i64.hash])))))
+
+(def: side_equivalence
+ (Equivalence Side)
+ (sum.equivalence n.equivalence n.equivalence))
+
+(def: member_equivalence
+ (Equivalence Member)
+ (sum.equivalence n.equivalence n.equivalence))
+
+(def: member_hash
+ (Hash Member)
+ (sum.hash n.hash n.hash))
+
+(implementation: #export access_equivalence
+ (Equivalence Access)
+
+ (def: (= reference sample)
+ (case [reference sample]
+ (^template [<tag> <equivalence>]
+ [[(<tag> reference) (<tag> sample)]
+ (\ <equivalence> = reference sample)])
+ ([#Side ..side_equivalence]
+ [#Member ..member_equivalence])
+
+ _
+ false)))
+
+(implementation: access_hash
+ (Hash Access)
+
+ (def: &equivalence ..access_equivalence)
+
+ (def: (hash value)
+ (let [sub_hash (sum.hash n.hash n.hash)]
+ (case value
+ (^template [<tag>]
+ [(<tag> value)
+ (\ sub_hash hash value)])
+ ([#Side]
+ [#Member])))))
+
+(implementation: #export (path'_equivalence equivalence)
+ (All [a] (-> (Equivalence a) (Equivalence (Path' a))))
+
+ (def: (= reference sample)
+ (case [reference sample]
+ [#Pop #Pop]
+ true
+
+ [(#Bit_Fork reference_when reference_then reference_else)
+ (#Bit_Fork sample_when sample_then sample_else)]
+ (and (bit\= reference_when sample_when)
+ (= reference_then sample_then)
+ (\ (maybe.equivalence =) = reference_else sample_else))
+
+ (^template [<tag> <equivalence>]
+ [[(<tag> reference_cons)
+ (<tag> sample_cons)]
+ (\ (list.equivalence (product.equivalence <equivalence> =)) =
+ (#.Cons reference_cons)
+ (#.Cons sample_cons))])
+ ([#I64_Fork i64.equivalence]
+ [#F64_Fork f.equivalence]
+ [#Text_Fork text.equivalence])
+
+ (^template [<tag> <equivalence>]
+ [[(<tag> reference') (<tag> sample')]
+ (\ <equivalence> = reference' sample')])
+ ([#Access ..access_equivalence]
+ [#Then equivalence])
+
+ [(#Bind reference') (#Bind sample')]
+ (n.= reference' sample')
+
+ (^template [<tag>]
+ [[(<tag> leftR rightR) (<tag> leftS rightS)]
+ (and (= leftR leftS)
+ (= rightR rightS))])
+ ([#Alt]
+ [#Seq])
+
+ _
+ false)))
+
+(implementation: (path'_hash super)
+ (All [a] (-> (Hash a) (Hash (Path' a))))
+
+ (def: &equivalence
+ (..path'_equivalence (\ super &equivalence)))
+
+ (def: (hash value)
+ (case value
+ #Pop
+ 2
+
+ (#Access access)
+ (n.* 3 (\ ..access_hash hash access))
+
+ (#Bind register)
+ (n.* 5 (\ n.hash hash register))
+
+ (#Bit_Fork when then else)
+ ($_ n.* 7
+ (\ bit.hash hash when)
+ (hash then)
+ (\ (maybe.hash (path'_hash super)) hash else))
+
+ (^template [<factor> <tag> <hash>]
+ [(<tag> cons)
+ (let [case_hash (product.hash <hash>
+ (path'_hash super))
+ cons_hash (product.hash case_hash (list.hash case_hash))]
+ (n.* <factor> (\ cons_hash hash cons)))])
+ ([11 #I64_Fork i64.hash]
+ [13 #F64_Fork f.hash]
+ [17 #Text_Fork text.hash])
+
+ (^template [<factor> <tag>]
+ [(<tag> fork)
+ (let [recur_hash (path'_hash super)
+ fork_hash (product.hash recur_hash recur_hash)]
+ (n.* <factor> (\ fork_hash hash fork)))])
+ ([19 #Alt]
+ [23 #Seq])
+
+ (#Then body)
+ (n.* 29 (\ super hash body))
+ )))
+
+(implementation: (branch_equivalence (^open "\."))
+ (All [a] (-> (Equivalence a) (Equivalence (Branch a))))
+
+ (def: (= reference sample)
+ (case [reference sample]
+ [(#Let [reference_input reference_register reference_body])
+ (#Let [sample_input sample_register sample_body])]
+ (and (\= reference_input sample_input)
+ (n.= reference_register sample_register)
+ (\= reference_body sample_body))
+
+ [(#If [reference_test reference_then reference_else])
+ (#If [sample_test sample_then sample_else])]
+ (and (\= reference_test sample_test)
+ (\= reference_then sample_then)
+ (\= reference_else sample_else))
+
+ [(#Get [reference_path reference_record])
+ (#Get [sample_path sample_record])]
+ (and (\ (list.equivalence ..member_equivalence) = reference_path sample_path)
+ (\= reference_record sample_record))
+
+ [(#Case [reference_input reference_path])
+ (#Case [sample_input sample_path])]
+ (and (\= reference_input sample_input)
+ (\ (path'_equivalence \=) = reference_path sample_path))
+
+ _
+ false)))
+
+(implementation: (branch_hash super)
+ (All [a] (-> (Hash a) (Hash (Branch a))))
+
+ (def: &equivalence
+ (..branch_equivalence (\ super &equivalence)))
+
+ (def: (hash value)
+ (case value
+ (#Let [input register body])
+ ($_ n.* 2
+ (\ super hash input)
+ (\ n.hash hash register)
+ (\ super hash body))
+
+ (#If [test then else])
+ ($_ n.* 3
+ (\ super hash test)
+ (\ super hash then)
+ (\ super hash else))
+
+ (#Get [path record])
+ ($_ n.* 5
+ (\ (list.hash ..member_hash) hash path)
+ (\ super hash record))
+
+ (#Case [input path])
+ ($_ n.* 7
+ (\ super hash input)
+ (\ (..path'_hash super) hash path))
+ )))
+
+(implementation: (loop_equivalence (^open "\."))
+ (All [a] (-> (Equivalence a) (Equivalence (Loop a))))
+
+ (def: (= reference sample)
+ (case [reference sample]
+ [(#Scope [reference_start reference_inits reference_iteration])
+ (#Scope [sample_start sample_inits sample_iteration])]
+ (and (n.= reference_start sample_start)
+ (\ (list.equivalence \=) = reference_inits sample_inits)
+ (\= reference_iteration sample_iteration))
+
+ [(#Recur reference) (#Recur sample)]
+ (\ (list.equivalence \=) = reference sample)
+
+ _
+ false)))
+
+(implementation: (loop_hash super)
+ (All [a] (-> (Hash a) (Hash (Loop a))))
+
+ (def: &equivalence
+ (..loop_equivalence (\ super &equivalence)))
+
+ (def: (hash value)
+ (case value
+ (#Scope [start inits iteration])
+ ($_ n.* 2
+ (\ n.hash hash start)
+ (\ (list.hash super) hash inits)
+ (\ super hash iteration))
+
+ (#Recur resets)
+ ($_ n.* 3
+ (\ (list.hash super) hash resets))
+ )))
+
+(implementation: (function_equivalence (^open "\."))
+ (All [a] (-> (Equivalence a) (Equivalence (Function a))))
+
+ (def: (= reference sample)
+ (case [reference sample]
+ [(#Abstraction [reference_environment reference_arity reference_body])
+ (#Abstraction [sample_environment sample_arity sample_body])]
+ (and (\ (list.equivalence \=) = reference_environment sample_environment)
+ (n.= reference_arity sample_arity)
+ (\= reference_body sample_body))
+
+ [(#Apply [reference_abstraction reference_arguments])
+ (#Apply [sample_abstraction sample_arguments])]
+ (and (\= reference_abstraction sample_abstraction)
+ (\ (list.equivalence \=) = reference_arguments sample_arguments))
+
+ _
+ false)))
+
+(implementation: (function_hash super)
+ (All [a] (-> (Hash a) (Hash (Function a))))
+
+ (def: &equivalence
+ (..function_equivalence (\ super &equivalence)))
+
+ (def: (hash value)
+ (case value
+ (#Abstraction [environment arity body])
+ ($_ n.* 2
+ (\ (list.hash super) hash environment)
+ (\ n.hash hash arity)
+ (\ super hash body))
+
+ (#Apply [abstraction arguments])
+ ($_ n.* 3
+ (\ super hash abstraction)
+ (\ (list.hash super) hash arguments))
+ )))
+
+(implementation: (control_equivalence (^open "\."))
+ (All [a] (-> (Equivalence a) (Equivalence (Control a))))
+
+ (def: (= reference sample)
+ (case [reference sample]
+ (^template [<tag> <equivalence>]
+ [[(<tag> reference) (<tag> sample)]
+ (\ (<equivalence> \=) = reference sample)])
+ ([#Branch ..branch_equivalence]
+ [#Loop ..loop_equivalence]
+ [#Function ..function_equivalence])
+
+ _
+ false)))
+
+(implementation: (control_hash super)
+ (All [a] (-> (Hash a) (Hash (Control a))))
+
+ (def: &equivalence
+ (..control_equivalence (\ super &equivalence)))
+
+ (def: (hash value)
+ (case value
+ (^template [<factor> <tag> <hash>]
+ [(<tag> value)
+ (n.* <factor> (\ (<hash> super) hash value))])
+ ([2 #Branch ..branch_hash]
+ [3 #Loop ..loop_hash]
+ [5 #Function ..function_hash])
+ )))
+
+(implementation: #export equivalence
+ (Equivalence Synthesis)
+
+ (def: (= reference sample)
+ (case [reference sample]
+ (^template [<tag> <equivalence>]
+ [[(<tag> reference') (<tag> sample')]
+ (\ <equivalence> = reference' sample')])
+ ([#Primitive ..primitive_equivalence]
+ [#Structure (analysis.composite_equivalence =)]
+ [#Reference reference.equivalence]
+ [#Control (control_equivalence =)]
+ [#Extension (extension.equivalence =)])
+
+ _
+ false)))
+
+(def: #export path_equivalence
+ (Equivalence Path)
+ (path'_equivalence equivalence))
+
+(implementation: #export hash
+ (Hash Synthesis)
+
+ (def: &equivalence ..equivalence)
+
+ (def: (hash value)
+ (let [recur_hash [..equivalence hash]]
+ (case value
+ (^template [<tag> <hash>]
+ [(<tag> value)
+ (\ <hash> hash value)])
+ ([#Primitive ..primitive_hash]
+ [#Structure (analysis.composite_hash recur_hash)]
+ [#Reference reference.hash]
+ [#Control (..control_hash recur_hash)]
+ [#Extension (extension.hash recur_hash)])))))
+
+(template: #export (!bind_top register thenP)
+ ($_ ..path/seq
+ (#..Bind register)
+ #..Pop
+ thenP))
+
+(template: #export (!multi_pop nextP)
+ ($_ ..path/seq
+ #..Pop
+ #..Pop
+ nextP))
+
+## TODO: There are sister patterns to the simple side checks for tuples.
+## These correspond to the situation where tuple members are accessed
+## and bound to variables, but those variables are never used, so they
+## become POPs.
+## After re-implementing unused-variable-elimination, must add those
+## pattern-optimizations again, since a lot of BINDs will become POPs
+## and thus will result in useless code being generated.
+(template [<name> <side>]
+ [(template: #export (<name> idx nextP)
+ ($_ ..path/seq
+ (<side> idx)
+ #..Pop
+ nextP))]
+
+ [simple_left_side ..side/left]
+ [simple_right_side ..side/right]
+ )
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/version.lux b/stdlib/source/library/lux/tool/compiler/language/lux/version.lux
new file mode 100644
index 000000000..dd3676068
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/version.lux
@@ -0,0 +1,9 @@
+(.module:
+ [library
+ [lux #*]]
+ [////
+ [version (#+ Version)]])
+
+(def: #export version
+ Version
+ 00,06,00)
diff --git a/stdlib/source/library/lux/tool/compiler/meta.lux b/stdlib/source/library/lux/tool/compiler/meta.lux
new file mode 100644
index 000000000..23cacb4aa
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/meta.lux
@@ -0,0 +1,9 @@
+(.module:
+ [library
+ [lux #*]]
+ [//
+ [version (#+ Version)]])
+
+(def: #export version
+ Version
+ 00,01,00)
diff --git a/stdlib/source/library/lux/tool/compiler/meta/archive.lux b/stdlib/source/library/lux/tool/compiler/meta/archive.lux
new file mode 100644
index 000000000..d04f1227f
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/meta/archive.lux
@@ -0,0 +1,280 @@
+(.module:
+ [library
+ [lux (#- Module)
+ [abstract
+ ["." equivalence (#+ Equivalence)]
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." function]
+ ["<>" parser
+ ["<b>" binary (#+ Parser)]]]
+ [data
+ [binary (#+ Binary)]
+ ["." product]
+ ["." name]
+ ["." text
+ ["%" format (#+ format)]]
+ [format
+ ["." binary (#+ Writer)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." dictionary (#+ Dictionary)]
+ ["." set]
+ ["." row (#+ Row)]]]
+ [math
+ [number
+ ["n" nat ("#\." equivalence)]]]
+ [type
+ abstract]]]
+ [/
+ ["." artifact]
+ ["." signature (#+ Signature)]
+ ["." key (#+ Key)]
+ ["." descriptor (#+ Module Descriptor)]
+ ["." document (#+ Document)]
+ [///
+ [version (#+ Version)]]])
+
+(type: #export Output
+ (Row [artifact.ID Binary]))
+
+(exception: #export (unknown_document {module Module}
+ {known_modules (List Module)})
+ (exception.report
+ ["Module" (%.text module)]
+ ["Known Modules" (exception.enumerate %.text known_modules)]))
+
+(exception: #export (cannot_replace_document {module Module}
+ {old (Document Any)}
+ {new (Document Any)})
+ (exception.report
+ ["Module" (%.text module)]
+ ["Old key" (signature.description (document.signature old))]
+ ["New key" (signature.description (document.signature new))]))
+
+(exception: #export (module_has_already_been_reserved {module Module})
+ (exception.report
+ ["Module" (%.text module)]))
+
+(exception: #export (module_must_be_reserved_before_it_can_be_added {module Module})
+ (exception.report
+ ["Module" (%.text module)]))
+
+(exception: #export (module_is_only_reserved {module Module})
+ (exception.report
+ ["Module" (%.text module)]))
+
+(type: #export ID
+ Nat)
+
+(def: #export runtime_module
+ Module
+ "")
+
+(abstract: #export Archive
+ {#next ID
+ #resolver (Dictionary Module [ID (Maybe [Descriptor (Document Any) Output])])}
+
+ (def: next
+ (-> Archive ID)
+ (|>> :representation (get@ #next)))
+
+ (def: #export empty
+ Archive
+ (:abstraction {#next 0
+ #resolver (dictionary.new text.hash)}))
+
+ (def: #export (id module archive)
+ (-> Module Archive (Try ID))
+ (let [(^slots [#..resolver]) (:representation archive)]
+ (case (dictionary.get module resolver)
+ (#.Some [id _])
+ (#try.Success id)
+
+ #.None
+ (exception.throw ..unknown_document [module
+ (dictionary.keys resolver)]))))
+
+ (def: #export (reserve module archive)
+ (-> Module Archive (Try [ID Archive]))
+ (let [(^slots [#..next #..resolver]) (:representation archive)]
+ (case (dictionary.get module resolver)
+ (#.Some _)
+ (exception.throw ..module_has_already_been_reserved [module])
+
+ #.None
+ (#try.Success [next
+ (|> archive
+ :representation
+ (update@ #..resolver (dictionary.put module [next #.None]))
+ (update@ #..next inc)
+ :abstraction)]))))
+
+ (def: #export (add module [descriptor document output] archive)
+ (-> Module [Descriptor (Document Any) Output] Archive (Try Archive))
+ (let [(^slots [#..resolver]) (:representation archive)]
+ (case (dictionary.get module resolver)
+ (#.Some [id #.None])
+ (#try.Success (|> archive
+ :representation
+ (update@ #..resolver (dictionary.put module [id (#.Some [descriptor document output])]))
+ :abstraction))
+
+ (#.Some [id (#.Some [existing_descriptor existing_document existing_output])])
+ (if (is? document existing_document)
+ ## TODO: Find out why this code allows for the same module to be added more than once. It looks fishy...
+ (#try.Success archive)
+ (exception.throw ..cannot_replace_document [module existing_document document]))
+
+ #.None
+ (exception.throw ..module_must_be_reserved_before_it_can_be_added [module]))))
+
+ (def: #export (find module archive)
+ (-> Module Archive (Try [Descriptor (Document Any) Output]))
+ (let [(^slots [#..resolver]) (:representation archive)]
+ (case (dictionary.get module resolver)
+ (#.Some [id (#.Some entry)])
+ (#try.Success entry)
+
+ (#.Some [id #.None])
+ (exception.throw ..module_is_only_reserved [module])
+
+ #.None
+ (exception.throw ..unknown_document [module
+ (dictionary.keys resolver)]))))
+
+ (def: #export (archived? archive module)
+ (-> Archive Module Bit)
+ (case (..find module archive)
+ (#try.Success _)
+ yes
+
+ (#try.Failure _)
+ no))
+
+ (def: #export archived
+ (-> Archive (List Module))
+ (|>> :representation
+ (get@ #resolver)
+ dictionary.entries
+ (list.all (function (_ [module [id descriptor+document]])
+ (case descriptor+document
+ (#.Some _) (#.Some module)
+ #.None #.None)))))
+
+ (def: #export (reserved? archive module)
+ (-> Archive Module Bit)
+ (let [(^slots [#..resolver]) (:representation archive)]
+ (case (dictionary.get module resolver)
+ (#.Some [id _])
+ yes
+
+ #.None
+ no)))
+
+ (def: #export reserved
+ (-> Archive (List Module))
+ (|>> :representation
+ (get@ #resolver)
+ dictionary.keys))
+
+ (def: #export reservations
+ (-> Archive (List [Module ID]))
+ (|>> :representation
+ (get@ #resolver)
+ dictionary.entries
+ (list\map (function (_ [module [id _]])
+ [module id]))))
+
+ (def: #export (merge additions archive)
+ (-> Archive Archive Archive)
+ (let [[+next +resolver] (:representation additions)]
+ (|> archive
+ :representation
+ (update@ #next (n.max +next))
+ (update@ #resolver (function (_ resolver)
+ (list\fold (function (_ [module [id entry]] resolver)
+ (case entry
+ (#.Some _)
+ (dictionary.put module [id entry] resolver)
+
+ #.None
+ resolver))
+ resolver
+ (dictionary.entries +resolver))))
+ :abstraction)))
+
+ (type: Reservation [Module ID])
+ (type: Frozen [Version ID (List Reservation)])
+
+ (def: reader
+ (Parser ..Frozen)
+ ($_ <>.and
+ <b>.nat
+ <b>.nat
+ (<b>.list (<>.and <b>.text <b>.nat))))
+
+ (def: writer
+ (Writer ..Frozen)
+ ($_ binary.and
+ binary.nat
+ binary.nat
+ (binary.list (binary.and binary.text binary.nat))))
+
+ (def: #export (export version archive)
+ (-> Version Archive Binary)
+ (let [(^slots [#..next #..resolver]) (:representation archive)]
+ (|> resolver
+ dictionary.entries
+ (list.all (function (_ [module [id descriptor+document]])
+ (case descriptor+document
+ (#.Some _) (#.Some [module id])
+ #.None #.None)))
+ [version next]
+ (binary.run ..writer))))
+
+ (exception: #export (version_mismatch {expected Version} {actual Version})
+ (exception.report
+ ["Expected" (%.nat expected)]
+ ["Actual" (%.nat actual)]))
+
+ (exception: #export corrupt_data)
+
+ (def: (correct_modules? reservations)
+ (-> (List Reservation) Bit)
+ (n.= (list.size reservations)
+ (|> reservations
+ (list\map product.left)
+ (set.from_list text.hash)
+ set.size)))
+
+ (def: (correct_ids? reservations)
+ (-> (List Reservation) Bit)
+ (n.= (list.size reservations)
+ (|> reservations
+ (list\map product.right)
+ (set.from_list n.hash)
+ set.size)))
+
+ (def: (correct_reservations? reservations)
+ (-> (List Reservation) Bit)
+ (and (correct_modules? reservations)
+ (correct_ids? reservations)))
+
+ (def: #export (import expected binary)
+ (-> Version Binary (Try Archive))
+ (do try.monad
+ [[actual next reservations] (<b>.run ..reader binary)
+ _ (exception.assert ..version_mismatch [expected actual]
+ (n\= expected actual))
+ _ (exception.assert ..corrupt_data []
+ (correct_reservations? reservations))]
+ (wrap (:abstraction
+ {#next next
+ #resolver (list\fold (function (_ [module id] archive)
+ (dictionary.put module [id #.None] archive))
+ (get@ #resolver (:representation ..empty))
+ reservations)}))))
+ )
diff --git a/stdlib/source/library/lux/tool/compiler/meta/archive/artifact.lux b/stdlib/source/library/lux/tool/compiler/meta/archive/artifact.lux
new file mode 100644
index 000000000..33e09e51a
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/meta/archive/artifact.lux
@@ -0,0 +1,155 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<b>" binary (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list]
+ ["." row (#+ Row) ("#\." functor fold)]
+ ["." dictionary (#+ Dictionary)]]
+ [format
+ ["." binary (#+ Writer)]]]
+ [type
+ abstract]]])
+
+(type: #export ID
+ Nat)
+
+(type: #export Category
+ #Anonymous
+ (#Definition Text)
+ (#Analyser Text)
+ (#Synthesizer Text)
+ (#Generator Text)
+ (#Directive Text))
+
+(type: #export Artifact
+ {#id ID
+ #category Category})
+
+(abstract: #export Registry
+ {#artifacts (Row Artifact)
+ #resolver (Dictionary Text ID)}
+
+ (def: #export empty
+ Registry
+ (:abstraction {#artifacts row.empty
+ #resolver (dictionary.new text.hash)}))
+
+ (def: #export artifacts
+ (-> Registry (Row Artifact))
+ (|>> :representation (get@ #artifacts)))
+
+ (def: next
+ (-> Registry ID)
+ (|>> ..artifacts row.size))
+
+ (def: #export (resource registry)
+ (-> Registry [ID Registry])
+ (let [id (..next registry)]
+ [id
+ (|> registry
+ :representation
+ (update@ #artifacts (row.add {#id id
+ #category #Anonymous}))
+ :abstraction)]))
+
+ (template [<tag> <create> <fetch>]
+ [(def: #export (<create> name registry)
+ (-> Text Registry [ID Registry])
+ (let [id (..next registry)]
+ [id
+ (|> registry
+ :representation
+ (update@ #artifacts (row.add {#id id
+ #category (<tag> name)}))
+ (update@ #resolver (dictionary.put name id))
+ :abstraction)]))
+
+ (def: #export (<fetch> registry)
+ (-> Registry (List Text))
+ (|> registry
+ :representation
+ (get@ #artifacts)
+ row.to_list
+ (list.all (|>> (get@ #category)
+ (case> (<tag> name) (#.Some name)
+ _ #.None)))))]
+
+ [#Definition definition definitions]
+ [#Analyser analyser analysers]
+ [#Synthesizer synthesizer synthesizers]
+ [#Generator generator generators]
+ [#Directive directive directives]
+ )
+
+ (def: #export (remember name registry)
+ (-> Text Registry (Maybe ID))
+ (|> (:representation registry)
+ (get@ #resolver)
+ (dictionary.get name)))
+
+ (def: #export writer
+ (Writer Registry)
+ (let [category (: (Writer Category)
+ (function (_ value)
+ (case value
+ (^template [<nat> <tag> <writer>]
+ [(<tag> value) ((binary.and binary.nat <writer>) [<nat> value])])
+ ([0 #Anonymous binary.any]
+ [1 #Definition binary.text]
+ [2 #Analyser binary.text]
+ [3 #Synthesizer binary.text]
+ [4 #Generator binary.text]
+ [5 #Directive binary.text]))))
+ artifacts (: (Writer (Row Category))
+ (binary.row/64 category))]
+ (|>> :representation
+ (get@ #artifacts)
+ (row\map (get@ #category))
+ artifacts)))
+
+ (exception: #export (invalid_category {tag Nat})
+ (exception.report
+ ["Tag" (%.nat tag)]))
+
+ (def: #export parser
+ (Parser Registry)
+ (let [category (: (Parser Category)
+ (do {! <>.monad}
+ [tag <b>.nat]
+ (case tag
+ 0 (\ ! map (|>> #Anonymous) <b>.any)
+ 1 (\ ! map (|>> #Definition) <b>.text)
+ 2 (\ ! map (|>> #Analyser) <b>.text)
+ 3 (\ ! map (|>> #Synthesizer) <b>.text)
+ 4 (\ ! map (|>> #Generator) <b>.text)
+ 5 (\ ! map (|>> #Directive) <b>.text)
+ _ (<>.fail (exception.construct ..invalid_category [tag])))))]
+ (|> (<b>.row/64 category)
+ (\ <>.monad map (row\fold (function (_ artifact registry)
+ (product.right
+ (case artifact
+ #Anonymous
+ (..resource registry)
+
+ (^template [<tag> <create>]
+ [(<tag> name)
+ (<create> name registry)])
+ ([#Definition ..definition]
+ [#Analyser ..analyser]
+ [#Synthesizer ..synthesizer]
+ [#Generator ..generator]
+ [#Directive ..directive])
+ )))
+ ..empty)))))
+ )
diff --git a/stdlib/source/library/lux/tool/compiler/meta/archive/descriptor.lux b/stdlib/source/library/lux/tool/compiler/meta/archive/descriptor.lux
new file mode 100644
index 000000000..2c602ac89
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/meta/archive/descriptor.lux
@@ -0,0 +1,49 @@
+(.module:
+ [library
+ [lux (#- Module)
+ [control
+ ["<>" parser
+ ["<b>" binary (#+ Parser)]]]
+ [data
+ ["." text]
+ [collection
+ [set (#+ Set)]]
+ [format
+ ["." binary (#+ Writer)]]]
+ [world
+ [file (#+ Path)]]]]
+ [//
+ ["." artifact (#+ Registry)]])
+
+(type: #export Module
+ Text)
+
+(type: #export Descriptor
+ {#name Module
+ #file Path
+ #hash Nat
+ #state Module_State
+ #references (Set Module)
+ #registry Registry})
+
+(def: #export writer
+ (Writer Descriptor)
+ ($_ binary.and
+ binary.text
+ binary.text
+ binary.nat
+ binary.any
+ (binary.set binary.text)
+ artifact.writer
+ ))
+
+(def: #export parser
+ (Parser Descriptor)
+ ($_ <>.and
+ <b>.text
+ <b>.text
+ <b>.nat
+ (\ <>.monad wrap #.Cached)
+ (<b>.set text.hash <b>.text)
+ artifact.parser
+ ))
diff --git a/stdlib/source/library/lux/tool/compiler/meta/archive/document.lux b/stdlib/source/library/lux/tool/compiler/meta/archive/document.lux
new file mode 100644
index 000000000..ea5ce1006
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/meta/archive/document.lux
@@ -0,0 +1,72 @@
+(.module:
+ [library
+ [lux (#- Module)
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ [binary (#+ Parser)]]]
+ [data
+ [collection
+ ["." dictionary (#+ Dictionary)]]
+ [format
+ ["." binary (#+ Writer)]]]
+ [type (#+ :share)
+ abstract]]]
+ [//
+ ["." signature (#+ Signature)]
+ ["." key (#+ Key)]
+ [descriptor (#+ Module)]])
+
+(exception: #export (invalid-signature {expected Signature} {actual Signature})
+ (exception.report
+ ["Expected" (signature.description expected)]
+ ["Actual" (signature.description actual)]))
+
+(abstract: #export (Document d)
+ {#signature Signature
+ #content d}
+
+ (def: #export (read key document)
+ (All [d] (-> (Key d) (Document Any) (Try d)))
+ (let [[document//signature document//content] (:representation document)]
+ (if (\ signature.equivalence =
+ (key.signature key)
+ document//signature)
+ (#try.Success (:share [e]
+ (Key e)
+ key
+
+ e
+ (:assume document//content)))
+ (exception.throw ..invalid-signature [(key.signature key)
+ document//signature]))))
+
+ (def: #export (write key content)
+ (All [d] (-> (Key d) d (Document d)))
+ (:abstraction {#signature (key.signature key)
+ #content content}))
+
+ (def: #export (check key document)
+ (All [d] (-> (Key d) (Document Any) (Try (Document d))))
+ (do try.monad
+ [_ (..read key document)]
+ (wrap (:assume document))))
+
+ (def: #export signature
+ (-> (Document Any) Signature)
+ (|>> :representation (get@ #signature)))
+
+ (def: #export (writer content)
+ (All [d] (-> (Writer d) (Writer (Document d))))
+ (let [writer (binary.and signature.writer
+ content)]
+ (|>> :representation writer)))
+
+ (def: #export parser
+ (All [d] (-> (Parser d) (Parser (Document d))))
+ (|>> (<>.and signature.parser)
+ (\ <>.monad map (|>> :abstraction))))
+ )
diff --git a/stdlib/source/library/lux/tool/compiler/meta/archive/key.lux b/stdlib/source/library/lux/tool/compiler/meta/archive/key.lux
new file mode 100644
index 000000000..ec6439aa7
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/meta/archive/key.lux
@@ -0,0 +1,19 @@
+(.module:
+ [library
+ [lux #*
+ [type
+ abstract]]]
+ [//
+ [signature (#+ Signature)]])
+
+(abstract: #export (Key k)
+ Signature
+
+ (def: #export signature
+ (-> (Key Any) Signature)
+ (|>> :representation))
+
+ (def: #export (key signature sample)
+ (All [d] (-> Signature d (Key d)))
+ (:abstraction signature))
+ )
diff --git a/stdlib/source/library/lux/tool/compiler/meta/archive/signature.lux b/stdlib/source/library/lux/tool/compiler/meta/archive/signature.lux
new file mode 100644
index 000000000..e39bb2144
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/meta/archive/signature.lux
@@ -0,0 +1,42 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [control
+ ["<>" parser
+ ["<b>" binary (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." name]
+ ["." text
+ ["%" format (#+ format)]]
+ [format
+ ["." binary (#+ Writer)]]]
+ [math
+ [number
+ ["." nat]]]]]
+ [////
+ [version (#+ Version)]])
+
+(type: #export Signature
+ {#name Name
+ #version Version})
+
+(def: #export equivalence
+ (Equivalence Signature)
+ (product.equivalence name.equivalence nat.equivalence))
+
+(def: #export (description signature)
+ (-> Signature Text)
+ (format (%.name (get@ #name signature)) " " (%.nat (get@ #version signature))))
+
+(def: #export writer
+ (Writer Signature)
+ (binary.and (binary.and binary.text binary.text)
+ binary.nat))
+
+(def: #export parser
+ (Parser Signature)
+ (<>.and (<>.and <b>.text <b>.text)
+ <b>.nat))
diff --git a/stdlib/source/library/lux/tool/compiler/meta/cache/dependency.lux b/stdlib/source/library/lux/tool/compiler/meta/cache/dependency.lux
new file mode 100644
index 000000000..3ba514b5f
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/meta/cache/dependency.lux
@@ -0,0 +1,97 @@
+(.module:
+ [library
+ [lux (#- Module)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." state]
+ ["." function
+ ["." memo (#+ Memo)]]]
+ [data
+ ["." maybe ("#\." functor)]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." dictionary (#+ Dictionary)]
+ ["." set (#+ Set)]]]]]
+ [///
+ ["." archive (#+ Output Archive)
+ [key (#+ Key)]
+ ["." descriptor (#+ Module Descriptor)]
+ ["." document (#+ Document)]]])
+
+(type: Ancestry
+ (Set Module))
+
+(def: fresh
+ Ancestry
+ (set.new text.hash))
+
+(type: #export Graph
+ (Dictionary Module Ancestry))
+
+(def: empty
+ Graph
+ (dictionary.new text.hash))
+
+(def: #export modules
+ (-> Graph (List Module))
+ dictionary.keys)
+
+(type: Dependency
+ {#module Module
+ #imports Ancestry})
+
+(def: #export graph
+ (-> (List Dependency) Graph)
+ (list\fold (function (_ [module imports] graph)
+ (dictionary.put module imports graph))
+ ..empty))
+
+(def: (ancestry archive)
+ (-> Archive Graph)
+ (let [memo (: (Memo Module Ancestry)
+ (function (_ recur module)
+ (do {! state.monad}
+ [#let [parents (case (archive.find module archive)
+ (#try.Success [descriptor document])
+ (get@ #descriptor.references descriptor)
+
+ (#try.Failure error)
+ ..fresh)]
+ ancestors (monad.map ! recur (set.to_list parents))]
+ (wrap (list\fold set.union parents ancestors)))))
+ ancestry (memo.open memo)]
+ (list\fold (function (_ module memory)
+ (if (dictionary.key? memory module)
+ memory
+ (let [[memory _] (ancestry [memory module])]
+ memory)))
+ ..empty
+ (archive.archived archive))))
+
+(def: (dependency? ancestry target source)
+ (-> Graph Module Module Bit)
+ (let [target_ancestry (|> ancestry
+ (dictionary.get target)
+ (maybe.default ..fresh))]
+ (set.member? target_ancestry source)))
+
+(type: #export Order
+ (List [Module [archive.ID [Descriptor (Document .Module) Output]]]))
+
+(def: #export (load_order key archive)
+ (-> (Key .Module) Archive (Try Order))
+ (let [ancestry (..ancestry archive)]
+ (|> ancestry
+ dictionary.keys
+ (list.sort (..dependency? ancestry))
+ (monad.map try.monad
+ (function (_ module)
+ (do try.monad
+ [module_id (archive.id module archive)
+ [descriptor document output] (archive.find module archive)
+ document (document.check key document)]
+ (wrap [module [module_id [descriptor document output]]])))))))
diff --git a/stdlib/source/library/lux/tool/compiler/meta/io.lux b/stdlib/source/library/lux/tool/compiler/meta/io.lux
new file mode 100644
index 000000000..fe11727b7
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/meta/io.lux
@@ -0,0 +1,20 @@
+(.module:
+ [library
+ [lux (#- Code)
+ [data
+ ["." text]]
+ [world
+ [file (#+ Path System)]]]])
+
+(type: #export Context
+ Path)
+
+(type: #export Code
+ Text)
+
+(def: #export (sanitize system)
+ (All [m] (-> (System m) Text Text))
+ (text.replace_all "/" (\ system separator)))
+
+(def: #export lux_context
+ "lux")
diff --git a/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux
new file mode 100644
index 000000000..b5ed4b84b
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux
@@ -0,0 +1,450 @@
+(.module:
+ [library
+ [lux (#- Module)
+ [target (#+ Target)]
+ [abstract
+ [predicate (#+ Predicate)]
+ ["." monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ [concurrency
+ ["." promise (#+ Promise) ("#\." monad)]]
+ ["<>" parser
+ ["<.>" binary (#+ Parser)]]]
+ [data
+ [binary (#+ Binary)]
+ ["." product]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." dictionary (#+ Dictionary)]
+ ["." row (#+ Row)]
+ ["." set]]]
+ [math
+ [number
+ ["n" nat]]]
+ [world
+ ["." file]]]]
+ [program
+ [compositor
+ [import (#+ Import)]
+ ["." static (#+ Static)]]]
+ ["." // (#+ Context)
+ ["#." context]
+ ["/#" //
+ ["." archive (#+ Output Archive)
+ ["." artifact (#+ Artifact)]
+ ["." descriptor (#+ Module Descriptor)]
+ ["." document (#+ Document)]]
+ [cache
+ ["." dependency]]
+ ["/#" // (#+ Input)
+ [language
+ ["$" lux
+ ["." version]
+ ["." analysis]
+ ["." synthesis]
+ ["." generation]
+ ["." directive]
+ ["#/." program]]]]]])
+
+(exception: #export (cannot_prepare {archive file.Path}
+ {module_id archive.ID}
+ {error Text})
+ (exception.report
+ ["Archive" archive]
+ ["Module ID" (%.nat module_id)]
+ ["Error" error]))
+
+(def: (archive fs static)
+ (All [!] (-> (file.System !) Static file.Path))
+ (format (get@ #static.target static)
+ (\ fs separator)
+ (get@ #static.host static)))
+
+(def: (unversioned_lux_archive fs static)
+ (All [!] (-> (file.System !) Static file.Path))
+ (format (..archive fs static)
+ (\ fs separator)
+ //.lux_context))
+
+(def: (versioned_lux_archive fs static)
+ (All [!] (-> (file.System !) Static file.Path))
+ (format (..unversioned_lux_archive fs static)
+ (\ fs separator)
+ (%.nat version.version)))
+
+(def: (module fs static module_id)
+ (All [!] (-> (file.System !) Static archive.ID file.Path))
+ (format (..versioned_lux_archive fs static)
+ (\ fs separator)
+ (%.nat module_id)))
+
+(def: #export (artifact fs static module_id artifact_id)
+ (All [!] (-> (file.System !) Static archive.ID artifact.ID file.Path))
+ (format (..module fs static module_id)
+ (\ fs separator)
+ (%.nat artifact_id)
+ (get@ #static.artifact_extension static)))
+
+(def: (ensure_directory fs path)
+ (-> (file.System Promise) file.Path (Promise (Try Any)))
+ (do promise.monad
+ [? (\ fs directory? path)]
+ (if ?
+ (wrap (#try.Success []))
+ (\ fs make_directory path))))
+
+(def: #export (prepare fs static module_id)
+ (-> (file.System Promise) Static archive.ID (Promise (Try Any)))
+ (do {! promise.monad}
+ [#let [module (..module fs static module_id)]
+ module_exists? (\ fs directory? module)]
+ (if module_exists?
+ (wrap (#try.Success []))
+ (do (try.with !)
+ [_ (ensure_directory fs (..unversioned_lux_archive fs static))
+ _ (ensure_directory fs (..versioned_lux_archive fs static))]
+ (|> module
+ (\ fs make_directory)
+ (\ ! map (|>> (case> (#try.Success output)
+ (#try.Success [])
+
+ (#try.Failure error)
+ (exception.throw ..cannot_prepare [(..archive fs static)
+ module_id
+ error])))))))))
+
+(def: #export (write fs static module_id artifact_id content)
+ (-> (file.System Promise) Static archive.ID artifact.ID Binary (Promise (Try Any)))
+ (\ fs write content (..artifact fs static module_id artifact_id)))
+
+(def: #export (enable fs static)
+ (-> (file.System Promise) Static (Promise (Try Any)))
+ (do (try.with promise.monad)
+ [_ (..ensure_directory fs (get@ #static.target static))]
+ (..ensure_directory fs (..archive fs static))))
+
+(def: (general_descriptor fs static)
+ (-> (file.System Promise) Static file.Path)
+ (format (..archive fs static)
+ (\ fs separator)
+ "general_descriptor"))
+
+(def: #export (freeze fs static archive)
+ (-> (file.System Promise) Static Archive (Promise (Try Any)))
+ (\ fs write (archive.export ///.version archive) (..general_descriptor fs static)))
+
+(def: module_descriptor_file
+ "module_descriptor")
+
+(def: (module_descriptor fs static module_id)
+ (-> (file.System Promise) Static archive.ID file.Path)
+ (format (..module fs static module_id)
+ (\ fs separator)
+ ..module_descriptor_file))
+
+(def: #export (cache fs static module_id content)
+ (-> (file.System Promise) Static archive.ID Binary (Promise (Try Any)))
+ (\ fs write content (..module_descriptor fs static module_id)))
+
+(def: (read_module_descriptor fs static module_id)
+ (-> (file.System Promise) Static archive.ID (Promise (Try Binary)))
+ (\ fs read (..module_descriptor fs static module_id)))
+
+(def: parser
+ (Parser [Descriptor (Document .Module)])
+ (<>.and descriptor.parser
+ (document.parser $.parser)))
+
+(def: (fresh_analysis_state host)
+ (-> Target .Lux)
+ (analysis.state (analysis.info version.version host)))
+
+(def: (analysis_state host archive)
+ (-> Target Archive (Try .Lux))
+ (do {! try.monad}
+ [modules (: (Try (List [Module .Module]))
+ (monad.map ! (function (_ module)
+ (do !
+ [[descriptor document output] (archive.find module archive)
+ content (document.read $.key document)]
+ (wrap [module content])))
+ (archive.archived archive)))]
+ (wrap (set@ #.modules modules (fresh_analysis_state host)))))
+
+(def: (cached_artifacts fs static module_id)
+ (-> (file.System Promise) Static archive.ID (Promise (Try (Dictionary Text Binary))))
+ (let [! (try.with promise.monad)]
+ (|> (..module fs static module_id)
+ (\ fs directory_files)
+ (\ ! map (|>> (list\map (function (_ file)
+ [(file.name fs file) file]))
+ (list.filter (|>> product.left (text\= ..module_descriptor_file) not))
+ (monad.map ! (function (_ [name path])
+ (|> path
+ (\ fs read)
+ (\ ! map (|>> [name])))))
+ (\ ! map (dictionary.from_list text.hash))))
+ (\ ! join))))
+
+(type: Definitions (Dictionary Text Any))
+(type: Analysers (Dictionary Text analysis.Handler))
+(type: Synthesizers (Dictionary Text synthesis.Handler))
+(type: Generators (Dictionary Text generation.Handler))
+(type: Directives (Dictionary Text directive.Handler))
+
+(type: Bundles
+ [Analysers
+ Synthesizers
+ Generators
+ Directives])
+
+(def: empty_bundles
+ Bundles
+ [(dictionary.new text.hash)
+ (dictionary.new text.hash)
+ (dictionary.new text.hash)
+ (dictionary.new text.hash)])
+
+(def: (loaded_document extension host module_id expected actual document)
+ (All [expression directive]
+ (-> Text (generation.Host expression directive) archive.ID (Row Artifact) (Dictionary Text Binary) (Document .Module)
+ (Try [(Document .Module) Bundles])))
+ (do {! try.monad}
+ [[definitions bundles] (: (Try [Definitions Bundles])
+ (loop [input (row.to_list expected)
+ definitions (: Definitions
+ (dictionary.new text.hash))
+ bundles ..empty_bundles]
+ (let [[analysers synthesizers generators directives] bundles]
+ (case input
+ (#.Cons [[artifact_id artifact_category] input'])
+ (case (do !
+ [data (try.from_maybe (dictionary.get (format (%.nat artifact_id) extension) actual))
+ #let [context [module_id artifact_id]
+ directive (\ host ingest context data)]]
+ (case artifact_category
+ #artifact.Anonymous
+ (do !
+ [_ (\ host re_learn context directive)]
+ (wrap [definitions
+ [analysers
+ synthesizers
+ generators
+ directives]]))
+
+ (#artifact.Definition name)
+ (if (text\= $/program.name name)
+ (wrap [definitions
+ [analysers
+ synthesizers
+ generators
+ directives]])
+ (do !
+ [value (\ host re_load context directive)]
+ (wrap [(dictionary.put name value definitions)
+ [analysers
+ synthesizers
+ generators
+ directives]])))
+
+ (#artifact.Analyser extension)
+ (do !
+ [value (\ host re_load context directive)]
+ (wrap [definitions
+ [(dictionary.put extension (:as analysis.Handler value) analysers)
+ synthesizers
+ generators
+ directives]]))
+
+ (#artifact.Synthesizer extension)
+ (do !
+ [value (\ host re_load context directive)]
+ (wrap [definitions
+ [analysers
+ (dictionary.put extension (:as synthesis.Handler value) synthesizers)
+ generators
+ directives]]))
+
+ (#artifact.Generator extension)
+ (do !
+ [value (\ host re_load context directive)]
+ (wrap [definitions
+ [analysers
+ synthesizers
+ (dictionary.put extension (:as generation.Handler value) generators)
+ directives]]))
+
+ (#artifact.Directive extension)
+ (do !
+ [value (\ host re_load context directive)]
+ (wrap [definitions
+ [analysers
+ synthesizers
+ generators
+ (dictionary.put extension (:as directive.Handler value) directives)]]))))
+ (#try.Success [definitions' bundles'])
+ (recur input' definitions' bundles')
+
+ failure
+ failure)
+
+ #.None
+ (#try.Success [definitions bundles])))))
+ content (document.read $.key document)
+ definitions (monad.map ! (function (_ [def_name def_global])
+ (case def_global
+ (#.Alias alias)
+ (wrap [def_name (#.Alias alias)])
+
+ (#.Definition [exported? type annotations _])
+ (do !
+ [value (try.from_maybe (dictionary.get def_name definitions))]
+ (wrap [def_name (#.Definition [exported? type annotations value])]))))
+ (get@ #.definitions content))]
+ (wrap [(document.write $.key (set@ #.definitions definitions content))
+ bundles])))
+
+(def: (load_definitions fs static module_id host_environment [descriptor document output])
+ (All [expression directive]
+ (-> (file.System Promise) Static archive.ID (generation.Host expression directive)
+ [Descriptor (Document .Module) Output]
+ (Promise (Try [[Descriptor (Document .Module) Output]
+ Bundles]))))
+ (do (try.with promise.monad)
+ [actual (cached_artifacts fs static module_id)
+ #let [expected (|> descriptor (get@ #descriptor.registry) artifact.artifacts)]
+ [document bundles] (promise\wrap (loaded_document (get@ #static.artifact_extension static) host_environment module_id expected actual document))]
+ (wrap [[descriptor document output] bundles])))
+
+(def: (purge! fs static [module_name module_id])
+ (-> (file.System Promise) Static [Module archive.ID] (Promise (Try Any)))
+ (do {! (try.with promise.monad)}
+ [#let [cache (..module fs static module_id)]
+ _ (|> cache
+ (\ fs directory_files)
+ (\ ! map (monad.map ! (\ fs delete)))
+ (\ ! join))]
+ (\ fs delete cache)))
+
+(def: (valid_cache? expected actual)
+ (-> Descriptor Input Bit)
+ (and (text\= (get@ #descriptor.name expected)
+ (get@ #////.module actual))
+ (text\= (get@ #descriptor.file expected)
+ (get@ #////.file actual))
+ (n.= (get@ #descriptor.hash expected)
+ (get@ #////.hash actual))))
+
+(type: Purge
+ (Dictionary Module archive.ID))
+
+(def: initial_purge
+ (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module) Output]]]])
+ Purge)
+ (|>> (list.all (function (_ [valid_cache? [module_name [module_id _]]])
+ (if valid_cache?
+ #.None
+ (#.Some [module_name module_id]))))
+ (dictionary.from_list text.hash)))
+
+(def: (full_purge caches load_order)
+ (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module) Output]]]])
+ dependency.Order
+ Purge)
+ (list\fold (function (_ [module_name [module_id [descriptor document output]]] purge)
+ (let [purged? (: (Predicate Module)
+ (dictionary.key? purge))]
+ (if (purged? module_name)
+ purge
+ (if (|> descriptor
+ (get@ #descriptor.references)
+ set.to_list
+ (list.any? purged?))
+ (dictionary.put module_name module_id purge)
+ purge))))
+ (..initial_purge caches)
+ load_order))
+
+(def: pseudo_module
+ Text
+ "(Lux Caching System)")
+
+(def: (load_every_reserved_module host_environment fs static import contexts archive)
+ (All [expression directive]
+ (-> (generation.Host expression directive) (file.System Promise) Static Import (List Context) Archive
+ (Promise (Try [Archive .Lux Bundles]))))
+ (do {! (try.with promise.monad)}
+ [pre_loaded_caches (|> archive
+ archive.reservations
+ (monad.map ! (function (_ [module_name module_id])
+ (do !
+ [data (..read_module_descriptor fs static module_id)
+ [descriptor document] (promise\wrap (<binary>.run ..parser data))]
+ (if (text\= archive.runtime_module module_name)
+ (wrap [true
+ [module_name [module_id [descriptor document (: Output row.empty)]]]])
+ (do !
+ [input (//context.read fs ..pseudo_module import contexts (get@ #static.host_module_extension static) module_name)]
+ (wrap [(..valid_cache? descriptor input)
+ [module_name [module_id [descriptor document (: Output row.empty)]]]])))))))
+ load_order (|> pre_loaded_caches
+ (list\map product.right)
+ (monad.fold try.monad
+ (function (_ [module [module_id descriptor,document,output]] archive)
+ (archive.add module descriptor,document,output archive))
+ archive)
+ (\ try.monad map (dependency.load_order $.key))
+ (\ try.monad join)
+ promise\wrap)
+ #let [purge (..full_purge pre_loaded_caches load_order)]
+ _ (|> purge
+ dictionary.entries
+ (monad.map ! (..purge! fs static)))
+ loaded_caches (|> load_order
+ (list.filter (function (_ [module_name [module_id [descriptor document output]]])
+ (not (dictionary.key? purge module_name))))
+ (monad.map ! (function (_ [module_name [module_id descriptor,document,output]])
+ (do !
+ [[descriptor,document,output bundles] (..load_definitions fs static module_id host_environment descriptor,document,output)]
+ (wrap [[module_name descriptor,document,output]
+ bundles])))))]
+ (promise\wrap
+ (do {! try.monad}
+ [archive (monad.fold !
+ (function (_ [[module descriptor,document] _bundle] archive)
+ (archive.add module descriptor,document archive))
+ archive
+ loaded_caches)
+ analysis_state (..analysis_state (get@ #static.host static) archive)]
+ (wrap [archive
+ analysis_state
+ (list\fold (function (_ [_ [+analysers +synthesizers +generators +directives]]
+ [analysers synthesizers generators directives])
+ [(dictionary.merge +analysers analysers)
+ (dictionary.merge +synthesizers synthesizers)
+ (dictionary.merge +generators generators)
+ (dictionary.merge +directives directives)])
+ ..empty_bundles
+ loaded_caches)])))))
+
+(def: #export (thaw host_environment fs static import contexts)
+ (All [expression directive]
+ (-> (generation.Host expression directive) (file.System Promise) Static Import (List Context)
+ (Promise (Try [Archive .Lux Bundles]))))
+ (do promise.monad
+ [binary (\ fs read (..general_descriptor fs static))]
+ (case binary
+ (#try.Success binary)
+ (do (try.with promise.monad)
+ [archive (promise\wrap (archive.import ///.version binary))]
+ (..load_every_reserved_module host_environment fs static import contexts archive))
+
+ (#try.Failure error)
+ (wrap (#try.Success [archive.empty
+ (fresh_analysis_state (get@ #static.host static))
+ ..empty_bundles])))))
diff --git a/stdlib/source/library/lux/tool/compiler/meta/io/context.lux b/stdlib/source/library/lux/tool/compiler/meta/io/context.lux
new file mode 100644
index 000000000..6e619d93d
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/meta/io/context.lux
@@ -0,0 +1,170 @@
+(.module:
+ [library
+ [lux (#- Module Code)
+ ["@" target]
+ [abstract
+ [predicate (#+ Predicate)]
+ ["." monad (#+ Monad do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ [concurrency
+ ["." promise (#+ Promise) ("#\." monad)]]]
+ [data
+ [binary (#+ Binary)]
+ ["." text ("#\." hash)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." dictionary (#+ Dictionary)]]]
+ [world
+ ["." file]]]]
+ [program
+ [compositor
+ [import (#+ Import)]]]
+ ["." // (#+ Context Code)
+ ["/#" // #_
+ [archive
+ [descriptor (#+ Module)]]
+ ["/#" // (#+ Input)]]])
+
+(exception: #export (cannot_find_module {importer Module} {module Module})
+ (exception.report
+ ["Module" (%.text module)]
+ ["Importer" (%.text importer)]))
+
+(exception: #export (cannot_read_module {module Module})
+ (exception.report
+ ["Module" (%.text module)]))
+
+(type: #export Extension
+ Text)
+
+(def: lux_extension
+ Extension
+ ".lux")
+
+(def: #export (path fs context module)
+ (All [m] (-> (file.System m) Context Module file.Path))
+ (|> module
+ (//.sanitize fs)
+ (format context (\ fs separator))))
+
+(def: (find_source_file fs importer contexts module extension)
+ (-> (file.System Promise) Module (List Context) Module Extension
+ (Promise (Try file.Path)))
+ (case contexts
+ #.Nil
+ (promise\wrap (exception.throw ..cannot_find_module [importer module]))
+
+ (#.Cons context contexts')
+ (let [path (format (..path fs context module) extension)]
+ (do promise.monad
+ [? (\ fs file? path)]
+ (if ?
+ (wrap (#try.Success path))
+ (find_source_file fs importer contexts' module extension))))))
+
+(def: (full_host_extension partial_host_extension)
+ (-> Extension Extension)
+ (format partial_host_extension ..lux_extension))
+
+(def: (find_local_source_file fs importer import contexts partial_host_extension module)
+ (-> (file.System Promise) Module Import (List Context) Extension Module
+ (Promise (Try [file.Path Binary])))
+ ## Preference is explicitly being given to Lux files that have a host extension.
+ ## Normal Lux files (i.e. without a host extension) are then picked as fallback files.
+ (do {! promise.monad}
+ [outcome (..find_source_file fs importer contexts module (..full_host_extension partial_host_extension))]
+ (case outcome
+ (#try.Success path)
+ (|> path
+ (\ fs read)
+ (\ (try.with !) map (|>> [path])))
+
+ (#try.Failure _)
+ (do {! (try.with !)}
+ [path (..find_source_file fs importer contexts module ..lux_extension)]
+ (|> path
+ (\ fs read)
+ (\ ! map (|>> [path])))))))
+
+(def: (find_library_source_file importer import partial_host_extension module)
+ (-> Module Import Extension Module (Try [file.Path Binary]))
+ (let [path (format module (..full_host_extension partial_host_extension))]
+ (case (dictionary.get path import)
+ (#.Some data)
+ (#try.Success [path data])
+
+ #.None
+ (let [path (format module ..lux_extension)]
+ (case (dictionary.get path import)
+ (#.Some data)
+ (#try.Success [path data])
+
+ #.None
+ (exception.throw ..cannot_find_module [importer module]))))))
+
+(def: (find_any_source_file fs importer import contexts partial_host_extension module)
+ (-> (file.System Promise) Module Import (List Context) Extension Module
+ (Promise (Try [file.Path Binary])))
+ ## Preference is explicitly being given to Lux files that have a host extension.
+ ## Normal Lux files (i.e. without a host extension) are then picked as fallback files.
+ (do {! promise.monad}
+ [outcome (find_local_source_file fs importer import contexts partial_host_extension module)]
+ (case outcome
+ (#try.Success [path data])
+ (wrap outcome)
+
+ (#try.Failure _)
+ (wrap (..find_library_source_file importer import partial_host_extension module)))))
+
+(def: #export (read fs importer import contexts partial_host_extension module)
+ (-> (file.System Promise) Module Import (List Context) Extension Module
+ (Promise (Try Input)))
+ (do (try.with promise.monad)
+ [[path binary] (..find_any_source_file fs importer import contexts partial_host_extension module)]
+ (case (\ utf8.codec decode binary)
+ (#try.Success code)
+ (wrap {#////.module module
+ #////.file path
+ #////.hash (text\hash code)
+ #////.code code})
+
+ (#try.Failure _)
+ (promise\wrap (exception.throw ..cannot_read_module [module])))))
+
+(type: #export Enumeration
+ (Dictionary file.Path Binary))
+
+(def: (enumerate_context fs directory enumeration)
+ (-> (file.System Promise) Context Enumeration (Promise (Try Enumeration)))
+ (do {! (try.with promise.monad)}
+ [enumeration (|> directory
+ (\ fs directory_files)
+ (\ ! map (monad.fold ! (function (_ file enumeration)
+ (if (text.ends_with? ..lux_extension file)
+ (do !
+ [source_code (\ fs read file)]
+ (promise\wrap
+ (dictionary.try_put (file.name fs file) source_code enumeration)))
+ (wrap enumeration)))
+ enumeration))
+ (\ ! join))]
+ (|> directory
+ (\ fs sub_directories)
+ (\ ! map (monad.fold ! (enumerate_context fs) enumeration))
+ (\ ! join))))
+
+(def: Action
+ (type (All [a] (Promise (Try a)))))
+
+(def: #export (enumerate fs contexts)
+ (-> (file.System Promise) (List Context) (Action Enumeration))
+ (monad.fold (: (Monad Action)
+ (try.with promise.monad))
+ (..enumerate_context fs)
+ (: Enumeration
+ (dictionary.new text.hash))
+ contexts))
diff --git a/stdlib/source/library/lux/tool/compiler/meta/packager.lux b/stdlib/source/library/lux/tool/compiler/meta/packager.lux
new file mode 100644
index 000000000..621045e33
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/meta/packager.lux
@@ -0,0 +1,43 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ Monad)]]
+ [control
+ [try (#+ Try)]]
+ [data
+ [binary (#+ Binary)]
+ [collection
+ ["." row]
+ ["." list ("#\." functor)]]]
+ [world
+ ["." file (#+ Path)]]]]
+ [program
+ [compositor
+ [static (#+ Static)]]]
+ [//
+ [cache
+ ["." dependency]]
+ ["." archive (#+ Archive)
+ ["." descriptor]
+ ["." artifact]]
+ [//
+ [language
+ [lux
+ [generation (#+ Context)]]]]])
+
+(type: #export Packager
+ (-> Archive Context (Try Binary)))
+
+(type: #export Order
+ (List [archive.ID (List artifact.ID)]))
+
+(def: #export order
+ (-> dependency.Order Order)
+ (list\map (function (_ [module [module_id [descriptor document]]])
+ (|> descriptor
+ (get@ #descriptor.registry)
+ artifact.artifacts
+ row.to_list
+ (list\map (|>> (get@ #artifact.id)))
+ [module_id]))))
diff --git a/stdlib/source/library/lux/tool/compiler/meta/packager/jvm.lux b/stdlib/source/library/lux/tool/compiler/meta/packager/jvm.lux
new file mode 100644
index 000000000..f5366ab8e
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/meta/packager/jvm.lux
@@ -0,0 +1,145 @@
+(.module:
+ [library
+ [lux (#- Module Definition)
+ [type (#+ :share)]
+ ["." ffi (#+ import: do_to)]
+ [abstract
+ ["." monad (#+ Monad do)]]
+ [control
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." binary (#+ Binary)]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." row (#+ Row) ("#\." fold)]
+ ["." list ("#\." functor fold)]]]
+ [math
+ [number
+ ["n" nat]]]
+ [target
+ [jvm
+ [encoding
+ ["." name]]]]]]
+ [program
+ [compositor
+ ["." static (#+ Static)]]]
+ ["." // (#+ Packager)
+ [//
+ ["." archive (#+ Output)
+ ["." descriptor (#+ Module)]
+ ["." artifact]]
+ [cache
+ ["." dependency]]
+ ["." io #_
+ ["#" archive]]
+ [//
+ [language
+ ["$" lux
+ [generation (#+ Context)]
+ [phase
+ [generation
+ [jvm
+ ["." runtime (#+ Definition)]]]]]]]]])
+
+(import: java/lang/Object)
+
+(import: java/lang/String)
+
+(import: java/util/jar/Attributes
+ ["#::."
+ (put [java/lang/Object java/lang/Object] #? java/lang/Object)])
+
+(import: java/util/jar/Attributes$Name
+ ["#::."
+ (#static MAIN_CLASS java/util/jar/Attributes$Name)
+ (#static MANIFEST_VERSION java/util/jar/Attributes$Name)])
+
+(import: java/util/jar/Manifest
+ ["#::."
+ (new [])
+ (getMainAttributes [] java/util/jar/Attributes)])
+
+(import: java/io/Flushable
+ ["#::."
+ (flush [] void)])
+
+(import: java/io/Closeable
+ ["#::."
+ (close [] void)])
+
+(import: java/io/OutputStream)
+
+(import: java/io/ByteArrayOutputStream
+ ["#::."
+ (new [int])
+ (toByteArray [] [byte])])
+
+(import: java/util/zip/ZipEntry)
+
+(import: java/util/zip/ZipOutputStream
+ ["#::."
+ (write [[byte] int int] void)
+ (closeEntry [] void)])
+
+(import: java/util/jar/JarEntry
+ ["#::."
+ (new [java/lang/String])])
+
+(import: java/util/jar/JarOutputStream
+ ["#::."
+ (new [java/io/OutputStream java/util/jar/Manifest])
+ (putNextEntry [java/util/zip/ZipEntry] void)])
+
+(def: byte 1)
+## https://en.wikipedia.org/wiki/Kibibyte
+(def: kibi_byte (n.* 1,024 byte))
+## https://en.wikipedia.org/wiki/Mebibyte
+(def: mebi_byte (n.* 1,024 kibi_byte))
+
+(def: manifest_version "1.0")
+
+(def: (manifest program)
+ (-> Context java/util/jar/Manifest)
+ (let [manifest (java/util/jar/Manifest::new)]
+ (exec (do_to (java/util/jar/Manifest::getMainAttributes manifest)
+ (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MAIN_CLASS) (|> program runtime.class_name name.internal name.external))
+ (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MANIFEST_VERSION) ..manifest_version))
+ manifest)))
+
+(def: (write_class static module artifact content sink)
+ (-> Static archive.ID artifact.ID Binary java/util/jar/JarOutputStream
+ java/util/jar/JarOutputStream)
+ (let [class_path (format (runtime.class_name [module artifact])
+ (get@ #static.artifact_extension static))]
+ (do_to sink
+ (java/util/jar/JarOutputStream::putNextEntry (java/util/jar/JarEntry::new class_path))
+ (java/util/zip/ZipOutputStream::write content +0 (.int (binary.size content)))
+ (java/io/Flushable::flush)
+ (java/util/zip/ZipOutputStream::closeEntry))))
+
+(def: (write_module static [module output] sink)
+ (-> Static [archive.ID Output] java/util/jar/JarOutputStream
+ java/util/jar/JarOutputStream)
+ (row\fold (function (_ [artifact content] sink)
+ (..write_class static module artifact content sink))
+ sink
+ output))
+
+(def: #export (package static)
+ (-> Static Packager)
+ (function (_ archive program)
+ (do {! try.monad}
+ [order (dependency.load_order $.key archive)
+ #let [buffer (java/io/ByteArrayOutputStream::new (.int ..mebi_byte))
+ sink (|> order
+ (list\map (function (_ [module [module_id [descriptor document output]]])
+ [module_id output]))
+ (list\fold (..write_module static)
+ (java/util/jar/JarOutputStream::new buffer (..manifest program))))
+ _ (do_to sink
+ (java/io/Flushable::flush)
+ (java/io/Closeable::close))]]
+ (wrap (java/io/ByteArrayOutputStream::toByteArray buffer)))))
diff --git a/stdlib/source/library/lux/tool/compiler/meta/packager/scheme.lux b/stdlib/source/library/lux/tool/compiler/meta/packager/scheme.lux
new file mode 100644
index 000000000..bcd06b6fd
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/meta/packager/scheme.lux
@@ -0,0 +1,132 @@
+(.module:
+ [library
+ [lux (#- Module)
+ [type (#+ :share)]
+ [abstract
+ ["." monad (#+ Monad do)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ [binary (#+ Binary)]
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]
+ ["." encoding]]
+ [collection
+ ["." row]
+ ["." list ("#\." functor fold)]
+ ["." dictionary (#+ Dictionary)]
+ ["." set]]
+ [format
+ ["." tar]
+ ["." binary]]]
+ [target
+ ["_" scheme]]
+ [time
+ ["." instant (#+ Instant)]]
+ [world
+ ["." file]]]]
+ [program
+ [compositor
+ ["." static (#+ Static)]]]
+ ["." // (#+ Packager)
+ [//
+ ["." archive (#+ Output)
+ ["." descriptor (#+ Module Descriptor)]
+ ["." artifact]
+ ["." document (#+ Document)]]
+ [cache
+ ["." dependency]]
+ ["." io #_
+ ["#" archive]]
+ [//
+ [language
+ ["$" lux
+ [generation (#+ Context)]]]]]])
+
+## TODO: Delete ASAP
+(type: (Action ! a)
+ (! (Try a)))
+
+(def: (then pre post)
+ (-> _.Expression _.Expression _.Expression)
+ (_.manual (format (_.code pre)
+ text.new_line
+ (_.code post))))
+
+(def: bundle_module
+ (-> Output (Try _.Expression))
+ (|>> row.to_list
+ (list\map product.right)
+ (monad.fold try.monad
+ (function (_ content so_far)
+ (|> content
+ (\ encoding.utf8 decode)
+ (\ try.monad map
+ (|>> :assume
+ (:share [directive]
+ directive
+ so_far
+
+ directive)
+ (..then so_far)))))
+ (: _.Expression (_.manual "")))))
+
+(def: module_file
+ (-> archive.ID file.Path)
+ (|>> %.nat (text.suffix ".scm")))
+
+(def: mode
+ tar.Mode
+ ($_ tar.and
+ tar.read_by_group
+ tar.read_by_owner
+
+ tar.write_by_other
+ tar.write_by_group
+ tar.write_by_owner))
+
+(def: owner
+ tar.Owner
+ {#tar.name tar.anonymous
+ #tar.id tar.no_id})
+
+(def: ownership
+ {#tar.user ..owner
+ #tar.group ..owner})
+
+(def: (write_module now mapping [module [module_id [descriptor document output]]])
+ (-> Instant (Dictionary Module archive.ID)
+ [Module [archive.ID [Descriptor (Document .Module) Output]]]
+ (Try tar.Entry))
+ (do {! try.monad}
+ [bundle (: (Try _.Expression)
+ (..bundle_module output))
+ entry_content (: (Try tar.Content)
+ (|> descriptor
+ (get@ #descriptor.references)
+ set.to_list
+ (list.all (function (_ module) (dictionary.get module mapping)))
+ (list\map (|>> ..module_file _.string _.load-relative/1))
+ (list\fold ..then bundle)
+ (: _.Expression)
+ _.code
+ (\ encoding.utf8 encode)
+ tar.content))
+ module_file (tar.path (..module_file module_id))]
+ (wrap (#tar.Normal [module_file now ..mode ..ownership entry_content]))))
+
+(def: #export (package now)
+ (-> Instant Packager)
+ (function (package archive program)
+ (do {! try.monad}
+ [order (dependency.load_order $.key archive)
+ #let [mapping (|> order
+ (list\map (function (_ [module [module_id [descriptor document output]]])
+ [module module_id]))
+ (dictionary.from_list text.hash)
+ (: (Dictionary Module archive.ID)))]
+ entries (monad.map ! (..write_module now mapping) order)]
+ (wrap (|> entries
+ row.from_list
+ (binary.run tar.writer))))))
diff --git a/stdlib/source/library/lux/tool/compiler/meta/packager/script.lux b/stdlib/source/library/lux/tool/compiler/meta/packager/script.lux
new file mode 100644
index 000000000..ac2b5758c
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/meta/packager/script.lux
@@ -0,0 +1,76 @@
+(.module:
+ [library
+ [lux #*
+ [type (#+ :share)]
+ [abstract
+ ["." monad (#+ Monad do)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ [binary (#+ Binary)]
+ ["." product]
+ [text
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." row]
+ ["." list ("#\." functor)]]]]]
+ [program
+ [compositor
+ ["." static (#+ Static)]]]
+ ["." // (#+ Packager)
+ [//
+ ["." archive (#+ Output)
+ ["." descriptor]
+ ["." artifact]]
+ [cache
+ ["." dependency]]
+ ["." io #_
+ ["#" archive]]
+ [//
+ [language
+ ["$" lux
+ [generation (#+ Context)]]]]]])
+
+## TODO: Delete ASAP
+(type: (Action ! a)
+ (! (Try a)))
+
+(def: (write_module sequence [module output] so_far)
+ (All [directive]
+ (-> (-> directive directive directive) [archive.ID Output] directive
+ (Try directive)))
+ (|> output
+ row.to_list
+ (list\map product.right)
+ (monad.fold try.monad
+ (function (_ content so_far)
+ (|> content
+ (\ utf8.codec decode)
+ (\ try.monad map
+ (function (_ content)
+ (sequence so_far
+ (:share [directive]
+ directive
+ so_far
+
+ directive
+ (:assume content)))))))
+ so_far)))
+
+(def: #export (package header to_code sequence scope)
+ (All [directive]
+ (-> directive
+ (-> directive Text)
+ (-> directive directive directive)
+ (-> directive directive)
+ Packager))
+ (function (package archive program)
+ (do {! try.monad}
+ [order (dependency.load_order $.key archive)]
+ (|> order
+ (list\map (function (_ [module [module_id [descriptor document output]]])
+ [module_id output]))
+ (monad.fold ! (..write_module sequence) header)
+ (\ ! map (|>> scope to_code (\ utf8.codec encode)))))))
diff --git a/stdlib/source/library/lux/tool/compiler/phase.lux b/stdlib/source/library/lux/tool/compiler/phase.lux
new file mode 100644
index 000000000..d69098f92
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/phase.lux
@@ -0,0 +1,119 @@
+(.module:
+ [library
+ [lux #*
+ ["." debug]
+ [abstract
+ [monad (#+ Monad do)]]
+ [control
+ ["." state]
+ ["." try (#+ Try) ("#\." functor)]
+ ["ex" exception (#+ Exception exception:)]
+ ["." io]
+ [parser
+ ["s" code]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]]
+ [time
+ ["." instant]
+ ["." duration]]
+ [macro
+ [syntax (#+ syntax:)]]]]
+ [//
+ [meta
+ [archive (#+ Archive)]]])
+
+(type: #export (Operation s o)
+ (state.State' Try s o))
+
+(def: #export monad
+ (All [s] (Monad (Operation s)))
+ (state.with try.monad))
+
+(type: #export (Phase s i o)
+ (-> Archive i (Operation s o)))
+
+(def: #export (run' state operation)
+ (All [s o]
+ (-> s (Operation s o) (Try [s o])))
+ (operation state))
+
+(def: #export (run state operation)
+ (All [s o]
+ (-> s (Operation s o) (Try o)))
+ (|> state
+ operation
+ (\ try.monad map product.right)))
+
+(def: #export get_state
+ (All [s o]
+ (Operation s s))
+ (function (_ state)
+ (#try.Success [state state])))
+
+(def: #export (set_state state)
+ (All [s o]
+ (-> s (Operation s Any)))
+ (function (_ _)
+ (#try.Success [state []])))
+
+(def: #export (sub [get set] operation)
+ (All [s s' o]
+ (-> [(-> s s') (-> s' s s)]
+ (Operation s' o)
+ (Operation s o)))
+ (function (_ state)
+ (do try.monad
+ [[state' output] (operation (get state))]
+ (wrap [(set state' state) output]))))
+
+(def: #export fail
+ (-> Text Operation)
+ (|>> try.fail (state.lift try.monad)))
+
+(def: #export (throw exception parameters)
+ (All [e] (-> (Exception e) e Operation))
+ (..fail (ex.construct exception parameters)))
+
+(def: #export (lift error)
+ (All [s a] (-> (Try a) (Operation s a)))
+ (function (_ state)
+ (try\map (|>> [state]) error)))
+
+(syntax: #export (assert exception message test)
+ (wrap (list (` (if (~ test)
+ (\ ..monad (~' wrap) [])
+ (..throw (~ exception) (~ message)))))))
+
+(def: #export identity
+ (All [s a] (Phase s a a))
+ (function (_ archive input state)
+ (#try.Success [state input])))
+
+(def: #export (compose pre post)
+ (All [s0 s1 i t o]
+ (-> (Phase s0 i t)
+ (Phase s1 t o)
+ (Phase [s0 s1] i o)))
+ (function (_ archive input [pre/state post/state])
+ (do try.monad
+ [[pre/state' temp] (pre archive input pre/state)
+ [post/state' output] (post archive temp post/state)]
+ (wrap [[pre/state' post/state'] output]))))
+
+(def: #export (timed definition description operation)
+ (All [s a]
+ (-> Name Text (Operation s a) (Operation s a)))
+ (do ..monad
+ [_ (wrap [])
+ #let [pre (io.run instant.now)]
+ output operation
+ #let [_ (|> instant.now
+ io.run
+ instant.relative
+ (duration.difference (instant.relative pre))
+ %.duration
+ (format (%.name definition) " [" description "]: ")
+ debug.log!)]]
+ (wrap output)))
diff --git a/stdlib/source/library/lux/tool/compiler/reference.lux b/stdlib/source/library/lux/tool/compiler/reference.lux
new file mode 100644
index 000000000..8823b29e2
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/reference.lux
@@ -0,0 +1,85 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]]
+ [control
+ [pipe (#+ case>)]]
+ [data
+ ["." name]
+ [text
+ ["%" format (#+ Format)]]]
+ [math
+ [number
+ ["n" nat]]]]]
+ ["." / #_
+ ["#." variable (#+ Variable)]])
+
+(type: #export Constant
+ Name)
+
+(type: #export Reference
+ (#Variable Variable)
+ (#Constant Constant))
+
+(implementation: #export equivalence
+ (Equivalence Reference)
+
+ (def: (= reference sample)
+ (case [reference sample]
+ (^template [<tag> <equivalence>]
+ [[(<tag> reference) (<tag> sample)]
+ (\ <equivalence> = reference sample)])
+ ([#Variable /variable.equivalence]
+ [#Constant name.equivalence])
+
+ _
+ false)))
+
+(implementation: #export hash
+ (Hash Reference)
+
+ (def: &equivalence
+ ..equivalence)
+
+ (def: (hash value)
+ (case value
+ (^template [<factor> <tag> <hash>]
+ [(<tag> value)
+ ($_ n.* <factor>
+ (\ <hash> hash value))])
+ ([2 #Variable /variable.hash]
+ [3 #Constant name.hash])
+ )))
+
+(template [<name> <family> <tag>]
+ [(template: #export (<name> content)
+ (<| <family>
+ <tag>
+ content))]
+
+ [local #..Variable #/variable.Local]
+ [foreign #..Variable #/variable.Foreign]
+ )
+
+(template [<name> <tag>]
+ [(template: #export (<name> content)
+ (<| <tag>
+ content))]
+
+ [variable #..Variable]
+ [constant #..Constant]
+ )
+
+(def: #export self
+ Reference
+ (..local 0))
+
+(def: #export format
+ (Format Reference)
+ (|>> (case> (#Variable variable)
+ (/variable.format variable)
+
+ (#Constant constant)
+ (%.name constant))))
diff --git a/stdlib/source/library/lux/tool/compiler/reference/variable.lux b/stdlib/source/library/lux/tool/compiler/reference/variable.lux
new file mode 100644
index 000000000..a8ce4c049
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/reference/variable.lux
@@ -0,0 +1,68 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]]
+ [control
+ [pipe (#+ case>)]]
+ [data
+ [text
+ ["%" format (#+ Format)]]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]]]]])
+
+(type: #export Register
+ Nat)
+
+(type: #export Variable
+ (#Local Register)
+ (#Foreign Register))
+
+(implementation: #export equivalence
+ (Equivalence Variable)
+
+ (def: (= reference sample)
+ (case [reference sample]
+ (^template [<tag>]
+ [[(<tag> reference') (<tag> sample')]
+ (n.= reference' sample')])
+ ([#Local] [#Foreign])
+
+ _
+ #0)))
+
+(implementation: #export hash
+ (Hash Variable)
+
+ (def: &equivalence
+ ..equivalence)
+
+ (def: hash
+ (|>> (case> (^template [<factor> <tag>]
+ [(<tag> register)
+ ($_ n.* <factor>
+ (\ n.hash hash register))])
+ ([2 #Local]
+ [3 #Foreign])))))
+
+(template: #export (self)
+ (#..Local 0))
+
+(def: #export self?
+ (-> Variable Bit)
+ (|>> (case> (^ (..self))
+ true
+
+ _
+ false)))
+
+(def: #export format
+ (Format Variable)
+ (|>> (case> (#Local local)
+ (%.format "+" (%.nat local))
+
+ (#Foreign foreign)
+ (%.format "-" (%.nat foreign)))))
diff --git a/stdlib/source/library/lux/tool/compiler/version.lux b/stdlib/source/library/lux/tool/compiler/version.lux
new file mode 100644
index 000000000..733b86477
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/version.lux
@@ -0,0 +1,52 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ [text
+ ["%" format]]]
+ [math
+ [number
+ ["n" nat]]]]])
+
+(type: #export Version
+ Nat)
+
+(def: range 100)
+
+(def: level
+ (n.% ..range))
+
+(def: current
+ (-> Nat Nat)
+ (|>>))
+
+(def: next
+ (n./ ..range))
+
+(def: #export patch
+ (-> Version Nat)
+ (|>> ..current ..level))
+
+(def: #export minor
+ (-> Version Nat)
+ (|>> ..next ..level))
+
+(def: #export major
+ (-> Version Nat)
+ (|>> ..next ..next ..level))
+
+(def: separator ".")
+
+(def: (padded value)
+ (-> Nat Text)
+ (if (n.< 10 value)
+ (%.format "0" (%.nat value))
+ (%.nat value)))
+
+(def: #export (format version)
+ (%.Format Version)
+ (%.format (..padded (..major version))
+ ..separator
+ (..padded (..minor version))
+ ..separator
+ (..padded (..patch version))))
diff --git a/stdlib/source/library/lux/tool/interpreter.lux b/stdlib/source/library/lux/tool/interpreter.lux
new file mode 100644
index 000000000..df48eb420
--- /dev/null
+++ b/stdlib/source/library/lux/tool/interpreter.lux
@@ -0,0 +1,222 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ [monad (#+ Monad do)]
+ ["." try (#+ Try)]
+ ["ex" exception (#+ exception:)]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]
+ [type (#+ :share)
+ ["." check]]
+ [compiler
+ ["." phase
+ ["." analysis
+ ["." module]
+ ["." type]]
+ ["." generation]
+ ["." directive (#+ State+ Operation)
+ ["." total]]
+ ["." extension]]
+ ["." default
+ ["." syntax]
+ ["." platform (#+ Platform)]
+ ["." init]]
+ ["." cli (#+ Configuration)]]
+ [world
+ ["." file (#+ File)]
+ ["." console (#+ Console)]]]]
+ ["." /type])
+
+(exception: #export (error {message Text})
+ message)
+
+(def: #export module "<INTERPRETER>")
+
+(def: fresh-source Source [[..module 1 0] 0 ""])
+
+(def: (add-line line [where offset input])
+ (-> Text Source Source)
+ [where offset (format input text.new-line line)])
+
+(def: exit-command Text "exit")
+
+(def: welcome-message
+ Text
+ (format text.new-line
+ "Welcome to the interpreter!" text.new-line
+ "Type '" ..exit-command "' to leave." text.new-line
+ text.new-line))
+
+(def: farewell-message
+ Text
+ "Till next time...")
+
+(def: enter-module
+ (All [anchor expression directive]
+ (Operation anchor expression directive Any))
+ (directive.lift-analysis
+ (do phase.monad
+ [_ (module.create 0 ..module)]
+ (analysis.set-current-module ..module))))
+
+(def: (initialize Monad<!> Console<!> platform configuration generation-bundle)
+ (All [! anchor expression directive]
+ (-> (Monad !)
+ (Console !) (Platform ! anchor expression directive)
+ Configuration
+ (generation.Bundle anchor expression directive)
+ (! (State+ anchor expression directive))))
+ (do Monad<!>
+ [state (platform.initialize platform generation-bundle)
+ state (platform.compile platform
+ (set@ #cli.module syntax.prelude configuration)
+ (set@ [#extension.state
+ #directive.analysis #directive.state
+ #extension.state
+ #.info #.mode]
+ #.Interpreter
+ state))
+ [state _] (\ (get@ #platform.file-system platform)
+ lift (phase.run' state enter-module))
+ _ (\ Console<!> write ..welcome-message)]
+ (wrap state)))
+
+(with-expansions [<Interpretation> (as-is (Operation anchor expression directive [Type Any]))]
+
+ (def: (interpret-directive code)
+ (All [anchor expression directive]
+ (-> Code <Interpretation>))
+ (do phase.monad
+ [_ (total.phase code)
+ _ init.refresh]
+ (wrap [Any []])))
+
+ (def: (interpret-expression code)
+ (All [anchor expression directive]
+ (-> Code <Interpretation>))
+ (do {! phase.monad}
+ [state (extension.lift phase.get-state)
+ #let [analyse (get@ [#directive.analysis #directive.phase] state)
+ synthesize (get@ [#directive.synthesis #directive.phase] state)
+ generate (get@ [#directive.generation #directive.phase] state)]
+ [_ codeT codeA] (directive.lift-analysis
+ (analysis.with-scope
+ (type.with-fresh-env
+ (do !
+ [[codeT codeA] (type.with-inference
+ (analyse code))
+ codeT (type.with-env
+ (check.clean codeT))]
+ (wrap [codeT codeA])))))
+ codeS (directive.lift-synthesis
+ (synthesize codeA))]
+ (directive.lift-generation
+ (generation.with-buffer
+ (do !
+ [codeH (generate codeS)
+ count generation.next
+ codeV (generation.evaluate! (format "interpretation_" (%.nat count)) codeH)]
+ (wrap [codeT codeV]))))))
+
+ (def: (interpret configuration code)
+ (All [anchor expression directive]
+ (-> Configuration Code <Interpretation>))
+ (function (_ state)
+ (case (<| (phase.run' state)
+ (:share [anchor expression directive]
+ {(State+ anchor expression directive)
+ state}
+ {<Interpretation>
+ (interpret-directive code)}))
+ (#try.Success [state' output])
+ (#try.Success [state' output])
+
+ (#try.Failure error)
+ (if (ex.match? total.not-a-directive error)
+ (<| (phase.run' state)
+ (:share [anchor expression directive]
+ {(State+ anchor expression directive)
+ state}
+ {<Interpretation>
+ (interpret-expression code)}))
+ (#try.Failure error)))))
+ )
+
+(def: (execute configuration code)
+ (All [anchor expression directive]
+ (-> Configuration Code (Operation anchor expression directive Text)))
+ (do phase.monad
+ [[codeT codeV] (interpret configuration code)
+ state phase.get-state]
+ (wrap (/type.represent (get@ [#extension.state
+ #directive.analysis #directive.state
+ #extension.state]
+ state)
+ codeT
+ codeV))))
+
+(type: (Context anchor expression directive)
+ {#configuration Configuration
+ #state (State+ anchor expression directive)
+ #source Source})
+
+(with-expansions [<Context> (as-is (Context anchor expression directive))]
+ (def: (read-eval-print context)
+ (All [anchor expression directive]
+ (-> <Context> (Try [<Context> Text])))
+ (do try.monad
+ [#let [[_where _offset _code] (get@ #source context)]
+ [source' input] (syntax.parse ..module syntax.no-aliases (text.size _code) (get@ #source context))
+ [state' representation] (let [## TODO: Simplify ASAP
+ state (:share [anchor expression directive]
+ {<Context>
+ context}
+ {(State+ anchor expression directive)
+ (get@ #state context)})]
+ (<| (phase.run' state)
+ ## TODO: Simplify ASAP
+ (:share [anchor expression directive]
+ {<Context>
+ context}
+ {(Operation anchor expression directive Text)
+ (execute (get@ #configuration context) input)})))]
+ (wrap [(|> context
+ (set@ #state state')
+ (set@ #source source'))
+ representation]))))
+
+(def: #export (run Monad<!> Console<!> platform configuration generation-bundle)
+ (All [! anchor expression directive]
+ (-> (Monad !)
+ (Console !) (Platform ! anchor expression directive)
+ Configuration
+ (generation.Bundle anchor expression directive)
+ (! Any)))
+ (do {! Monad<!>}
+ [state (initialize Monad<!> Console<!> platform configuration)]
+ (loop [context {#configuration configuration
+ #state state
+ #source ..fresh-source}
+ multi-line? #0]
+ (do !
+ [_ (if multi-line?
+ (\ Console<!> write " ")
+ (\ Console<!> write "> "))
+ line (\ Console<!> read-line)]
+ (if (and (not multi-line?)
+ (text\= ..exit-command line))
+ (\ Console<!> write ..farewell-message)
+ (case (read-eval-print (update@ #source (add-line line) context))
+ (#try.Success [context' representation])
+ (do !
+ [_ (\ Console<!> write representation)]
+ (recur context' #0))
+
+ (#try.Failure error)
+ (if (ex.match? syntax.end-of-file error)
+ (recur context #1)
+ (exec (log! (ex.construct ..error error))
+ (recur (set@ #source ..fresh-source context) #0))))))
+ )))
diff --git a/stdlib/source/library/lux/tool/mediator.lux b/stdlib/source/library/lux/tool/mediator.lux
new file mode 100644
index 000000000..b24309ef1
--- /dev/null
+++ b/stdlib/source/library/lux/tool/mediator.lux
@@ -0,0 +1,19 @@
+(.module:
+ [library
+ [lux (#- Source Module)
+ [world
+ ["." binary (#+ Binary)]
+ ["." file (#+ File)]]]]
+ [//
+ [compiler (#+ Compiler)
+ [meta
+ ["." archive (#+ Archive)
+ [descriptor (#+ Module)]]]]])
+
+(type: #export Source File)
+
+(type: #export (Mediator !)
+ (-> Archive Module (! Archive)))
+
+(type: #export (Instancer ! d o)
+ (-> (file.System !) (List Source) (Compiler d o) (Mediator !)))
diff --git a/stdlib/source/library/lux/type.lux b/stdlib/source/library/lux/type.lux
new file mode 100644
index 000000000..751645cc4
--- /dev/null
+++ b/stdlib/source/library/lux/type.lux
@@ -0,0 +1,463 @@
+(.module: {#.doc "Basic functionality for working with types."}
+ [library
+ [lux (#- function)
+ ["@" target]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ Monad do)]]
+ [control
+ ["." function]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text ("#\." monoid equivalence)]
+ ["." name ("#\." equivalence codec)]
+ [collection
+ ["." array]
+ ["." list ("#\." functor monoid fold)]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ [number
+ ["n" nat ("#\." decimal)]]]
+ ["." meta
+ ["." location]]]])
+
+(template [<name> <tag>]
+ [(def: #export (<name> type)
+ (-> Type [Nat Type])
+ (loop [num_args 0
+ type type]
+ (case type
+ (<tag> env sub_type)
+ (recur (inc num_args) sub_type)
+
+ _
+ [num_args type])))]
+
+ [flatten_univ_q #.UnivQ]
+ [flatten_ex_q #.ExQ]
+ )
+
+(def: #export (flatten_function type)
+ (-> Type [(List Type) Type])
+ (case type
+ (#.Function in out')
+ (let [[ins out] (flatten_function out')]
+ [(list& in ins) out])
+
+ _
+ [(list) type]))
+
+(def: #export (flatten_application type)
+ (-> Type [Type (List Type)])
+ (case type
+ (#.Apply arg func')
+ (let [[func args] (flatten_application func')]
+ [func (list\compose args (list arg))])
+
+ _
+ [type (list)]))
+
+(template [<name> <tag>]
+ [(def: #export (<name> type)
+ (-> Type (List Type))
+ (case type
+ (<tag> left right)
+ (list& left (<name> right))
+
+ _
+ (list type)))]
+
+ [flatten_variant #.Sum]
+ [flatten_tuple #.Product]
+ )
+
+(def: #export (format type)
+ (-> Type Text)
+ (case type
+ (#.Primitive name params)
+ ($_ text\compose
+ "(primitive "
+ (text.enclose' text.double_quote name)
+ (|> params
+ (list\map (|>> format (text\compose " ")))
+ (list\fold (function.flip text\compose) ""))
+ ")")
+
+ (^template [<tag> <open> <close> <flatten>]
+ [(<tag> _)
+ ($_ text\compose <open>
+ (|> (<flatten> type)
+ (list\map format)
+ list.reverse
+ (list.interpose " ")
+ (list\fold text\compose ""))
+ <close>)])
+ ([#.Sum "(| " ")" flatten_variant]
+ [#.Product "[" "]" flatten_tuple])
+
+ (#.Function input output)
+ (let [[ins out] (flatten_function type)]
+ ($_ text\compose "(-> "
+ (|> ins
+ (list\map format)
+ list.reverse
+ (list.interpose " ")
+ (list\fold text\compose ""))
+ " " (format out) ")"))
+
+ (#.Parameter idx)
+ (n\encode idx)
+
+ (#.Var id)
+ ($_ text\compose "⌈v:" (n\encode id) "⌋")
+
+ (#.Ex id)
+ ($_ text\compose "⟨e:" (n\encode id) "⟩")
+
+ (#.Apply param fun)
+ (let [[type_func type_args] (flatten_application type)]
+ ($_ text\compose "(" (format type_func) " " (|> type_args (list\map format) list.reverse (list.interpose " ") (list\fold text\compose "")) ")"))
+
+ (^template [<tag> <desc>]
+ [(<tag> env body)
+ ($_ text\compose "(" <desc> " {" (|> env (list\map format) (text.join_with " ")) "} " (format body) ")")])
+ ([#.UnivQ "All"]
+ [#.ExQ "Ex"])
+
+ (#.Named [module name] type)
+ ($_ text\compose module "." name)
+ ))
+
+(def: (beta_reduce env type)
+ (-> (List Type) Type Type)
+ (case type
+ (#.Primitive name params)
+ (#.Primitive name (list\map (beta_reduce env) params))
+
+ (^template [<tag>]
+ [(<tag> left right)
+ (<tag> (beta_reduce env left) (beta_reduce env right))])
+ ([#.Sum] [#.Product]
+ [#.Function] [#.Apply])
+
+ (^template [<tag>]
+ [(<tag> old_env def)
+ (case old_env
+ #.Nil
+ (<tag> env def)
+
+ _
+ (<tag> (list\map (beta_reduce env) old_env) def))])
+ ([#.UnivQ]
+ [#.ExQ])
+
+ (#.Parameter idx)
+ (maybe.default (error! ($_ text\compose
+ "Unknown type parameter" text.new_line
+ " Index: " (n\encode idx) text.new_line
+ "Environment: " (|> env
+ list.enumeration
+ (list\map (.function (_ [index type])
+ ($_ text\compose
+ (n\encode index)
+ " " (..format type))))
+ (text.join_with (text\compose text.new_line " ")))))
+ (list.nth idx env))
+
+ _
+ type
+ ))
+
+(implementation: #export equivalence
+ (Equivalence Type)
+
+ (def: (= x y)
+ (or (for {@.php false} ## TODO: Remove this once JPHP is gone.
+ (is? x y))
+ (case [x y]
+ [(#.Primitive xname xparams) (#.Primitive yname yparams)]
+ (and (text\= xname yname)
+ (n.= (list.size yparams) (list.size xparams))
+ (list\fold (.function (_ [x y] prev) (and prev (= x y)))
+ #1
+ (list.zip/2 xparams yparams)))
+
+ (^template [<tag>]
+ [[(<tag> xid) (<tag> yid)]
+ (n.= yid xid)])
+ ([#.Var] [#.Ex] [#.Parameter])
+
+ (^or [(#.Function xleft xright) (#.Function yleft yright)]
+ [(#.Apply xleft xright) (#.Apply yleft yright)])
+ (and (= xleft yleft)
+ (= xright yright))
+
+ [(#.Named xname xtype) (#.Named yname ytype)]
+ (and (name\= xname yname)
+ (= xtype ytype))
+
+ (^template [<tag>]
+ [[(<tag> xL xR) (<tag> yL yR)]
+ (and (= xL yL) (= xR yR))])
+ ([#.Sum] [#.Product])
+
+ (^or [(#.UnivQ xenv xbody) (#.UnivQ yenv ybody)]
+ [(#.ExQ xenv xbody) (#.ExQ yenv ybody)])
+ (and (n.= (list.size yenv) (list.size xenv))
+ (= xbody ybody)
+ (list\fold (.function (_ [x y] prev) (and prev (= x y)))
+ #1
+ (list.zip/2 xenv yenv)))
+
+ _
+ #0
+ ))))
+
+(def: #export (apply params func)
+ (-> (List Type) Type (Maybe Type))
+ (case params
+ #.Nil
+ (#.Some func)
+
+ (#.Cons param params')
+ (case func
+ (^template [<tag>]
+ [(<tag> env body)
+ (|> body
+ (beta_reduce (list& func param env))
+ (apply params'))])
+ ([#.UnivQ] [#.ExQ])
+
+ (#.Apply A F)
+ (apply (list& A params) F)
+
+ (#.Named name unnamed)
+ (apply params unnamed)
+
+ _
+ #.None)))
+
+(def: #export (to_code type)
+ (-> Type Code)
+ (case type
+ (#.Primitive name params)
+ (` (#.Primitive (~ (code.text name))
+ (.list (~+ (list\map to_code params)))))
+
+ (^template [<tag>]
+ [(<tag> idx)
+ (` (<tag> (~ (code.nat idx))))])
+ ([#.Var] [#.Ex] [#.Parameter])
+
+ (^template [<tag>]
+ [(<tag> left right)
+ (` (<tag> (~ (to_code left))
+ (~ (to_code right))))])
+ ([#.Sum] [#.Product] [#.Function] [#.Apply])
+
+ (#.Named name sub_type)
+ (code.identifier name)
+
+ (^template [<tag>]
+ [(<tag> env body)
+ (` (<tag> (.list (~+ (list\map to_code env)))
+ (~ (to_code body))))])
+ ([#.UnivQ] [#.ExQ])
+ ))
+
+(def: #export (un_alias type)
+ (-> Type Type)
+ (case type
+ (#.Named _ (#.Named name type'))
+ (un_alias (#.Named name type'))
+
+ _
+ type))
+
+(def: #export (un_name type)
+ (-> Type Type)
+ (case type
+ (#.Named name type')
+ (un_name type')
+
+ _
+ type))
+
+(template [<name> <base> <ctor>]
+ [(def: #export (<name> types)
+ (-> (List Type) Type)
+ (case types
+ #.Nil
+ <base>
+
+ (#.Cons type #.Nil)
+ type
+
+ (#.Cons type types')
+ (<ctor> type (<name> types'))))]
+
+ [variant Nothing #.Sum]
+ [tuple Any #.Product]
+ )
+
+(def: #export (function inputs output)
+ (-> (List Type) Type Type)
+ (case inputs
+ #.Nil
+ output
+
+ (#.Cons input inputs')
+ (#.Function input (function inputs' output))))
+
+(def: #export (application params quant)
+ (-> (List Type) Type Type)
+ (case params
+ #.Nil
+ quant
+
+ (#.Cons param params')
+ (application params' (#.Apply param quant))))
+
+(template [<name> <tag>]
+ [(def: #export (<name> size body)
+ (-> Nat Type Type)
+ (case size
+ 0 body
+ _ (|> body (<name> (dec size)) (<tag> (list)))))]
+
+ [univ_q #.UnivQ]
+ [ex_q #.ExQ]
+ )
+
+(def: #export (quantified? type)
+ (-> Type Bit)
+ (case type
+ (#.Named [module name] _type)
+ (quantified? _type)
+
+ (#.Apply A F)
+ (maybe.default #0
+ (do maybe.monad
+ [applied (apply (list A) F)]
+ (wrap (quantified? applied))))
+
+ (^or (#.UnivQ _) (#.ExQ _))
+ #1
+
+ _
+ #0))
+
+(def: #export (array depth element_type)
+ (-> Nat Type Type)
+ (case depth
+ 0 element_type
+ _ (|> element_type
+ (array (dec depth))
+ (list)
+ (#.Primitive array.type_name))))
+
+(def: #export (flatten_array type)
+ (-> Type [Nat Type])
+ (case type
+ (^multi (^ (#.Primitive name (list element_type)))
+ (text\= array.type_name name))
+ (let [[depth element_type] (flatten_array element_type)]
+ [(inc depth) element_type])
+
+ _
+ [0 type]))
+
+(def: #export array?
+ (-> Type Bit)
+ (|>> ..flatten_array
+ product.left
+ (n.> 0)))
+
+(syntax: (new_secret_marker)
+ (macro.with_gensyms [g!_secret_marker_]
+ (wrap (list g!_secret_marker_))))
+
+(def: secret_marker
+ (`` (name_of (~~ (new_secret_marker)))))
+
+(syntax: #export (:log! {input (<>.or (<>.and <code>.identifier
+ (<>.maybe (<>.after (<code>.identifier! ..secret_marker) <code>.any)))
+ <code>.any)})
+ (case input
+ (#.Left [valueN valueC])
+ (do meta.monad
+ [location meta.location
+ valueT (meta.find_type valueN)
+ #let [_ ("lux io log"
+ ($_ text\compose
+ (name\encode (name_of ..:log!)) " " (location.format location) text.new_line
+ "Expression: " (case valueC
+ (#.Some valueC)
+ (code.format valueC)
+
+ #.None
+ (name\encode valueN))
+ text.new_line
+ " Type: " (..format valueT)))]]
+ (wrap (list (code.identifier valueN))))
+
+ (#.Right valueC)
+ (macro.with_gensyms [g!value]
+ (wrap (list (` (.let [(~ g!value) (~ valueC)]
+ (..:log! (~ valueC) (~ (code.identifier ..secret_marker)) (~ g!value)))))))))
+
+(def: type_parameters
+ (Parser (List Text))
+ (<code>.tuple (<>.some <code>.local_identifier)))
+
+(syntax: #export (:cast {type_vars type_parameters}
+ input
+ output
+ {value (<>.maybe <code>.any)})
+ (let [casterC (` (: (All [(~+ (list\map code.local_identifier type_vars))]
+ (-> (~ input) (~ output)))
+ (|>> :assume)))]
+ (case value
+ #.None
+ (wrap (list casterC))
+
+ (#.Some value)
+ (wrap (list (` ((~ casterC) (~ value))))))))
+
+(type: Typed
+ {#type Code
+ #expression Code})
+
+(def: typed
+ (Parser Typed)
+ (<>.and <code>.any <code>.any))
+
+## TODO: Make sure the generated code always gets optimized away.
+(syntax: #export (:share {type_vars ..type_parameters}
+ {exemplar ..typed}
+ {computation ..typed})
+ (macro.with_gensyms [g!_]
+ (let [shareC (` (: (All [(~+ (list\map code.local_identifier type_vars))]
+ (-> (~ (get@ #type exemplar))
+ (~ (get@ #type computation))))
+ (.function ((~ g!_) (~ g!_))
+ (~ (get@ #expression computation)))))]
+ (wrap (list (` ((~ shareC) (~ (get@ #expression exemplar)))))))))
+
+(syntax: #export (:by_example {type_vars ..type_parameters}
+ {exemplar ..typed}
+ {extraction <code>.any})
+ (wrap (list (` (:of ((~! :share)
+ [(~+ (list\map code.local_identifier type_vars))]
+
+ (~ (get@ #type exemplar))
+ (~ (get@ #expression exemplar))
+
+ (~ extraction)
+ (:assume [])))))))
diff --git a/stdlib/source/library/lux/type/abstract.lux b/stdlib/source/library/lux/type/abstract.lux
new file mode 100644
index 000000000..0bd4a505a
--- /dev/null
+++ b/stdlib/source/library/lux/type/abstract.lux
@@ -0,0 +1,269 @@
+(.module:
+ [library
+ [lux #*
+ [type (#+ :cast)]
+ ["." meta]
+ [abstract
+ [monad (#+ Monad do)]]
+ [control
+ ["." exception (#+ exception:)]
+ ["<>" parser ("#\." monad)
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." name ("#\." codec)]
+ ["." text ("#\." equivalence monoid)]
+ [collection
+ ["." list ("#\." functor monoid)]]]
+ [macro
+ ["." code]
+ [syntax (#+ syntax:)
+ ["|.|" export]
+ ["|.|" annotations]]]]])
+
+(type: Stack List)
+
+(def: peek
+ (All [a] (-> (Stack a) (Maybe a)))
+ list.head)
+
+(def: (push value stack)
+ (All [a] (-> a (Stack a) (Stack a)))
+ (#.Cons value stack))
+
+(def: pop
+ (All [a] (-> (Stack a) (Maybe (Stack a))))
+ list.tail)
+
+(type: #export Frame
+ {#name Text
+ #type_vars (List Code)
+ #abstraction Code
+ #representation Code})
+
+(def: frames
+ (Stack Frame)
+ #.Nil)
+
+(template: (!peek <source> <reference> <then>)
+ (loop [entries <source>]
+ (case entries
+ (#.Cons [head_name head] tail)
+ (if (text\= <reference> head_name)
+ <then>
+ (recur tail))
+
+ #.Nil
+ (undefined))))
+
+(def: (peek_frames_definition reference source)
+ (-> Text (List [Text Global]) (Stack Frame))
+ (!peek source reference
+ (case head
+ (#.Left _)
+ (undefined)
+
+ (#.Right [exported? frame_type frame_anns frame_value])
+ (:as (Stack Frame) frame_value))))
+
+(def: (peek_frames reference definition_reference source)
+ (-> Text Text (List [Text Module]) (Stack Frame))
+ (!peek source reference
+ (peek_frames_definition definition_reference (get@ #.definitions head))))
+
+(exception: #export no_active_frames)
+
+(def: (peek! frame)
+ (-> (Maybe Text) (Meta Frame))
+ (function (_ compiler)
+ (let [[reference definition_reference] (name_of ..frames)
+ current_frames (peek_frames reference definition_reference (get@ #.modules compiler))]
+ (case (case frame
+ (#.Some frame)
+ (list.find (function (_ [actual _])
+ (text\= frame actual))
+ current_frames)
+
+ #.None
+ (..peek current_frames))
+ (#.Some frame)
+ (#.Right [compiler frame])
+
+ #.None
+ (exception.throw ..no_active_frames [])))))
+
+(def: #export current
+ (Meta Frame)
+ (..peek! #.None))
+
+(def: #export (specific name)
+ (-> Text (Meta Frame))
+ (..peek! (#.Some name)))
+
+(template: (!push <source> <reference> <then>)
+ (loop [entries <source>]
+ (case entries
+ (#.Cons [head_name head] tail)
+ (if (text\= <reference> head_name)
+ (#.Cons [head_name <then>]
+ tail)
+ (#.Cons [head_name head]
+ (recur tail)))
+
+ #.Nil
+ (undefined))))
+
+(def: (push_frame_definition reference frame source)
+ (-> Text Frame (List [Text Global]) (List [Text Global]))
+ (!push source reference
+ (case head
+ (#.Left _)
+ (undefined)
+
+ (#.Right [exported? frames_type frames_anns frames_value])
+ (#.Right [exported?
+ frames_type
+ frames_anns
+ (..push frame (:as (Stack Frame) frames_value))]))))
+
+(def: (push_frame [module_reference definition_reference] frame source)
+ (-> Name Frame (List [Text Module]) (List [Text Module]))
+ (!push source module_reference
+ (update@ #.definitions (push_frame_definition definition_reference frame) head)))
+
+(def: (push! frame)
+ (-> Frame (Meta Any))
+ (function (_ compiler)
+ (#.Right [(update@ #.modules
+ (..push_frame (name_of ..frames) frame)
+ compiler)
+ []])))
+
+(def: (pop_frame_definition reference source)
+ (-> Text (List [Text Global]) (List [Text Global]))
+ (!push source reference
+ (case head
+ (#.Left _)
+ (undefined)
+
+ (#.Right [exported? frames_type frames_anns frames_value])
+ (#.Right [exported?
+ frames_type
+ frames_anns
+ (let [current_frames (:as (Stack Frame) frames_value)]
+ (case (..pop current_frames)
+ (#.Some current_frames')
+ current_frames'
+
+ #.None
+ current_frames))]))))
+
+(def: (pop_frame [module_reference definition_reference] source)
+ (-> Name (List [Text Module]) (List [Text Module]))
+ (!push source module_reference
+ (|> head (update@ #.definitions (pop_frame_definition definition_reference)))))
+
+(syntax: (pop!)
+ (function (_ compiler)
+ (#.Right [(update@ #.modules
+ (..pop_frame (name_of ..frames))
+ compiler)
+ (list)])))
+
+(def: cast
+ (Parser [(Maybe Text) Code])
+ (<>.either (<>.and (<>.maybe <code>.local_identifier) <code>.any)
+ (<>.and (<>\wrap #.None) <code>.any)))
+
+(template [<name> <from> <to>]
+ [(syntax: #export (<name> {[frame value] ..cast})
+ (do meta.monad
+ [[name type_vars abstraction representation] (peek! frame)]
+ (wrap (list (` ((~! :cast) [(~+ type_vars)] (~ <from>) (~ <to>)
+ (~ value)))))))]
+
+ [:abstraction representation abstraction]
+ [:representation abstraction representation]
+ )
+
+(def: abstraction_type_name
+ (-> Name Text)
+ (|>> name\encode
+ ($_ text\compose
+ (name\encode (name_of #..Abstraction))
+ " ")))
+
+(def: representation_definition_name
+ (-> Text Text)
+ (|>> ($_ text\compose
+ (name\encode (name_of #..Representation))
+ " ")))
+
+(def: declaration
+ (Parser [Text (List Text)])
+ (<>.either (<code>.form (<>.and <code>.local_identifier (<>.some <code>.local_identifier)))
+ (<>.and <code>.local_identifier (\ <>.monad wrap (list)))))
+
+## TODO: Make sure the generated code always gets optimized away.
+## (This applies to uses of ":abstraction" and ":representation")
+(syntax: #export (abstract:
+ {export |export|.parser}
+ {[name type_vars] declaration}
+ representation_type
+ {annotations (<>.default |annotations|.empty |annotations|.parser)}
+ {primitives (<>.some <code>.any)})
+ (do meta.monad
+ [current_module meta.current_module_name
+ #let [type_varsC (list\map code.local_identifier type_vars)
+ abstraction_declaration (` ((~ (code.local_identifier name)) (~+ type_varsC)))
+ representation_declaration (` ((~ (code.local_identifier (representation_definition_name name)))
+ (~+ type_varsC)))]
+ _ (..push! [name
+ type_varsC
+ abstraction_declaration
+ representation_declaration])]
+ (wrap (list& (` (type: (~+ (|export|.format export)) (~ abstraction_declaration)
+ (~ (|annotations|.format annotations))
+ (primitive (~ (code.text (abstraction_type_name [current_module name])))
+ [(~+ type_varsC)])))
+ (` (type: (~ representation_declaration)
+ (~ representation_type)))
+ ($_ list\compose
+ primitives
+ (list (` ((~! ..pop!)))))))))
+
+(type: (Selection a)
+ (#Specific Code a)
+ (#Current a))
+
+(def: (selection parser)
+ (All [a] (-> (Parser a) (Parser (Selection a))))
+ (<>.or (<>.and <code>.any parser)
+ parser))
+
+(syntax: #export (:transmutation {selection (..selection <code>.any)})
+ (case selection
+ (#Specific specific value)
+ (wrap (list (` (..:abstraction (~ specific)
+ (..:representation (~ specific)
+ (~ value))))))
+
+ (#Current value)
+ (wrap (list (` (..:abstraction (..:representation (~ value))))))))
+
+(syntax: #export (^:representation {selection (<code>.form (..selection <code>.local_identifier))}
+ body
+ {branches (<>.some <code>.any)})
+ (case selection
+ (#Specific specific name)
+ (let [g!var (code.local_identifier name)]
+ (wrap (list& g!var
+ (` (.let [(~ g!var) (..:representation (~ specific) (~ g!var))]
+ (~ body)))
+ branches)))
+
+ (#Current name)
+ (let [g!var (code.local_identifier name)]
+ (wrap (list& g!var
+ (` (.let [(~ g!var) (..:representation (~ g!var))]
+ (~ body)))
+ branches)))))
diff --git a/stdlib/source/library/lux/type/check.lux b/stdlib/source/library/lux/type/check.lux
new file mode 100644
index 000000000..a8b447338
--- /dev/null
+++ b/stdlib/source/library/lux/type/check.lux
@@ -0,0 +1,721 @@
+(.module: {#.doc "Type-checking functionality."}
+ [library
+ [lux #*
+ ["@" target]
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ ["." monad (#+ Monad do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ Exception exception:)]]
+ [data
+ ["." maybe]
+ ["." product]
+ ["." text ("#\." monoid equivalence)]
+ [collection
+ ["." list]
+ ["." set (#+ Set)]]]
+ [math
+ [number
+ ["n" nat ("#\." decimal)]]]]]
+ ["." // ("#\." equivalence)])
+
+(template: (!n\= reference subject)
+ ("lux i64 =" reference subject))
+
+(template: (!text\= reference subject)
+ ("lux text =" reference subject))
+
+(exception: #export (unknown_type_var {id Nat})
+ (exception.report
+ ["ID" (n\encode id)]))
+
+(exception: #export (unbound_type_var {id Nat})
+ (exception.report
+ ["ID" (n\encode id)]))
+
+(exception: #export (invalid_type_application {funcT Type} {argT Type})
+ (exception.report
+ ["Type function" (//.format funcT)]
+ ["Type argument" (//.format argT)]))
+
+(exception: #export (cannot_rebind_var {id Nat} {type Type} {bound Type})
+ (exception.report
+ ["Var" (n\encode id)]
+ ["Wanted Type" (//.format type)]
+ ["Current Type" (//.format bound)]))
+
+(exception: #export (type_check_failed {expected Type} {actual Type})
+ (exception.report
+ ["Expected" (//.format expected)]
+ ["Actual" (//.format actual)]))
+
+(type: #export Var
+ Nat)
+
+(type: Assumption
+ [Type Type])
+
+(type: #export (Check a)
+ (-> Type_Context (Try [Type_Context a])))
+
+(type: (Checker a)
+ (-> (List Assumption) a a (Check (List Assumption))))
+
+(type: Type_Vars
+ (List [Var (Maybe Type)]))
+
+(implementation: #export functor
+ (Functor Check)
+
+ (def: (map f fa)
+ (function (_ context)
+ (case (fa context)
+ (#try.Success [context' output])
+ (#try.Success [context' (f output)])
+
+ (#try.Failure error)
+ (#try.Failure error)))))
+
+(implementation: #export apply
+ (Apply Check)
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (function (_ context)
+ (case (ff context)
+ (#try.Success [context' f])
+ (case (fa context')
+ (#try.Success [context'' a])
+ (#try.Success [context'' (f a)])
+
+ (#try.Failure error)
+ (#try.Failure error))
+
+ (#try.Failure error)
+ (#try.Failure error)
+ )))
+ )
+
+(implementation: #export monad
+ (Monad Check)
+
+ (def: &functor ..functor)
+
+ (def: (wrap x)
+ (function (_ context)
+ (#try.Success [context x])))
+
+ (def: (join ffa)
+ (function (_ context)
+ (case (ffa context)
+ (#try.Success [context' fa])
+ (case (fa context')
+ (#try.Success [context'' a])
+ (#try.Success [context'' a])
+
+ (#try.Failure error)
+ (#try.Failure error))
+
+ (#try.Failure error)
+ (#try.Failure error)
+ )))
+ )
+
+(open: "check\." ..monad)
+
+(def: (var::new id plist)
+ (-> Var Type_Vars Type_Vars)
+ (#.Cons [id #.None] plist))
+
+(def: (var::get id plist)
+ (-> Var Type_Vars (Maybe (Maybe Type)))
+ (case plist
+ (#.Cons [var_id var_type]
+ plist')
+ (if (!n\= id var_id)
+ (#.Some var_type)
+ (var::get id plist'))
+
+ #.Nil
+ #.None))
+
+(def: (var::put id value plist)
+ (-> Var (Maybe Type) Type_Vars Type_Vars)
+ (case plist
+ #.Nil
+ (list [id value])
+
+ (#.Cons [var_id var_type]
+ plist')
+ (if (!n\= id var_id)
+ (#.Cons [var_id value]
+ plist')
+ (#.Cons [var_id var_type]
+ (var::put id value plist')))))
+
+(def: #export (run context proc)
+ (All [a] (-> Type_Context (Check a) (Try a)))
+ (case (proc context)
+ (#try.Success [context' output])
+ (#try.Success output)
+
+ (#try.Failure error)
+ (#try.Failure error)))
+
+(def: #export (fail message)
+ (All [a] (-> Text (Check a)))
+ (function (_ context)
+ (#try.Failure message)))
+
+(def: #export (assert message test)
+ (-> Text Bit (Check Any))
+ (function (_ context)
+ (if test
+ (#try.Success [context []])
+ (#try.Failure message))))
+
+(def: #export (throw exception message)
+ (All [e a] (-> (Exception e) e (Check a)))
+ (..fail (exception.construct exception message)))
+
+(def: #export existential
+ {#.doc "A producer of existential types."}
+ (Check [Nat Type])
+ (function (_ context)
+ (let [id (get@ #.ex_counter context)]
+ (#try.Success [(update@ #.ex_counter inc context)
+ [id (#.Ex id)]]))))
+
+(template [<name> <outputT> <fail> <succeed>]
+ [(def: #export (<name> id)
+ (-> Var (Check <outputT>))
+ (function (_ context)
+ (case (|> context (get@ #.var_bindings) (var::get id))
+ (^or (#.Some (#.Some (#.Var _)))
+ (#.Some #.None))
+ (#try.Success [context <fail>])
+
+ (#.Some (#.Some bound))
+ (#try.Success [context <succeed>])
+
+ #.None
+ (exception.throw ..unknown_type_var id))))]
+
+ [bound? Bit false true]
+ [read (Maybe Type) #.None (#.Some bound)]
+ )
+
+(def: #export (read! id)
+ (-> Var (Check Type))
+ (do ..monad
+ [?type (read id)]
+ (case ?type
+ (#.Some type)
+ (wrap type)
+
+ #.None
+ (..throw ..unbound_type_var id))))
+
+(def: (peek id)
+ (-> Var (Check Type))
+ (function (_ context)
+ (case (|> context (get@ #.var_bindings) (var::get id))
+ (#.Some (#.Some bound))
+ (#try.Success [context bound])
+
+ (#.Some _)
+ (exception.throw ..unbound_type_var id)
+
+ _
+ (exception.throw ..unknown_type_var id))))
+
+(def: #export (bind type id)
+ (-> Type Var (Check Any))
+ (function (_ context)
+ (case (|> context (get@ #.var_bindings) (var::get id))
+ (#.Some #.None)
+ (#try.Success [(update@ #.var_bindings (var::put id (#.Some type)) context)
+ []])
+
+ (#.Some (#.Some bound))
+ (exception.throw ..cannot_rebind_var [id type bound])
+
+ _
+ (exception.throw ..unknown_type_var id))))
+
+(def: (update type id)
+ (-> Type Var (Check Any))
+ (function (_ context)
+ (case (|> context (get@ #.var_bindings) (var::get id))
+ (#.Some _)
+ (#try.Success [(update@ #.var_bindings (var::put id (#.Some type)) context)
+ []])
+
+ _
+ (exception.throw ..unknown_type_var id))))
+
+(def: #export var
+ (Check [Var Type])
+ (function (_ context)
+ (let [id (get@ #.var_counter context)]
+ (#try.Success [(|> context
+ (update@ #.var_counter inc)
+ (update@ #.var_bindings (var::new id)))
+ [id (#.Var id)]]))))
+
+(def: (apply_type! funcT argT)
+ (-> Type Type (Check Type))
+ (case funcT
+ (#.Var func_id)
+ (do ..monad
+ [?funcT' (read func_id)]
+ (case ?funcT'
+ (#.Some funcT')
+ (apply_type! funcT' argT)
+
+ _
+ (throw ..invalid_type_application [funcT argT])))
+
+ (#.Apply argT' funcT')
+ (do ..monad
+ [funcT'' (apply_type! funcT' argT')]
+ (apply_type! funcT'' argT))
+
+ _
+ (case (//.apply (list argT) funcT)
+ (#.Some output)
+ (check\wrap output)
+
+ _
+ (throw ..invalid_type_application [funcT argT]))))
+
+(type: Ring
+ (Set Var))
+
+(def: empty_ring
+ Ring
+ (set.new n.hash))
+
+## TODO: Optimize this by not using sets anymore.
+(def: (ring start)
+ (-> Var (Check Ring))
+ (function (_ context)
+ (loop [current start
+ output (set.add start empty_ring)]
+ (case (|> context (get@ #.var_bindings) (var::get current))
+ (#.Some (#.Some type))
+ (case type
+ (#.Var post)
+ (if (!n\= start post)
+ (#try.Success [context output])
+ (recur post (set.add post output)))
+
+ _
+ (#try.Success [context empty_ring]))
+
+ (#.Some #.None)
+ (#try.Success [context output])
+
+ #.None
+ (exception.throw ..unknown_type_var current)))))
+
+(def: #export fresh_context
+ Type_Context
+ {#.var_counter 0
+ #.ex_counter 0
+ #.var_bindings (list)})
+
+(def: (attempt op)
+ (All [a] (-> (Check a) (Check (Maybe a))))
+ (function (_ context)
+ (case (op context)
+ (#try.Success [context' output])
+ (#try.Success [context' (#.Some output)])
+
+ (#try.Failure _)
+ (#try.Success [context #.None]))))
+
+(def: (either left right)
+ (All [a] (-> (Check a) (Check a) (Check a)))
+ (function (_ context)
+ (case (left context)
+ (#try.Failure _)
+ (right context)
+
+ output
+ output)))
+
+(def: (assumed? [e a] assumptions)
+ (-> Assumption (List Assumption) Bit)
+ (list.any? (function (_ [e' a'])
+ (and (//\= e e')
+ (//\= a a')))
+ assumptions))
+
+(def: (assume! assumption assumptions)
+ (-> Assumption (List Assumption) (List Assumption))
+ (#.Cons assumption assumptions))
+
+## TODO: "if_bind" can be optimized...
+(def: (if_bind id type then else)
+ (All [a]
+ (-> Var Type (Check a) (-> Type (Check a))
+ (Check a)))
+ ($_ either
+ (do ..monad
+ [_ (..bind type id)]
+ then)
+ (do {! ..monad}
+ [ring (..ring id)
+ _ (assert "" (n.> 1 (set.size ring)))
+ _ (monad.map ! (update type) (set.to_list ring))]
+ then)
+ (do ..monad
+ [?bound (read id)]
+ (else (maybe.default (#.Var id) ?bound)))))
+
+## TODO: "link_2" can be optimized...
+(def: (link_2 left right)
+ (-> Var Var (Check Any))
+ (do ..monad
+ [_ (..bind (#.Var right) left)]
+ (..bind (#.Var left) right)))
+
+## TODO: "link_3" can be optimized...
+(def: (link_3 interpose to from)
+ (-> Var Var Var (Check Any))
+ (do ..monad
+ [_ (update (#.Var interpose) from)]
+ (update (#.Var to) interpose)))
+
+## TODO: "check_vars" can be optimized...
+(def: (check_vars check' assumptions idE idA)
+ (-> (Checker Type) (Checker Var))
+ (if (!n\= idE idA)
+ (check\wrap assumptions)
+ (do {! ..monad}
+ [ebound (attempt (peek idE))
+ abound (attempt (peek idA))]
+ (case [ebound abound]
+ ## Link the 2 variables circularly
+ [#.None #.None]
+ (do !
+ [_ (link_2 idE idA)]
+ (wrap assumptions))
+
+ ## Interpose new variable between 2 existing links
+ [(#.Some etype) #.None]
+ (case etype
+ (#.Var targetE)
+ (do !
+ [_ (link_3 idA targetE idE)]
+ (wrap assumptions))
+
+ _
+ (check' assumptions etype (#.Var idA)))
+
+ ## Interpose new variable between 2 existing links
+ [#.None (#.Some atype)]
+ (case atype
+ (#.Var targetA)
+ (do !
+ [_ (link_3 idE targetA idA)]
+ (wrap assumptions))
+
+ _
+ (check' assumptions (#.Var idE) atype))
+
+ [(#.Some etype) (#.Some atype)]
+ (case [etype atype]
+ [(#.Var targetE) (#.Var targetA)]
+ (do !
+ [ringE (..ring idE)
+ ringA (..ring idA)]
+ (if (\ set.equivalence = ringE ringA)
+ (wrap assumptions)
+ ## Fuse 2 rings
+ (do !
+ [_ (monad.fold ! (function (_ interpose to)
+ (do !
+ [_ (link_3 interpose to idE)]
+ (wrap interpose)))
+ targetE
+ (set.to_list ringA))]
+ (wrap assumptions))))
+
+ (^template [<pattern> <id> <type>]
+ [<pattern>
+ (do !
+ [ring (..ring <id>)
+ _ (monad.map ! (update <type>) (set.to_list ring))]
+ (wrap assumptions))])
+ ([[(#.Var _) _] idE atype]
+ [[_ (#.Var _)] idA etype])
+
+ _
+ (check' assumptions etype atype))))))
+
+(def: silent_failure!
+ (All [a] (Check a))
+ (..fail ""))
+
+## TODO: "check_apply" can be optimized...
+(def: (check_apply check' assumptions expected actual)
+ (-> (Checker Type) (Checker [Type Type]))
+ (let [[expected_input expected_function] expected
+ [actual_input actual_function] actual]
+ (case [expected_function actual_function]
+ [(#.Ex exE) (#.Ex exA)]
+ (if (!n\= exE exA)
+ (check' assumptions expected_input actual_input)
+ ..silent_failure!)
+
+ [(#.UnivQ _ _) (#.Ex _)]
+ (do ..monad
+ [expected' (apply_type! expected_function expected_input)]
+ (check' assumptions expected' (#.Apply actual)))
+
+ [(#.Ex _) (#.UnivQ _ _)]
+ (do ..monad
+ [actual' (apply_type! actual_function actual_input)]
+ (check' assumptions (#.Apply expected) actual'))
+
+ [(#.Apply [expected_input' expected_function']) (#.Ex _)]
+ (do ..monad
+ [expected_function'' (apply_type! expected_function' expected_input')]
+ (check' assumptions (#.Apply [expected_input expected_function'']) (#.Apply actual)))
+
+ [(#.Ex _) (#.Apply [actual_input' actual_function'])]
+ (do ..monad
+ [actual_function'' (apply_type! actual_function' actual_input')]
+ (check' assumptions (#.Apply expected) (#.Apply [actual_input actual_function''])))
+
+ (^or [(#.Ex _) _] [_ (#.Ex _)])
+ (do ..monad
+ [assumptions (check' assumptions expected_function actual_function)]
+ (check' assumptions expected_input actual_input))
+
+ [(#.Var id) _]
+ (function (_ context)
+ (case ((do ..monad
+ [expected_function' (..read! id)]
+ (check' assumptions (#.Apply expected_input expected_function') (#.Apply actual)))
+ context)
+ (#try.Success output)
+ (#try.Success output)
+
+ (#try.Failure _)
+ (case actual_function
+ (#.UnivQ _ _)
+ ((do ..monad
+ [actual' (apply_type! actual_function actual_input)]
+ (check' assumptions (#.Apply expected) actual'))
+ context)
+
+ (#.Ex exA)
+ ((do ..monad
+ [assumptions (check' assumptions expected_function actual_function)]
+ (check' assumptions expected_input actual_input))
+ context)
+
+ _
+ ((do ..monad
+ [assumptions (check' assumptions expected_function actual_function)
+ expected' (apply_type! actual_function expected_input)
+ actual' (apply_type! actual_function actual_input)]
+ (check' assumptions expected' actual'))
+ context))))
+
+ [_ (#.Var id)]
+ (function (_ context)
+ (case ((do ..monad
+ [actual_function' (read! id)]
+ (check' assumptions (#.Apply expected) (#.Apply actual_input actual_function')))
+ context)
+ (#try.Success output)
+ (#try.Success output)
+
+ _
+ ((do ..monad
+ [assumptions (check' assumptions expected_function actual_function)
+ expected' (apply_type! expected_function expected_input)
+ actual' (apply_type! expected_function actual_input)]
+ (check' assumptions expected' actual'))
+ context)))
+
+ _
+ ..silent_failure!)))
+
+(def: (with exception parameter check)
+ (All [e a] (-> (Exception e) e (Check a) (Check a)))
+ (|>> check (exception.with exception parameter)))
+
+## TODO: "check'" can be optimized...
+(def: (check' assumptions expected actual)
+ {#.doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."}
+ (Checker Type)
+ (if (for {@.php false} ## TODO: Remove this once JPHP is gone.
+ (is? expected actual))
+ (check\wrap assumptions)
+ (with ..type_check_failed [expected actual]
+ (case [expected actual]
+ [(#.Var idE) (#.Var idA)]
+ (check_vars check' assumptions idE idA)
+
+ [(#.Var id) _]
+ (if_bind id actual
+ (check\wrap assumptions)
+ (function (_ bound)
+ (check' assumptions bound actual)))
+
+ [_ (#.Var id)]
+ (if_bind id expected
+ (check\wrap assumptions)
+ (function (_ bound)
+ (check' assumptions expected bound)))
+
+ (^template [<fE> <fA>]
+ [[(#.Apply aE <fE>) (#.Apply aA <fA>)]
+ (check_apply check' assumptions [aE <fE>] [aA <fA>])])
+ ([F1 (#.Ex ex)]
+ [(#.Ex exE) fA]
+ [fE (#.Var idA)]
+ [(#.Var idE) fA])
+
+ [(#.Apply A F) _]
+ (let [new_assumption [expected actual]]
+ (if (assumed? new_assumption assumptions)
+ (check\wrap assumptions)
+ (do ..monad
+ [expected' (apply_type! F A)]
+ (check' (assume! new_assumption assumptions) expected' actual))))
+
+ [_ (#.Apply A F)]
+ (do ..monad
+ [actual' (apply_type! F A)]
+ (check' assumptions expected actual'))
+
+ ## TODO: Refactor-away as cold-code
+ (^template [<tag> <instancer>]
+ [[(<tag> _) _]
+ (do ..monad
+ [[_ paramT] <instancer>
+ expected' (apply_type! expected paramT)]
+ (check' assumptions expected' actual))])
+ ([#.UnivQ ..existential]
+ [#.ExQ ..var])
+
+ ## TODO: Refactor-away as cold-code
+ (^template [<tag> <instancer>]
+ [[_ (<tag> _)]
+ (do ..monad
+ [[_ paramT] <instancer>
+ actual' (apply_type! actual paramT)]
+ (check' assumptions expected actual'))])
+ ([#.UnivQ ..var]
+ [#.ExQ ..existential])
+
+ [(#.Primitive e_name e_params) (#.Primitive a_name a_params)]
+ (if (!text\= e_name a_name)
+ (loop [assumptions assumptions
+ e_params e_params
+ a_params a_params]
+ (case [e_params a_params]
+ [#.Nil #.Nil]
+ (check\wrap assumptions)
+
+ [(#.Cons e_head e_tail) (#.Cons a_head a_tail)]
+ (do ..monad
+ [assumptions' (check' assumptions e_head a_head)]
+ (recur assumptions' e_tail a_tail))
+
+ _
+ ..silent_failure!))
+ ..silent_failure!)
+
+ (^template [<compose>]
+ [[(<compose> eL eR) (<compose> aL aR)]
+ (do ..monad
+ [assumptions (check' assumptions eL aL)]
+ (check' assumptions eR aR))])
+ ([#.Sum]
+ [#.Product])
+
+ [(#.Function eI eO) (#.Function aI aO)]
+ (do ..monad
+ [assumptions (check' assumptions aI eI)]
+ (check' assumptions eO aO))
+
+ [(#.Ex e!id) (#.Ex a!id)]
+ (if (!n\= e!id a!id)
+ (check\wrap assumptions)
+ ..silent_failure!)
+
+ [(#.Named _ ?etype) _]
+ (check' assumptions ?etype actual)
+
+ [_ (#.Named _ ?atype)]
+ (check' assumptions expected ?atype)
+
+ _
+ ..silent_failure!))))
+
+(def: #export (check expected actual)
+ {#.doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."}
+ (-> Type Type (Check Any))
+ (check' (list) expected actual))
+
+(def: #export (checks? expected actual)
+ {#.doc "A simple type-checking function that just returns a yes/no answer."}
+ (-> Type Type Bit)
+ (case (..run ..fresh_context (..check' (list) expected actual))
+ (#try.Failure _)
+ false
+
+ (#try.Success _)
+ true))
+
+(def: #export context
+ (Check Type_Context)
+ (function (_ context)
+ (#try.Success [context context])))
+
+(def: #export (clean inputT)
+ (-> Type (Check Type))
+ (case inputT
+ (#.Primitive name paramsT+)
+ (|> paramsT+
+ (monad.map ..monad clean)
+ (check\map (|>> (#.Primitive name))))
+
+ (^or (#.Parameter _) (#.Ex _) (#.Named _))
+ (check\wrap inputT)
+
+ (^template [<tag>]
+ [(<tag> leftT rightT)
+ (do ..monad
+ [leftT' (clean leftT)]
+ (|> (clean rightT)
+ (check\map (|>> (<tag> leftT')))))])
+ ([#.Sum] [#.Product] [#.Function] [#.Apply])
+
+ (#.Var id)
+ (do ..monad
+ [?actualT (read id)]
+ (case ?actualT
+ (#.Some actualT)
+ (clean actualT)
+
+ _
+ (wrap inputT)))
+
+ (^template [<tag>]
+ [(<tag> envT+ unquantifiedT)
+ (do {! ..monad}
+ [envT+' (monad.map ! clean envT+)]
+ (wrap (<tag> envT+' unquantifiedT)))])
+ ([#.UnivQ] [#.ExQ])
+ ))
diff --git a/stdlib/source/library/lux/type/dynamic.lux b/stdlib/source/library/lux/type/dynamic.lux
new file mode 100644
index 000000000..b5a6e7fc0
--- /dev/null
+++ b/stdlib/source/library/lux/type/dynamic.lux
@@ -0,0 +1,51 @@
+(.module:
+ [library
+ [lux #*
+ ["." debug]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ [text
+ ["%" format]]]
+ [macro (#+ with_gensyms)
+ ["." syntax (#+ syntax:)]]
+ ["." type
+ abstract]]])
+
+(exception: #export (wrong_type {expected Type} {actual Type})
+ (exception.report
+ ["Expected" (%.type expected)]
+ ["Actual" (%.type actual)]))
+
+(abstract: #export Dynamic
+ [Type Any]
+
+ {#.doc "A value coupled with its type, so it can be checked later."}
+
+ (def: abstraction (-> [Type Any] Dynamic) (|>> :abstraction))
+ (def: representation (-> Dynamic [Type Any]) (|>> :representation))
+
+ (syntax: #export (:dynamic value)
+ {#.doc (doc (: Dynamic
+ (:dynamic 123)))}
+ (with_gensyms [g!value]
+ (wrap (list (` (let [(~ g!value) (~ value)]
+ ((~! ..abstraction) [(:of (~ g!value)) (~ g!value)])))))))
+
+ (syntax: #export (:check type value)
+ {#.doc (doc (: (try.Try Nat)
+ (:check Nat (:dynamic 123))))}
+ (with_gensyms [g!type g!value]
+ (wrap (list (` (let [[(~ g!type) (~ g!value)] ((~! ..representation) (~ value))]
+ (: ((~! try.Try) (~ type))
+ (if (\ (~! type.equivalence) (~' =)
+ (.type (~ type)) (~ g!type))
+ (#try.Success (:as (~ type) (~ g!value)))
+ ((~! exception.throw) ..wrong_type [(.type (~ type)) (~ g!type)])))))))))
+
+ (def: #export (format value)
+ (-> Dynamic (Try Text))
+ (let [[type value] (:representation value)]
+ (debug.represent type value)))
+ )
diff --git a/stdlib/source/library/lux/type/implicit.lux b/stdlib/source/library/lux/type/implicit.lux
new file mode 100644
index 000000000..a308b99a8
--- /dev/null
+++ b/stdlib/source/library/lux/type/implicit.lux
@@ -0,0 +1,401 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ Monad do)]
+ ["eq" equivalence]]
+ [control
+ ["." try]
+ ["p" parser
+ ["s" code (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." monad fold)]
+ ["." dictionary (#+ Dictionary)]]]
+ ["." macro
+ ["." code]
+ [syntax (#+ syntax:)]]
+ [math
+ ["." number
+ ["n" nat]]]
+ ["." meta
+ ["." annotation]]
+ ["." type
+ ["." check (#+ Check)]]]])
+
+(def: (find_type_var id env)
+ (-> Nat Type_Context (Meta Type))
+ (case (list.find (|>> product.left (n.= id))
+ (get@ #.var_bindings env))
+ (#.Some [_ (#.Some type)])
+ (case type
+ (#.Var id')
+ (find_type_var id' env)
+
+ _
+ (\ meta.monad wrap type))
+
+ (#.Some [_ #.None])
+ (meta.fail (format "Unbound type-var " (%.nat id)))
+
+ #.None
+ (meta.fail (format "Unknown type-var " (%.nat id)))
+ ))
+
+(def: (resolve_type var_name)
+ (-> Name (Meta Type))
+ (do meta.monad
+ [raw_type (meta.find_type var_name)
+ compiler meta.get_compiler]
+ (case raw_type
+ (#.Var id)
+ (find_type_var id (get@ #.type_context compiler))
+
+ _
+ (wrap raw_type))))
+
+(def: (find_member_type idx sig_type)
+ (-> Nat Type (Check Type))
+ (case sig_type
+ (#.Named _ sig_type')
+ (find_member_type idx sig_type')
+
+ (#.Apply arg func)
+ (case (type.apply (list arg) func)
+ #.None
+ (check.fail (format "Cannot apply type " (%.type func) " to type " (%.type arg)))
+
+ (#.Some sig_type')
+ (find_member_type idx sig_type'))
+
+ (#.Product left right)
+ (if (n.= 0 idx)
+ (\ check.monad wrap left)
+ (find_member_type (dec idx) right))
+
+ _
+ (if (n.= 0 idx)
+ (\ check.monad wrap sig_type)
+ (check.fail (format "Cannot find member type " (%.nat idx) " for " (%.type sig_type))))))
+
+(def: (find_member_name member)
+ (-> Name (Meta Name))
+ (case member
+ ["" simple_name]
+ (meta.either (do meta.monad
+ [member (meta.normalize member)
+ _ (meta.resolve_tag member)]
+ (wrap member))
+ (do {! meta.monad}
+ [this_module_name meta.current_module_name
+ imp_mods (meta.imported_modules this_module_name)
+ tag_lists (monad.map ! meta.tag_lists imp_mods)
+ #let [tag_lists (|> tag_lists list\join (list\map product.left) list\join)
+ candidates (list.filter (|>> product.right (text\= simple_name))
+ tag_lists)]]
+ (case candidates
+ #.Nil
+ (meta.fail (format "Unknown tag: " (%.name member)))
+
+ (#.Cons winner #.Nil)
+ (wrap winner)
+
+ _
+ (meta.fail (format "Too many candidate tags: " (%.list %.name candidates))))))
+
+ _
+ (\ meta.monad wrap member)))
+
+(def: (resolve_member member)
+ (-> Name (Meta [Nat Type]))
+ (do meta.monad
+ [member (find_member_name member)
+ [idx tag_list sig_type] (meta.resolve_tag member)]
+ (wrap [idx sig_type])))
+
+(def: (prepare_definitions source_module target_module constants aggregate)
+ (-> Text Text (List [Text Definition]) (-> (List [Name Type]) (List [Name Type])))
+ (list\fold (function (_ [name [exported? def_type def_anns def_value]] aggregate)
+ (if (and (annotation.implementation? def_anns)
+ (or (text\= target_module source_module)
+ exported?))
+ (#.Cons [[source_module name] def_type] aggregate)
+ aggregate))
+ aggregate
+ constants))
+
+(def: local_env
+ (Meta (List [Name Type]))
+ (do meta.monad
+ [local_batches meta.locals
+ #let [total_locals (list\fold (function (_ [name type] table)
+ (try.default table (dictionary.try_put name type table)))
+ (: (Dictionary Text Type)
+ (dictionary.new text.hash))
+ (list\join local_batches))]]
+ (wrap (|> total_locals
+ dictionary.entries
+ (list\map (function (_ [name type]) [["" name] type]))))))
+
+(def: local_structs
+ (Meta (List [Name Type]))
+ (do {! meta.monad}
+ [this_module_name meta.current_module_name
+ definitions (meta.definitions this_module_name)]
+ (wrap (prepare_definitions this_module_name this_module_name definitions #.Nil))))
+
+(def: imported_structs
+ (Meta (List [Name Type]))
+ (do {! meta.monad}
+ [this_module_name meta.current_module_name
+ imported_modules (meta.imported_modules this_module_name)
+ accessible_definitions (monad.map ! meta.definitions imported_modules)]
+ (wrap (list\fold (function (_ [imported_module definitions] tail)
+ (prepare_definitions imported_module this_module_name definitions tail))
+ #.Nil
+ (list.zip/2 imported_modules accessible_definitions)))))
+
+(def: (apply_function_type func arg)
+ (-> Type Type (Check Type))
+ (case func
+ (#.Named _ func')
+ (apply_function_type func' arg)
+
+ (#.UnivQ _)
+ (do check.monad
+ [[id var] check.var]
+ (apply_function_type (maybe.assume (type.apply (list var) func))
+ arg))
+
+ (#.Function input output)
+ (do check.monad
+ [_ (check.check input arg)]
+ (wrap output))
+
+ _
+ (check.fail (format "Invalid function type: " (%.type func)))))
+
+(def: (concrete_type type)
+ (-> Type (Check [(List Nat) Type]))
+ (case type
+ (#.UnivQ _)
+ (do check.monad
+ [[id var] check.var
+ [ids final_output] (concrete_type (maybe.assume (type.apply (list var) type)))]
+ (wrap [(#.Cons id ids)
+ final_output]))
+
+ _
+ (\ check.monad wrap [(list) type])))
+
+(def: (check_apply member_type input_types output_type)
+ (-> Type (List Type) Type (Check []))
+ (do check.monad
+ [member_type' (monad.fold check.monad
+ (function (_ input member)
+ (apply_function_type member input))
+ member_type
+ input_types)]
+ (check.check output_type member_type')))
+
+(type: #rec Instance
+ {#constructor Name
+ #dependencies (List Instance)})
+
+(def: (test_provision provision context dep alts)
+ (-> (-> Lux Type_Context Type (Check Instance))
+ Type_Context Type (List [Name Type])
+ (Meta (List Instance)))
+ (do meta.monad
+ [compiler meta.get_compiler]
+ (case (|> alts
+ (list\map (function (_ [alt_name alt_type])
+ (case (check.run context
+ (do {! check.monad}
+ [[tvars alt_type] (concrete_type alt_type)
+ #let [[deps alt_type] (type.flatten_function alt_type)]
+ _ (check.check dep alt_type)
+ context' check.context
+ =deps (monad.map ! (provision compiler context') deps)]
+ (wrap =deps)))
+ (#.Left error)
+ (list)
+
+ (#.Right =deps)
+ (list [alt_name =deps]))))
+ list\join)
+ #.Nil
+ (meta.fail (format "No candidates for provisioning: " (%.type dep)))
+
+ found
+ (wrap found))))
+
+(def: (provision compiler context dep)
+ (-> Lux Type_Context Type (Check Instance))
+ (case (meta.run compiler
+ ($_ meta.either
+ (do meta.monad [alts ..local_env] (..test_provision provision context dep alts))
+ (do meta.monad [alts ..local_structs] (..test_provision provision context dep alts))
+ (do meta.monad [alts ..imported_structs] (..test_provision provision context dep alts))))
+ (#.Left error)
+ (check.fail error)
+
+ (#.Right candidates)
+ (case candidates
+ #.Nil
+ (check.fail (format "No candidates for provisioning: " (%.type dep)))
+
+ (#.Cons winner #.Nil)
+ (\ check.monad wrap winner)
+
+ _
+ (check.fail (format "Too many candidates for provisioning: " (%.type dep) " --- " (%.list (|>> product.left %.name) candidates))))
+ ))
+
+(def: (test_alternatives sig_type member_idx input_types output_type alts)
+ (-> Type Nat (List Type) Type (List [Name Type]) (Meta (List Instance)))
+ (do meta.monad
+ [compiler meta.get_compiler
+ context meta.type_context]
+ (case (|> alts
+ (list\map (function (_ [alt_name alt_type])
+ (case (check.run context
+ (do {! check.monad}
+ [[tvars alt_type] (concrete_type alt_type)
+ #let [[deps alt_type] (type.flatten_function alt_type)]
+ _ (check.check alt_type sig_type)
+ member_type (find_member_type member_idx alt_type)
+ _ (check_apply member_type input_types output_type)
+ context' check.context
+ =deps (monad.map ! (provision compiler context') deps)]
+ (wrap =deps)))
+ (#.Left error)
+ (list)
+
+ (#.Right =deps)
+ (list [alt_name =deps]))))
+ list\join)
+ #.Nil
+ (meta.fail (format "No alternatives for " (%.type (type.function input_types output_type))))
+
+ found
+ (wrap found))))
+
+(def: (find_alternatives sig_type member_idx input_types output_type)
+ (-> Type Nat (List Type) Type (Meta (List Instance)))
+ (let [test (test_alternatives sig_type member_idx input_types output_type)]
+ ($_ meta.either
+ (do meta.monad [alts ..local_env] (test alts))
+ (do meta.monad [alts ..local_structs] (test alts))
+ (do meta.monad [alts ..imported_structs] (test alts)))))
+
+(def: (var? input)
+ (-> Code Bit)
+ (case input
+ [_ (#.Identifier _)]
+ #1
+
+ _
+ #0))
+
+(def: (join_pair [l r])
+ (All [a] (-> [a a] (List a)))
+ (list l r))
+
+(def: (instance$ [constructor dependencies])
+ (-> Instance Code)
+ (case dependencies
+ #.Nil
+ (code.identifier constructor)
+
+ _
+ (` ((~ (code.identifier constructor)) (~+ (list\map instance$ dependencies))))))
+
+(syntax: #export (\\
+ {member s.identifier}
+ {args (p.or (p.and (p.some s.identifier) s.end!)
+ (p.and (p.some s.any) s.end!))})
+ {#.doc (doc "Automatic implementation selection (for type-class style polymorphism)."
+ "This feature layers type-class style polymorphism on top of Lux's signatures and implementations."
+ "When calling a polymorphic function, or using a polymorphic constant,"
+ "this macro will check the types of the arguments, and the expected type for the whole expression"
+ "and it will search in the local scope, the module's scope and the imports' scope"
+ "in order to find suitable implementations to satisfy those requirements."
+ "If a single alternative is found, that one will be used automatically."
+ "If no alternative is found, or if more than one alternative is found (ambiguity)"
+ "a compile-time error will be raised, to alert the user."
+ "Examples:"
+ "Nat equivalence"
+ (\ number.equivalence = x y)
+ (\\ = x y)
+ "Can optionally add the prefix of the module where the signature was defined."
+ (\\ eq.= x y)
+ "(List Nat) equivalence"
+ (\\ =
+ (list.indices 10)
+ (list.indices 10))
+ "(Functor List) map"
+ (\\ map inc (list.indices 10))
+ "Caveat emptor: You need to make sure to import the module of any implementation you want to use."
+ "Otherwise, this macro will not find it.")}
+ (case args
+ (#.Left [args _])
+ (do {! meta.monad}
+ [[member_idx sig_type] (resolve_member member)
+ input_types (monad.map ! resolve_type args)
+ output_type meta.expected_type
+ chosen_ones (find_alternatives sig_type member_idx input_types output_type)]
+ (case chosen_ones
+ #.Nil
+ (meta.fail (format "No implementation could be found for member: " (%.name member)))
+
+ (#.Cons chosen #.Nil)
+ (wrap (list (` (\ (~ (instance$ chosen))
+ (~ (code.local_identifier (product.right member)))
+ (~+ (list\map code.identifier args))))))
+
+ _
+ (meta.fail (format "Too many implementations available: "
+ (|> chosen_ones
+ (list\map (|>> product.left %.name))
+ (text.join_with ", "))
+ " --- for type: " (%.type sig_type)))))
+
+ (#.Right [args _])
+ (do {! meta.monad}
+ [labels (|> (macro.gensym "") (list.repeat (list.size args)) (monad.seq !))]
+ (wrap (list (` (let [(~+ (|> (list.zip/2 labels args) (list\map join_pair) list\join))]
+ (..\\ (~ (code.identifier member)) (~+ labels)))))))
+ ))
+
+(def: (implicit_bindings amount)
+ (-> Nat (Meta (List Code)))
+ (|> (macro.gensym "g!implicit")
+ (list.repeat amount)
+ (monad.seq meta.monad)))
+
+(def: implicits
+ (Parser (List Code))
+ (s.tuple (p.many s.any)))
+
+(syntax: #export (with {implementations ..implicits} body)
+ (do meta.monad
+ [g!implicit+ (implicit_bindings (list.size implementations))]
+ (wrap (list (` (let [(~+ (|> (list.zip/2 g!implicit+ implementations)
+ (list\map (function (_ [g!implicit implementation])
+ (list g!implicit implementation)))
+ list\join))]
+ (~ body)))))))
+
+(syntax: #export (implicit: {implementations ..implicits})
+ (do meta.monad
+ [g!implicit+ (implicit_bindings (list.size implementations))]
+ (wrap (|> (list.zip/2 g!implicit+ implementations)
+ (list\map (function (_ [g!implicit implementation])
+ (` (def: (~ g!implicit)
+ {#.implementation? #1}
+ (~ implementation)))))))))
diff --git a/stdlib/source/library/lux/type/quotient.lux b/stdlib/source/library/lux/type/quotient.lux
new file mode 100644
index 000000000..b872e6ff1
--- /dev/null
+++ b/stdlib/source/library/lux/type/quotient.lux
@@ -0,0 +1,56 @@
+(.module:
+ [library
+ [lux (#- type)
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [macro (#+ with_gensyms)
+ [syntax (#+ syntax:)]]
+ ["." type
+ abstract]]])
+
+(abstract: #export (Class t c %)
+ (-> t c)
+
+ (def: #export class
+ (All [t c]
+ (Ex [%]
+ (-> (-> t c) (Class t c %))))
+ (|>> :abstraction))
+
+ (abstract: #export (Quotient t c %)
+ {#value t
+ #label c}
+
+ (def: #export (quotient class value)
+ (All [t c %]
+ (-> (Class t c %) t
+ (Quotient t c %)))
+ (:abstraction {#value value
+ #label ((:representation Class class) value)}))
+
+ (template [<name> <output> <slot>]
+ [(def: #export <name>
+ (All [t c %] (-> (Quotient t c %) <output>))
+ (|>> :representation (get@ <slot>)))]
+
+ [value t #value]
+ [label c #label]
+ )
+ )
+ )
+
+(syntax: #export (type class)
+ (with_gensyms [g!t g!c g!%]
+ (wrap (list (` ((~! type.:by_example)
+ [(~ g!t) (~ g!c) (~ g!%)]
+
+ (..Class (~ g!t) (~ g!c) (~ g!%))
+ (~ class)
+
+ (..Quotient (~ g!t) (~ g!c) (~ g!%))))))))
+
+(implementation: #export (equivalence super)
+ (All [t c %] (-> (Equivalence c) (Equivalence (..Quotient t c %))))
+
+ (def: (= reference sample)
+ (\ super = (..label reference) (..label sample))))
diff --git a/stdlib/source/library/lux/type/refinement.lux b/stdlib/source/library/lux/type/refinement.lux
new file mode 100644
index 000000000..a3e49104d
--- /dev/null
+++ b/stdlib/source/library/lux/type/refinement.lux
@@ -0,0 +1,89 @@
+(.module:
+ [library
+ [lux (#- type)
+ [abstract
+ [predicate (#+ Predicate)]]
+ ["." macro
+ [syntax (#+ syntax:)]]
+ ["." type
+ abstract]]])
+
+(abstract: #export (Refined t %)
+ {#value t
+ #predicate (Predicate t)}
+
+ {#.doc "A refined type '%' of base type 't' using a predicate."}
+
+ (type: #export (Refiner t %)
+ (-> t (Maybe (Refined t %))))
+
+ (def: #export (refinement predicate)
+ (All [t]
+ (Ex [%]
+ (-> (Predicate t) (Refiner t %))))
+ (function (_ un_refined)
+ (if (predicate un_refined)
+ (#.Some (:abstraction {#value un_refined
+ #predicate predicate}))
+ #.None)))
+
+ (template [<name> <output> <slot>]
+ [(def: #export <name>
+ (All [t %] (-> (Refined t %) <output>))
+ (|>> :representation (get@ <slot>)))]
+
+ [un_refine t #value]
+ [predicate (Predicate t) #predicate]
+ )
+
+ (def: #export (lift transform)
+ (All [t %]
+ (-> (-> t t)
+ (-> (Refined t %) (Maybe (Refined t %)))))
+ (function (_ refined)
+ (let [(^slots [#value #predicate]) (:representation refined)
+ value' (transform value)]
+ (if (predicate value')
+ (#.Some (:abstraction {#value value'
+ #predicate predicate}))
+ #.None))))
+ )
+
+(def: #export (filter refiner values)
+ (All [t %] (-> (Refiner t %) (List t) (List (Refined t %))))
+ (case values
+ #.Nil
+ #.Nil
+
+ (#.Cons head tail)
+ (case (refiner head)
+ (#.Some refined)
+ (#.Cons refined (filter refiner tail))
+
+ #.None
+ (filter refiner tail))))
+
+(def: #export (partition refiner values)
+ (All [t %] (-> (Refiner t %) (List t) [(List (Refined t %)) (List t)]))
+ (case values
+ #.Nil
+ [#.Nil #.Nil]
+
+ (#.Cons head tail)
+ (let [[yes no] (partition refiner tail)]
+ (case (refiner head)
+ (#.Some refined)
+ [(#.Cons refined yes)
+ no]
+
+ #.None
+ [yes
+ (#.Cons head no)]))))
+
+(syntax: #export (type refiner)
+ (macro.with_gensyms [g!t g!%]
+ (wrap (list (` ((~! type.:by_example) [(~ g!t) (~ g!%)]
+ (..Refiner (~ g!t) (~ g!%))
+ (~ refiner)
+
+ (..Refined (~ g!t) (~ g!%))))))))
diff --git a/stdlib/source/library/lux/type/resource.lux b/stdlib/source/library/lux/type/resource.lux
new file mode 100644
index 000000000..5a2b79c1d
--- /dev/null
+++ b/stdlib/source/library/lux/type/resource.lux
@@ -0,0 +1,218 @@
+(.module:
+ [library
+ [lux #*
+ ["." meta]
+ [abstract
+ ["." monad (#+ Monad do)
+ [indexed (#+ IxMonad)]]]
+ [control
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO)]
+ [concurrency
+ ["." promise (#+ Promise)]]
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." identity (#+ Identity)]
+ ["." maybe]
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." set]
+ ["." row (#+ Row)]
+ ["." list ("#\." functor fold)]]]
+ ["." macro
+ [syntax (#+ syntax:)]]
+ [math
+ [number
+ ["n" nat]]]
+ [type
+ abstract]]])
+
+(type: #export (Procedure monad input output value)
+ (-> input (monad [output value])))
+
+(type: #export (Linear monad value)
+ (All [keys]
+ (Procedure monad keys keys value)))
+
+(type: #export (Affine monad permissions value)
+ (All [keys]
+ (Procedure monad keys [permissions keys] value)))
+
+(type: #export (Relevant monad permissions value)
+ (All [keys]
+ (Procedure monad [permissions keys] keys value)))
+
+(implementation: (indexed Monad<m>)
+ (All [m] (-> (Monad m) (IxMonad (Procedure m))))
+
+ (def: (wrap value)
+ (function (_ keys)
+ (\ Monad<m> wrap [keys value])))
+
+ (def: (bind f input)
+ (function (_ keysI)
+ (do Monad<m>
+ [[keysT value] (input keysI)]
+ ((f value) keysT)))))
+
+(template [<name> <m> <monad> <execute> <lift>]
+ [(def: #export <name>
+ (IxMonad (Procedure <m>))
+ (..indexed <monad>))
+
+ (def: #export (<execute> procedure)
+ (All [v] (-> (Linear <m> v) (<m> v)))
+ (do <monad>
+ [[_ output] (procedure [])]
+ (wrap output)))
+
+ (def: #export (<lift> procedure)
+ (All [v] (-> (<m> v) (Linear <m> v)))
+ (function (_ keys)
+ (do <monad>
+ [output procedure]
+ (wrap [keys output]))))]
+
+ [pure Identity identity.monad run_pure lift_pure]
+ [sync IO io.monad run_sync lift_sync]
+ [async Promise promise.monad run_async lift_async]
+ )
+
+(abstract: #export Ordered Any)
+
+(abstract: #export Commutative Any)
+
+(abstract: #export (Key mode key)
+ Any
+
+ (template [<name> <mode>]
+ [(def: <name>
+ (Ex [k] (-> Any (Key <mode> k)))
+ (|>> :abstraction))]
+
+ [ordered_key Ordered]
+ [commutative_key Commutative]
+ ))
+
+(abstract: #export (Res key value)
+ value
+
+ {#.doc "A value locked by a key."}
+
+ (template [<name> <m> <monad> <mode> <key>]
+ [(def: #export (<name> value)
+ (All [v] (Ex [k] (-> v (Affine <m> (Key <mode> k) (Res k v)))))
+ (function (_ keys)
+ (\ <monad> wrap [[(<key> []) keys] (:abstraction value)])))]
+
+ [ordered_pure Identity identity.monad Ordered ordered_key]
+ [ordered_sync IO io.monad Ordered ordered_key]
+ [ordered_async Promise promise.monad Ordered ordered_key]
+ [commutative_sync IO io.monad Commutative commutative_key]
+ [commutative_pure Identity identity.monad Commutative commutative_key]
+ [commutative_async Promise promise.monad Commutative commutative_key]
+ )
+
+ (template [<name> <m> <monad>]
+ [(def: #export (<name> resource)
+ (All [v k m]
+ (-> (Res k v) (Relevant <m> (Key m k) v)))
+ (function (_ [key keys])
+ (\ <monad> wrap [keys (:representation resource)])))]
+
+ [read_pure Identity identity.monad]
+ [read_sync IO io.monad]
+ [read_async Promise promise.monad]
+ ))
+
+(exception: #export (index_cannot_be_repeated {index Nat})
+ (exception.report
+ ["Index" (%.nat index)]))
+
+(exception: #export amount_cannot_be_zero)
+
+(def: indices
+ (Parser (List Nat))
+ (<code>.tuple (loop [seen (set.new n.hash)]
+ (do {! <>.monad}
+ [done? <code>.end?]
+ (if done?
+ (wrap (list))
+ (do !
+ [head <code>.nat
+ _ (<>.assert (exception.construct ..index_cannot_be_repeated head)
+ (not (set.member? seen head)))
+ tail (recur (set.add head seen))]
+ (wrap (list& head tail))))))))
+
+(def: (no_op Monad<m>)
+ (All [m] (-> (Monad m) (Linear m Any)))
+ (function (_ context)
+ (\ Monad<m> wrap [context []])))
+
+(template [<name> <m> <monad>]
+ [(syntax: #export (<name> {swaps ..indices})
+ (macro.with_gensyms [g!_ g!context]
+ (case swaps
+ #.Nil
+ (wrap (list (` ((~! no_op) <monad>))))
+
+ (#.Cons head tail)
+ (do {! meta.monad}
+ [#let [max_idx (list\fold n.max head tail)]
+ g!inputs (<| (monad.seq !) (list.repeat (inc max_idx)) (macro.gensym "input"))
+ #let [g!outputs (|> (monad.fold maybe.monad
+ (function (_ from to)
+ (do maybe.monad
+ [input (list.nth from g!inputs)]
+ (wrap (row.add input to))))
+ (: (Row Code) row.empty)
+ swaps)
+ maybe.assume
+ row.to_list)
+ g!inputsT+ (list\map (|>> (~) (..Key ..Commutative) (`)) g!inputs)
+ g!outputsT+ (list\map (|>> (~) (..Key ..Commutative) (`)) g!outputs)]]
+ (wrap (list (` (: (All [(~+ g!inputs) (~ g!context)]
+ (Procedure (~! <m>)
+ [(~+ g!inputsT+) (~ g!context)]
+ [(~+ g!outputsT+) (~ g!context)]
+ .Any))
+ (function ((~ g!_) [(~+ g!inputs) (~ g!context)])
+ (\ (~! <monad>) (~' wrap) [[(~+ g!outputs) (~ g!context)] []]))))))))))]
+
+ [exchange_pure Identity identity.monad]
+ [exchange_sync IO io.monad]
+ [exchange_async Promise promise.monad]
+ )
+
+(def: amount
+ (Parser Nat)
+ (do <>.monad
+ [raw <code>.nat
+ _ (<>.assert (exception.construct ..amount_cannot_be_zero [])
+ (n.> 0 raw))]
+ (wrap raw)))
+
+(template [<name> <m> <monad> <from> <to>]
+ [(syntax: #export (<name> {amount ..amount})
+ (macro.with_gensyms [g!_ g!context]
+ (do {! meta.monad}
+ [g!keys (<| (monad.seq !) (list.repeat amount) (macro.gensym "keys"))]
+ (wrap (list (` (: (All [(~+ g!keys) (~ g!context)]
+ (Procedure (~! <m>)
+ [<from> (~ g!context)]
+ [<to> (~ g!context)]
+ .Any))
+ (function ((~ g!_) [<from> (~ g!context)])
+ (\ (~! <monad>) (~' wrap) [[<to> (~ g!context)] []])))))))))]
+
+ [group_pure Identity identity.monad (~+ g!keys) [(~+ g!keys)]]
+ [group_sync IO io.monad (~+ g!keys) [(~+ g!keys)]]
+ [group_async Promise promise.monad (~+ g!keys) [(~+ g!keys)]]
+ [un_group_pure Identity identity.monad [(~+ g!keys)] (~+ g!keys)]
+ [un_group_sync IO io.monad [(~+ g!keys)] (~+ g!keys)]
+ [un_group_async Promise promise.monad [(~+ g!keys)] (~+ g!keys)]
+ )
diff --git a/stdlib/source/library/lux/type/unit.lux b/stdlib/source/library/lux/type/unit.lux
new file mode 100644
index 000000000..ccdb34d46
--- /dev/null
+++ b/stdlib/source/library/lux/type/unit.lux
@@ -0,0 +1,188 @@
+(.module:
+ [library
+ [lux #*
+ ["." meta]
+ [abstract
+ [monad (#+ Monad do)]
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]
+ [enum (#+ Enum)]]
+ [control
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ [text
+ ["%" format (#+ format)]]]
+ [macro
+ ["." code]
+ [syntax (#+ syntax:)
+ ["|.|" export]
+ ["|.|" annotations]]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]
+ ["." ratio (#+ Ratio)]]]
+ [type
+ abstract]]])
+
+(abstract: #export (Qty unit)
+ Int
+
+ (def: in
+ (All [unit] (-> Int (Qty unit)))
+ (|>> :abstraction))
+
+ (def: out
+ (All [unit] (-> (Qty unit) Int))
+ (|>> :representation))
+
+ (template [<name> <op>]
+ [(def: #export (<name> param subject)
+ (All [unit] (-> (Qty unit) (Qty unit) (Qty unit)))
+ (:abstraction (<op> (:representation param)
+ (:representation subject))))]
+
+ [+ i.+]
+ [- i.-]
+ )
+
+ (template [<name> <op> <p> <s> <p*s>]
+ [(def: #export (<name> param subject)
+ (All [p s] (-> (Qty <p>) (Qty <s>) (Qty <p*s>)))
+ (:abstraction (<op> (:representation param)
+ (:representation subject))))]
+
+ [* i.* p s [p s]]
+ [/ i./ p [p s] s]
+ )
+ )
+
+(interface: #export (Unit a)
+ (: (-> Int (Qty a))
+ in)
+ (: (-> (Qty a) Int)
+ out))
+
+(interface: #export (Scale s)
+ (: (All [u] (-> (Qty u) (Qty (s u))))
+ scale)
+ (: (All [u] (-> (Qty (s u)) (Qty u)))
+ de_scale)
+ (: Ratio
+ ratio))
+
+(type: #export Pure
+ (Qty Any))
+
+(def: #export pure
+ (-> Int Pure)
+ ..in)
+
+(def: #export number
+ (-> Pure Int)
+ ..out)
+
+(syntax: #export (unit:
+ {export |export|.parser}
+ {type_name <code>.local_identifier}
+ {unit_name <code>.local_identifier}
+ {annotations (<>.default |annotations|.empty |annotations|.parser)})
+ (do meta.monad
+ [@ meta.current_module_name
+ #let [g!type (code.local_identifier type_name)]]
+ (wrap (list (` (type: (~+ (|export|.format export)) (~ g!type)
+ (~ (|annotations|.format annotations))
+ (primitive (~ (code.text (%.name [@ type_name]))))))
+
+ (` (implementation: (~+ (|export|.format export)) (~ (code.local_identifier unit_name))
+ (..Unit (~ g!type))
+
+ (def: (~' in) (~! ..in))
+ (def: (~' out) (~! ..out))))
+ ))))
+
+(def: scale
+ (Parser Ratio)
+ (<code>.tuple (do <>.monad
+ [numerator <code>.nat
+ _ (<>.assert (format "Numerator must be positive: " (%.nat numerator))
+ (n.> 0 numerator))
+ denominator <code>.nat
+ _ (<>.assert (format "Denominator must be positive: " (%.nat denominator))
+ (n.> 0 denominator))]
+ (wrap [numerator denominator]))))
+
+(syntax: #export (scale:
+ {export |export|.parser}
+ {type_name <code>.local_identifier}
+ {scale_name <code>.local_identifier}
+ {(^slots [#ratio.numerator #ratio.denominator]) ..scale}
+ {annotations (<>.default |annotations|.empty |annotations|.parser)})
+ (do meta.monad
+ [@ meta.current_module_name
+ #let [g!scale (code.local_identifier type_name)]]
+ (wrap (list (` (type: (~+ (|export|.format export)) ((~ g!scale) (~' u))
+ (~ (|annotations|.format annotations))
+ (primitive (~ (code.text (%.name [@ type_name]))) [(~' u)])))
+
+ (` (implementation: (~+ (|export|.format export)) (~ (code.local_identifier scale_name))
+ (..Scale (~ g!scale))
+
+ (def: (~' scale)
+ (|>> ((~! ..out))
+ (i.* (~ (code.int (.int numerator))))
+ (i./ (~ (code.int (.int denominator))))
+ ((~! ..in))))
+ (def: (~' de_scale)
+ (|>> ((~! ..out))
+ (i.* (~ (code.int (.int denominator))))
+ (i./ (~ (code.int (.int numerator))))
+ ((~! ..in))))
+ (def: (~' ratio)
+ [(~ (code.nat numerator)) (~ (code.nat denominator))])))
+ ))))
+
+(def: #export (re_scale from to quantity)
+ (All [si so u] (-> (Scale si) (Scale so) (Qty (si u)) (Qty (so u))))
+ (let [[numerator denominator] (ratio./ (\ from ratio)
+ (\ to ratio))]
+ (|> quantity
+ out
+ (i.* (.int numerator))
+ (i./ (.int denominator))
+ in)))
+
+(scale: #export Kilo kilo [1 1,000])
+(scale: #export Mega mega [1 1,000,000])
+(scale: #export Giga giga [1 1,000,000,000])
+
+(scale: #export Milli milli [ 1,000 1])
+(scale: #export Micro micro [ 1,000,000 1])
+(scale: #export Nano nano [1,000,000,000 1])
+
+(unit: #export Gram gram)
+(unit: #export Meter meter)
+(unit: #export Litre litre)
+(unit: #export Second second)
+
+(implementation: #export equivalence
+ (All [unit] (Equivalence (Qty unit)))
+
+ (def: (= reference sample)
+ (i.= (..out reference) (..out sample))))
+
+(implementation: #export order
+ (All [unit] (Order (Qty unit)))
+
+ (def: &equivalence ..equivalence)
+
+ (def: (< reference sample)
+ (i.< (..out reference) (..out sample))))
+
+(implementation: #export enum
+ (All [unit] (Enum (Qty unit)))
+
+ (def: &order ..order)
+ (def: succ (|>> ..out inc ..in))
+ (def: pred (|>> ..out dec ..in)))
diff --git a/stdlib/source/library/lux/type/variance.lux b/stdlib/source/library/lux/type/variance.lux
new file mode 100644
index 000000000..406717046
--- /dev/null
+++ b/stdlib/source/library/lux/type/variance.lux
@@ -0,0 +1,12 @@
+(.module:
+ [library
+ [lux #*]])
+
+(type: #export (Co t)
+ (-> Any t))
+
+(type: #export (Contra t)
+ (-> t Any))
+
+(type: #export (In t)
+ (-> t t))
diff --git a/stdlib/source/library/lux/world/console.lux b/stdlib/source/library/lux/world/console.lux
new file mode 100644
index 000000000..41652fdd7
--- /dev/null
+++ b/stdlib/source/library/lux/world/console.lux
@@ -0,0 +1,159 @@
+(.module:
+ [library
+ [lux #*
+ [ffi (#+ import:)]
+ ["@" target]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO io)]
+ [concurrency
+ ["." promise (#+ Promise)]
+ ["." atom]]]
+ [data
+ ["." text (#+ Char)
+ ["%" format (#+ format)]]]]])
+
+(template [<name>]
+ [(exception: #export (<name>)
+ "")]
+
+ [cannot_open]
+ [cannot_close]
+ )
+
+(interface: #export (Console !)
+ (: (-> [] (! (Try Char)))
+ read)
+ (: (-> [] (! (Try Text)))
+ read_line)
+ (: (-> Text (! (Try Any)))
+ write)
+ (: (-> [] (! (Try Any)))
+ close))
+
+(def: #export (async console)
+ (-> (Console IO) (Console Promise))
+ (`` (implementation
+ (~~ (template [<capability>]
+ [(def: <capability>
+ (|>> (\ console <capability>) promise.future))]
+
+ [read]
+ [read_line]
+ [write]
+ [close])))))
+
+(with_expansions [<jvm> (as_is (import: java/lang/String)
+
+ (import: java/io/Console
+ ["#::."
+ (readLine [] #io #try java/lang/String)])
+
+ (import: java/io/InputStream
+ ["#::."
+ (read [] #io #try int)])
+
+ (import: java/io/PrintStream
+ ["#::."
+ (print [java/lang/String] #io #try void)])
+
+ (import: java/lang/System
+ ["#::."
+ (#static console [] #io #? java/io/Console)
+ (#static in java/io/InputStream)
+ (#static out java/io/PrintStream)])
+
+ (def: #export default
+ (IO (Try (Console IO)))
+ (do io.monad
+ [?jvm_console (java/lang/System::console)]
+ (case ?jvm_console
+ #.None
+ (wrap (exception.throw ..cannot_open []))
+
+ (#.Some jvm_console)
+ (let [jvm_input (java/lang/System::in)
+ jvm_output (java/lang/System::out)]
+ (<| wrap
+ exception.return
+ (: (Console IO)) ## TODO: Remove ASAP
+ (implementation
+ (def: (read _)
+ (|> jvm_input
+ java/io/InputStream::read
+ (\ (try.with io.monad) map .nat)))
+
+ (def: (read_line _)
+ (java/io/Console::readLine jvm_console))
+
+ (def: (write message)
+ (java/io/PrintStream::print message jvm_output))
+
+ (def: close
+ (|>> (exception.throw ..cannot_close) wrap)))))))))]
+ (for {@.old (as_is <jvm>)
+ @.jvm (as_is <jvm>)}
+ (as_is)))
+
+(def: #export (write_line message console)
+ (All [!] (-> Text (Console !) (! (Try Any))))
+ (\ console write (format message text.new_line)))
+
+(interface: #export (Mock s)
+ (: (-> s (Try [s Char]))
+ on_read)
+ (: (-> s (Try [s Text]))
+ on_read_line)
+ (: (-> Text s (Try s))
+ on_write)
+ (: (-> s (Try s))
+ on_close))
+
+(def: #export (mock mock init)
+ (All [s] (-> (Mock s) s (Console IO)))
+ (let [state (atom.atom init)]
+ (`` (implementation
+ (~~ (template [<method> <mock>]
+ [(def: (<method> _)
+ (do {! io.monad}
+ [|state| (atom.read state)]
+ (case (\ mock <mock> |state|)
+ (#try.Success [|state| output])
+ (do !
+ [_ (atom.write |state| state)]
+ (wrap (#try.Success output)))
+
+ (#try.Failure error)
+ (wrap (#try.Failure error)))))]
+
+ [read on_read]
+ [read_line on_read_line]
+ ))
+
+ (def: (write input)
+ (do {! io.monad}
+ [|state| (atom.read state)]
+ (case (\ mock on_write input |state|)
+ (#try.Success |state|)
+ (do !
+ [_ (atom.write |state| state)]
+ (wrap (#try.Success [])))
+
+ (#try.Failure error)
+ (wrap (#try.Failure error)))))
+
+ (def: (close _)
+ (do {! io.monad}
+ [|state| (atom.read state)]
+ (case (\ mock on_close |state|)
+ (#try.Success |state|)
+ (do !
+ [_ (atom.write |state| state)]
+ (wrap (#try.Success [])))
+
+ (#try.Failure error)
+ (wrap (#try.Failure error)))))
+ ))))
diff --git a/stdlib/source/library/lux/world/db/jdbc.lux b/stdlib/source/library/lux/world/db/jdbc.lux
new file mode 100644
index 000000000..5ef233daf
--- /dev/null
+++ b/stdlib/source/library/lux/world/db/jdbc.lux
@@ -0,0 +1,176 @@
+(.module:
+ [library
+ [lux (#- and int)
+ [control
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ [monad (#+ Monad do)]
+ ["." try (#+ Try)]
+ ["ex" exception]
+ [concurrency
+ ["." promise (#+ Promise) ("#\." monad)]]
+ [security
+ ["!" capability (#+ capability:)]]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]]
+ ["." io (#+ IO)]
+ [world
+ [net (#+ URL)]]
+ [host (#+ import:)]]]
+ [//
+ ["." sql]]
+ ["." / #_
+ ["#." input (#+ Input)]
+ ["#." output (#+ Output)]])
+
+(import: java/lang/String)
+
+(import: java/sql/ResultSet
+ (getRow [] #try int)
+ (next [] #try boolean)
+ (close [] #io #try void))
+
+(import: java/sql/Statement
+ (#static NO_GENERATED_KEYS int)
+ (#static RETURN_GENERATED_KEYS int)
+ (getGeneratedKeys [] #try java/sql/ResultSet)
+ (close [] #io #try void))
+
+(import: java/sql/PreparedStatement
+ (executeUpdate [] #io #try int)
+ (executeQuery [] #io #try java/sql/ResultSet))
+
+(import: java/sql/Connection
+ (prepareStatement [java/lang/String int] #try java/sql/PreparedStatement)
+ (isValid [int] #try boolean)
+ (close [] #io #try void))
+
+(import: java/sql/DriverManager
+ (#static getConnection [java/lang/String java/lang/String java/lang/String] #io #try java/sql/Connection))
+
+(type: #export Credentials
+ {#url URL
+ #user Text
+ #password Text})
+
+(type: #export ID Int)
+
+(type: #export (Statement input)
+ {#sql sql.Statement
+ #input (Input input)
+ #value input})
+
+(template [<name> <forge> <output>]
+ [(capability: #export (<name> ! i)
+ (<forge> (Statement i) (! (Try <output>))))]
+
+ [Can-Execute can-execute Nat]
+ [Can-Insert can-insert (List ID)]
+ )
+
+(capability: #export (Can-Query ! i o)
+ (can-query [(Statement i) (Output o)] (! (Try (List o)))))
+
+(capability: #export (Can-Close !)
+ (can-close Any (! (Try Any))))
+
+(interface: #export (DB !)
+ (: (Can-Execute !)
+ execute)
+ (: (Can-Insert !)
+ insert)
+ (: (Can-Query !)
+ query)
+ (: (Can-Close !)
+ close))
+
+(def: (with-statement statement conn action)
+ (All [i a]
+ (-> (Statement i) java/sql/Connection
+ (-> java/sql/PreparedStatement (IO (Try a)))
+ (IO (Try a))))
+ (do (try.with io.monad)
+ [prepared (io.io (java/sql/Connection::prepareStatement (sql.sql (get@ #sql statement))
+ (java/sql/Statement::RETURN_GENERATED_KEYS)
+ conn))
+ _ (io.io ((get@ #input statement) (get@ #value statement) [1 prepared]))
+ result (action prepared)
+ _ (java/sql/Statement::close prepared)]
+ (wrap result)))
+
+(def: #export (async db)
+ (-> (DB IO) (DB Promise))
+ (`` (implementation
+ (~~ (template [<name> <forge>]
+ [(def: <name> (<forge> (|>> (!.use (\ db <name>)) promise.future)))]
+
+ [execute can-execute]
+ [insert can-insert]
+ [close can-close]
+ [query can-query])))))
+
+(def: #export (connect creds)
+ (-> Credentials (IO (Try (DB IO))))
+ (do (try.with io.monad)
+ [connection (java/sql/DriverManager::getConnection (get@ #url creds)
+ (get@ #user creds)
+ (get@ #password creds))]
+ (wrap (: (DB IO)
+ (implementation
+ (def: execute
+ (..can-execute
+ (function (execute statement)
+ (with-statement statement connection
+ (function (_ prepared)
+ (do (try.with io.monad)
+ [row-count (java/sql/PreparedStatement::executeUpdate prepared)]
+ (wrap (.nat row-count))))))))
+
+ (def: insert
+ (..can-insert
+ (function (insert statement)
+ (with-statement statement connection
+ (function (_ prepared)
+ (do (try.with io.monad)
+ [_ (java/sql/PreparedStatement::executeUpdate prepared)
+ result-set (io.io (java/sql/Statement::getGeneratedKeys prepared))]
+ (/output.rows /output.long result-set)))))))
+
+ (def: close
+ (..can-close
+ (function (close _)
+ (java/sql/Connection::close connection))))
+
+ (def: query
+ (..can-query
+ (function (query [statement output])
+ (with-statement statement connection
+ (function (_ prepared)
+ (do (try.with io.monad)
+ [result-set (java/sql/PreparedStatement::executeQuery prepared)]
+ (/output.rows output result-set)))))))
+ )))))
+
+(def: #export (with-db creds action)
+ (All [a]
+ (-> Credentials
+ (-> (DB IO) (IO (Try a)))
+ (IO (Try a))))
+ (do (try.with io.monad)
+ [db (..connect creds)
+ result (action db)
+ _ (!.use (\ db close) [])]
+ (wrap result)))
+
+(def: #export (with-async-db creds action)
+ (All [a]
+ (-> Credentials
+ (-> (DB Promise) (Promise (Try a)))
+ (Promise (Try a))))
+ (do (try.with promise.monad)
+ [db (promise.future (..connect creds))
+ result (action (..async db))
+ _ (promise\wrap (io.run (!.use (\ db close) [])))]
+ (wrap result)))
diff --git a/stdlib/source/library/lux/world/db/jdbc/input.lux b/stdlib/source/library/lux/world/db/jdbc/input.lux
new file mode 100644
index 000000000..9c3de1238
--- /dev/null
+++ b/stdlib/source/library/lux/world/db/jdbc/input.lux
@@ -0,0 +1,107 @@
+(.module:
+ [library
+ [lux (#- and int)
+ [ffi (#+ import:)]
+ [control
+ [functor (#+ Contravariant)]
+ [monad (#+ Monad do)]
+ ["." try (#+ Try)]]
+ [time
+ ["." instant (#+ Instant)]]
+ ["." io (#+ IO)]
+ [world
+ [binary (#+ Binary)]]]])
+
+(import: java/lang/String)
+
+(template [<class>]
+ [(import: <class>
+ (new [long]))]
+
+ [java/sql/Date] [java/sql/Time] [java/sql/Timestamp]
+ )
+
+(`` (import: java/sql/PreparedStatement
+ (~~ (template [<name> <type>]
+ [(<name> [int <type>] #try void)]
+
+ [setBoolean boolean]
+
+ [setByte byte]
+ [setShort short]
+ [setInt int]
+ [setLong long]
+
+ [setFloat float]
+ [setDouble double]
+
+ [setString java/lang/String]
+ [setBytes [byte]]
+
+ [setDate java/sql/Date]
+ [setTime java/sql/Time]
+ [setTimestamp java/sql/Timestamp]
+ ))))
+
+(type: #export (Input a)
+ (-> a [Nat java/sql/PreparedStatement]
+ (Try [Nat java/sql/PreparedStatement])))
+
+(implementation: #export contravariant (Contravariant Input)
+ (def: (map-1 f fb)
+ (function (fa value circumstance)
+ (fb (f value) circumstance))))
+
+(def: #export (and pre post)
+ (All [l r] (-> (Input l) (Input r) (Input [l r])))
+ (function (_ [left right] context)
+ (do try.monad
+ [context (pre left context)]
+ (post right context))))
+
+(def: #export (fail error)
+ (All [a] (-> Text (Input a)))
+ (function (_ value [idx context])
+ (#try.Failure error)))
+
+(def: #export empty
+ (Input Any)
+ (function (_ value context)
+ (#try.Success context)))
+
+(template [<function> <type> <setter>]
+ [(def: #export <function>
+ (Input <type>)
+ (function (_ value [idx statement])
+ (do try.monad
+ [_ (<setter> (.int idx) value statement)]
+ (wrap [(.inc idx) statement]))))]
+
+ [boolean Bit java/sql/PreparedStatement::setBoolean]
+
+ [byte Int java/sql/PreparedStatement::setByte]
+ [short Int java/sql/PreparedStatement::setShort]
+ [int Int java/sql/PreparedStatement::setInt]
+ [long Int java/sql/PreparedStatement::setLong]
+
+ [float Frac java/sql/PreparedStatement::setFloat]
+ [double Frac java/sql/PreparedStatement::setDouble]
+
+ [string Text java/sql/PreparedStatement::setString]
+ [bytes Binary java/sql/PreparedStatement::setBytes]
+ )
+
+(template [<function> <setter> <constructor>]
+ [(def: #export <function>
+ (Input Instant)
+ (function (_ value [idx statement])
+ (do try.monad
+ [_ (<setter> (.int idx)
+ (<constructor> (instant.to-millis value))
+ statement)]
+ (wrap [(.inc idx) statement]))))]
+
+ [date java/sql/PreparedStatement::setDate java/sql/Date::new]
+ [time java/sql/PreparedStatement::setTime java/sql/Time::new]
+ [time-stamp java/sql/PreparedStatement::setTimestamp java/sql/Timestamp::new]
+ )
diff --git a/stdlib/source/library/lux/world/db/jdbc/output.lux b/stdlib/source/library/lux/world/db/jdbc/output.lux
new file mode 100644
index 000000000..b172a1ac9
--- /dev/null
+++ b/stdlib/source/library/lux/world/db/jdbc/output.lux
@@ -0,0 +1,195 @@
+(.module:
+ [library
+ [lux (#- and int)
+ [ffi (#+ import:)]
+ [control
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ [monad (#+ Monad do)]
+ ["ex" exception]
+ ["." try (#+ Try)]]
+ [time
+ ["." instant (#+ Instant)]]
+ ["." io (#+ IO)]
+ [world
+ [binary (#+ Binary)]]]])
+
+(import: java/lang/String)
+
+(import: java/util/Date
+ (getTime [] long))
+
+(import: java/sql/Date)
+(import: java/sql/Time)
+(import: java/sql/Timestamp)
+
+(`` (import: java/sql/ResultSet
+ (~~ (template [<method-name> <return-class>]
+ [(<method-name> [int] #try <return-class>)]
+
+ [getBoolean boolean]
+
+ [getByte byte]
+ [getShort short]
+ [getInt int]
+ [getLong long]
+
+ [getDouble double]
+ [getFloat float]
+
+ [getString java/lang/String]
+ [getBytes [byte]]
+
+ [getDate java/sql/Date]
+ [getTime java/sql/Time]
+ [getTimestamp java/sql/Timestamp]
+ ))
+ (next [] #try boolean)
+ (close [] #io #try void)))
+
+(type: #export (Output a)
+ (-> [Nat java/sql/ResultSet] (Try [Nat a])))
+
+(implementation: #export functor
+ (Functor Output)
+
+ (def: (map f fa)
+ (function (_ idx+rs)
+ (case (fa idx+rs)
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success [idx' value])
+ (#try.Success [idx' (f value)])))))
+
+(implementation: #export apply
+ (Apply Output)
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (function (_ [idx rs])
+ (case (ff [idx rs])
+ (#try.Success [idx' f])
+ (case (fa [idx' rs])
+ (#try.Success [idx'' a])
+ (#try.Success [idx'' (f a)])
+
+ (#try.Failure msg)
+ (#try.Failure msg))
+
+ (#try.Failure msg)
+ (#try.Failure msg)))))
+
+(implementation: #export monad
+ (Monad Output)
+
+ (def: &functor ..functor)
+
+ (def: (wrap a)
+ (function (_ [idx rs])
+ (#.Some [idx a])))
+
+ (def: (join mma)
+ (function (_ [idx rs])
+ (case (mma [idx rs])
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success [idx' ma])
+ (ma [idx' rs])))))
+
+(def: #export (fail error)
+ (All [a] (-> Text (Output a)))
+ (function (_ [idx result-set])
+ (#try.Failure error)))
+
+(def: #export (and left right)
+ (All [a b]
+ (-> (Output a) (Output b) (Output [a b])))
+ (do ..monad
+ [=left left
+ =right right]
+ (wrap [=left =right])))
+
+(template [<func-name> <method-name> <type>]
+ [(def: #export <func-name>
+ (Output <type>)
+ (function (_ [idx result-set])
+ (case (<method-name> [(.int idx)] result-set)
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success value)
+ (#try.Success [(inc idx) value]))))]
+
+ [boolean java/sql/ResultSet::getBoolean Bit]
+
+ [byte java/sql/ResultSet::getByte Int]
+ [short java/sql/ResultSet::getShort Int]
+ [int java/sql/ResultSet::getInt Int]
+ [long java/sql/ResultSet::getLong Int]
+
+ [float java/sql/ResultSet::getFloat Frac]
+ [double java/sql/ResultSet::getDouble Frac]
+
+ [string java/sql/ResultSet::getString Text]
+ [bytes java/sql/ResultSet::getBytes Binary]
+ )
+
+(template [<func-name> <method-name>]
+ [(def: #export <func-name>
+ (Output Instant)
+ (function (_ [idx result-set])
+ (case (<method-name> [(.int idx)] result-set)
+ (#try.Failure error)
+ (#try.Failure error)
+
+ (#try.Success value)
+ (#try.Success [(inc idx)
+ (instant.from-millis (java/util/Date::getTime value))]))))]
+
+ [date java/sql/ResultSet::getDate]
+ [time java/sql/ResultSet::getTime]
+ [time-stamp java/sql/ResultSet::getTimestamp]
+ )
+
+(def: #export (rows output results)
+ (All [a] (-> (Output a) java/sql/ResultSet (IO (Try (List a)))))
+ (case (java/sql/ResultSet::next results)
+ (#try.Success has-next?)
+ (if has-next?
+ (case (output [1 results])
+ (#.Some [_ head])
+ (do io.monad
+ [?tail (rows output results)]
+ (case ?tail
+ (#try.Success tail)
+ (wrap (ex.return (#.Cons head tail)))
+
+ (#try.Failure error)
+ (do io.monad
+ [temp (java/sql/ResultSet::close results)]
+ (wrap (do try.monad
+ [_ temp]
+ (try.fail error))))))
+
+ (#try.Failure error)
+ (do io.monad
+ [temp (java/sql/ResultSet::close results)]
+ (wrap (do try.monad
+ [_ temp]
+ (try.fail error)))))
+ (do io.monad
+ [temp (java/sql/ResultSet::close results)]
+ (wrap (do try.monad
+ [_ temp]
+ (wrap (list))))))
+
+ (#try.Failure error)
+ (do io.monad
+ [temp (java/sql/ResultSet::close results)]
+ (wrap (do try.monad
+ [_ temp]
+ (try.fail error))))
+ ))
diff --git a/stdlib/source/library/lux/world/db/sql.lux b/stdlib/source/library/lux/world/db/sql.lux
new file mode 100644
index 000000000..99f3f027d
--- /dev/null
+++ b/stdlib/source/library/lux/world/db/sql.lux
@@ -0,0 +1,476 @@
+(.module:
+ [library
+ [lux (#- Source Definition function and or not type is? int)
+ [control
+ [monad (#+ do)]]
+ [data
+ [number
+ ["i" int]]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [type
+ abstract]]])
+
+(def: parenthesize
+ (-> Text Text)
+ (text.enclose ["(" ")"]))
+
+## Kind
+(template [<declaration>]
+ [(abstract: #export <declaration> Any)]
+
+ [Literal']
+ [Column']
+ [Placeholder']
+ [(Value' kind)]
+
+ [Function']
+
+ [Condition']
+
+ [Index']
+
+ [Table']
+ [View']
+ [Source']
+ [DB']
+
+ [No-Limit] [With-Limit]
+ [No-Offset] [With-Offset]
+ [Order']
+ [No-Order] [With-Order]
+ [No-Group] [With-Group]
+ [(Query' order group limit offset)]
+
+ [Command']
+
+ [No-Where] [With-Where] [Without-Where]
+ [No-Having] [With-Having] [Without-Having]
+ [(Action' where having kind)]
+
+ [(Schema' kind)]
+ [Definition']
+ [(Statement' kind)]
+ )
+
+(type: #export Alias Text)
+
+(def: #export no-alias Alias "")
+
+(abstract: #export (SQL kind)
+ Text
+
+ ## SQL
+ (template [<declaration> <kind>]
+ [(type: #export <declaration> (SQL <kind>))]
+
+ [Literal (Value' Literal')]
+ [Column (Value' Column')]
+ [Placeholder (Value' Placeholder')]
+ [Value (Value' Any)]
+
+ [Function Function']
+ [Condition Condition']
+
+ [Index Index']
+
+ [Table Table']
+ [View View']
+ [Source Source']
+ [DB DB']
+
+ [Order Order']
+
+ [(Schema kind) (Schema' kind)]
+
+ [(Query where having order group limit offset) (Statement' (Action' where having (Query' order group limit offset)))]
+ [(Command where having) (Statement' (Action' where having Command'))]
+ [(Action where having kind) (Statement' (Action' where having kind))]
+
+ [Definition (Statement' Definition')]
+ [Statement (Statement' Any)]
+ )
+
+ (def: Base-Query (.type (Query No-Where No-Having No-Order No-Group No-Limit No-Offset)))
+ (def: Any-Query (.type (Query Any Any Any Any Any Any)))
+
+ (def: #export read
+ {#.doc (doc "Only use this function for debugging purposes."
+ "Do not use this function to actually execute SQL code.")}
+ (-> (SQL Any) Text)
+ (|>> :representation))
+
+ (def: #export (sql action)
+ (-> Statement Text)
+ (format (:representation action) ";"))
+
+ (def: enumerate
+ (-> (List (SQL Any)) Text)
+ (|>> (list\map (|>> :representation))
+ (text.join-with ", ")))
+
+ ## Value
+ (def: #export ? Placeholder (:abstraction "?"))
+
+ (def: literal
+ (-> Text Literal)
+ (|>> :abstraction))
+
+ (def: #export null Literal (..literal "NULL"))
+
+ (def: #export (int value)
+ (-> Int Literal)
+ (..literal (if (i.< +0 value)
+ (%.int value)
+ (%.nat (.nat value)))))
+
+ (def: #export function
+ (-> Text Function)
+ (|>> :abstraction))
+
+ (def: #export (call function parameters)
+ (-> Function (List Value) Value)
+ (:abstraction (format (:representation function)
+ (..parenthesize (..enumerate parameters)))))
+
+ ## Condition
+ (template [<name> <sql-op>]
+ [(def: #export (<name> reference sample)
+ (-> Value Value Condition)
+ (:abstraction
+ (..parenthesize
+ (format (:representation sample)
+ " " <sql-op> " "
+ (:representation reference)))))]
+
+ [= "="]
+ [<> "<>"]
+ [is? "IS"]
+ [> ">"]
+ [>= ">="]
+ [< "<"]
+ [<= "<="]
+ [like? "LIKE"]
+ [ilike? "ILIKE"]
+ )
+
+ (def: #export (between from to sample)
+ (-> Value Value Value Condition)
+ (:abstraction
+ (..parenthesize
+ (format (:representation sample)
+ " BETWEEN " (:representation from)
+ " AND " (:representation to)))))
+
+ (def: #export (in options value)
+ (-> (List Value) Value Condition)
+ (:abstraction
+ (format (:representation value)
+ " IN "
+ (..parenthesize (enumerate options)))))
+
+ (template [<func-name> <sql-op>]
+ [(def: #export (<func-name> left right)
+ (-> Condition Condition Condition)
+ (:abstraction
+ (format (..parenthesize (:representation left))
+ " " <sql-op> " "
+ (..parenthesize (:representation right)))))]
+
+ [and "AND"]
+ [or "OR"]
+ )
+
+ (template [<name> <type> <sql>]
+ [(def: #export <name>
+ (-> <type> Condition)
+ (|>> :representation ..parenthesize (format <sql> " ") :abstraction))]
+
+ [not Condition "NOT"]
+ [exists Any-Query "EXISTS"]
+ )
+
+ ## Query
+ (template [<name> <type> <decoration>]
+ [(def: #export <name>
+ (-> <type> Source)
+ (|>> :representation <decoration> :abstraction))]
+
+ [from-table Table (<|)]
+ [from-view View (<|)]
+ [from-query Any-Query ..parenthesize]
+ )
+
+ (template [<func-name> <op>]
+ [(def: #export (<func-name> columns source)
+ (-> (List [Column Alias]) Source Base-Query)
+ (:abstraction
+ (format <op>
+ " "
+ (case columns
+ #.Nil
+ "*"
+
+ _
+ (|> columns
+ (list\map (.function (_ [column alias])
+ (if (text\= ..no-alias alias)
+ (:representation column)
+ (format (:representation column) " AS " alias))))
+ (text.join-with ", ")))
+ " FROM " (:representation source))))]
+
+
+ [select "SELECT"]
+ [select-distinct "SELECT DISTINCT"]
+ )
+
+ (template [<name> <join-text>]
+ [(def: #export (<name> table condition prev)
+ (-> Table Condition Base-Query Base-Query)
+ (:abstraction
+ (format (:representation prev)
+ " " <join-text> " "
+ (:representation table)
+ " ON " (:representation condition))))]
+
+ [inner-join "INNER JOIN"]
+ [left-join "LEFT JOIN"]
+ [right-join "RIGHT JOIN"]
+ [full-outer-join "FULL OUTER JOIN"]
+ )
+
+ (template [<function> <sql-op>]
+ [(def: #export (<function> left right)
+ (-> Any-Query Any-Query (Query Without-Where Without-Having No-Order No-Group No-Limit No-Offset))
+ (:abstraction
+ (format (:representation left)
+ " " <sql-op> " "
+ (:representation right))))]
+
+ [union "UNION"]
+ [union-all "UNION ALL"]
+ [intersect "INTERSECT"]
+ )
+
+ (template [<name> <sql> <variables> <input> <output>]
+ [(def: #export (<name> value query)
+ (All <variables>
+ (-> Nat <input> <output>))
+ (:abstraction
+ (format (:representation query)
+ " " <sql> " "
+ (%.nat value))))]
+
+ [limit "LIMIT" [where having order group offset]
+ (Query where having order group No-Limit offset)
+ (Query where having order group With-Limit offset)]
+
+ [offset "OFFSET" [where having order group limit]
+ (Query where having order group limit No-Offset)
+ (Query where having order group limit With-Offset)]
+ )
+
+ (template [<name> <sql>]
+ [(def: #export <name>
+ Order
+ (:abstraction <sql>))]
+
+ [ascending "ASC"]
+ [descending "DESC"]
+ )
+
+ (def: #export (order-by pairs query)
+ (All [where having group limit offset]
+ (-> (List [Value Order])
+ (Query where having No-Order group limit offset)
+ (Query where having With-Order group limit offset)))
+ (case pairs
+ #.Nil
+ (|> query :representation :abstraction)
+
+ _
+ (:abstraction
+ (format (:representation query)
+ " ORDER BY "
+ (|> pairs
+ (list\map (.function (_ [value order])
+ (format (:representation value) " " (:representation order))))
+ (text.join-with ", "))))))
+
+ (def: #export (group-by pairs query)
+ (All [where having order limit offset]
+ (-> (List Value)
+ (Query where having order No-Group limit offset)
+ (Query where having order With-Group limit offset)))
+ (case pairs
+ #.Nil
+ (|> query :representation :abstraction)
+
+ _
+ (:abstraction
+ (format (:representation query)
+ " GROUP BY "
+ (..enumerate pairs)))))
+
+ ## Command
+ (def: #export (insert table columns rows)
+ (-> Table (List Column) (List (List Value)) (Command Without-Where Without-Having))
+ (:abstraction
+ (format "INSERT INTO " (:representation table) " "
+ (..parenthesize (..enumerate columns))
+ " VALUES "
+ (|> rows
+ (list\map (|>> ..enumerate ..parenthesize))
+ (text.join-with ", "))
+ )))
+
+ (def: #export (update table pairs)
+ (-> Table (List [Column Value]) (Command No-Where No-Having))
+ (:abstraction (format "UPDATE " (:representation table)
+ (case pairs
+ #.Nil
+ ""
+
+ _
+ (format " SET " (|> pairs
+ (list\map (.function (_ [column value])
+ (format (:representation column) "=" (:representation value))))
+ (text.join-with ", ")))))))
+
+ (def: #export delete
+ (-> Table (Command No-Where No-Having))
+ (|>> :representation (format "DELETE FROM ") :abstraction))
+
+ ## Action
+ (def: #export (where condition prev)
+ (All [kind having]
+ (-> Condition (Action No-Where having kind) (Action With-Where having kind)))
+ (:abstraction
+ (format (:representation prev)
+ " WHERE "
+ (:representation condition))))
+
+ (def: #export (having condition prev)
+ (All [where kind]
+ (-> Condition (Action where No-Having kind) (Action where With-Having kind)))
+ (:abstraction
+ (format (:representation prev)
+ " HAVING "
+ (:representation condition))))
+
+ ## Schema
+ (def: #export type
+ (-> Text (Schema Value))
+ (|>> :abstraction))
+
+ (template [<name> <attr>]
+ [(def: #export (<name> attr)
+ (-> (Schema Value) (Schema Value))
+ (:abstraction
+ (format (:representation attr) " " <attr>)))]
+
+ [unique "UNIQUE"]
+ [not-null "NOT NULL"]
+ [stored "STORED"]
+ )
+
+ (def: #export (default value attr)
+ (-> Value (Schema Value) (Schema Value))
+ (:abstraction
+ (format (:representation attr) " DEFAULT " (:representation value))))
+
+ (def: #export (define-column name type)
+ (-> Column (Schema Value) (Schema Column))
+ (:abstraction
+ (format (:representation name) " " (:representation type))))
+
+ (def: #export (auto-increment offset column)
+ (-> Int (Schema Column) (Schema Column))
+ (:abstraction
+ (format (:representation column) " AUTO_INCREMENT=" (:representation (..int offset)))))
+
+ (def: #export (create-table or-replace? table columns)
+ (-> Bit Table (List (Schema Column)) Definition)
+ (let [command (if or-replace?
+ "CREATE OR REPLACE TABLE"
+ "CREATE TABLE IF NOT EXISTS")]
+ (:abstraction
+ (format command " " (:representation table)
+ (..parenthesize (..enumerate columns))))))
+
+ (def: #export (create-table-as table query)
+ (-> Table Any-Query Definition)
+ (:abstraction
+ (format "CREATE TABLE " (:representation table) " AS " (:representation query))))
+
+ (template [<name> <sql>]
+ [(def: #export (<name> table)
+ (-> Table Definition)
+ (:abstraction
+ (format <sql> " TABLE " (:representation table))))]
+
+ [drop "DROP"]
+ [truncate "TRUNCATE"]
+ )
+
+ (def: #export (add-column table column)
+ (-> Table (Schema Column) Definition)
+ (:abstraction
+ (format "ALTER TABLE " (:representation table) " ADD " (:representation column))))
+
+ (def: #export (drop-column table column)
+ (-> Table Column Definition)
+ (:abstraction
+ (format "ALTER TABLE " (:representation table) " DROP COLUMN " (:representation column))))
+
+ (template [<name> <type>]
+ [(def: #export (<name> name)
+ (-> Text <type>)
+ (:abstraction name))]
+
+ [column Column]
+ [table Table]
+ [view View]
+ [index Index]
+ [db DB]
+ )
+
+ (template [<name> <type> <sql>]
+ [(def: #export <name>
+ (-> <type> Definition)
+ (|>> :representation (format <sql> " ") :abstraction))]
+
+ [create-db DB "CREATE DATABASE"]
+ [drop-db DB "DROP DATABASE"]
+ [drop-view View "DROP VIEW"]
+ )
+
+ (template [<name> <sql>]
+ [(def: #export (<name> view query)
+ (-> View Any-Query Definition)
+ (:abstraction
+ (format <sql> " " (:representation view) " AS " (:representation query))))]
+
+ [create-view "CREATE VIEW"]
+ [create-or-replace-view "CREATE OR REPLACE VIEW"]
+ )
+
+ (def: #export (create-index index table unique? columns)
+ (-> Index Table Bit (List Column) Definition)
+ (:abstraction
+ (format "CREATE " (if unique? "UNIQUE" "") " INDEX " (:representation index)
+ " ON " (:representation table) " " (..parenthesize (..enumerate columns)))))
+
+ (def: #export (with alias query body)
+ (All [where having order group limit offset]
+ (-> Table Any-Query
+ (Query where having order group limit offset)
+ (Query where having order group limit offset)))
+ (:abstraction
+ (format "WITH " (:representation alias)
+ " AS " (..parenthesize (:representation query))
+ " " (:representation body))))
+ )
diff --git a/stdlib/source/library/lux/world/file.lux b/stdlib/source/library/lux/world/file.lux
new file mode 100644
index 000000000..7f95b3282
--- /dev/null
+++ b/stdlib/source/library/lux/world/file.lux
@@ -0,0 +1,1303 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ ["." ffi]
+ [abstract
+ ["." monad (#+ Monad do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try (#+ Try) ("#\." functor)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO) ("#\." functor)]
+ ["." function]
+ [concurrency
+ ["." promise (#+ Promise)]
+ ["." stm (#+ Var STM)]]]
+ [data
+ ["." bit ("#\." equivalence)]
+ ["." product]
+ ["." maybe ("#\." functor)]
+ ["." binary (#+ Binary)]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." array (#+ Array)]
+ ["." list ("#\." functor)]
+ ["." dictionary (#+ Dictionary)]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["i" int]
+ ["f" frac]]]
+ [time
+ ["." instant (#+ Instant)]
+ ["." duration]]]])
+
+(type: #export Path
+ Text)
+
+(`` (interface: #export (System !)
+ (: Text
+ separator)
+
+ (~~ (template [<name> <output>]
+ [(: (-> Path (! <output>))
+ <name>)]
+
+ [file? Bit]
+ [directory? Bit]
+ ))
+
+ (~~ (template [<name> <output>]
+ [(: (-> Path (! (Try <output>)))
+ <name>)]
+
+ [make_directory Any]
+ [directory_files (List Path)]
+ [sub_directories (List Path)]
+
+ [file_size Nat]
+ [last_modified Instant]
+ [can_execute? Bit]
+ [read Binary]
+ [delete Any]
+ ))
+
+ (~~ (template [<name> <input>]
+ [(: (-> <input> Path (! (Try Any)))
+ <name>)]
+
+ [modify Instant]
+ [write Binary]
+ [append Binary]
+ [move Path]
+ ))
+ ))
+
+(def: #export (un_nest fs path)
+ (All [!] (-> (System !) Path (Maybe [Path Text])))
+ (let [/ (\ fs separator)]
+ (case (text.last_index_of / path)
+ #.None
+ #.None
+
+ (#.Some last_separator)
+ (do maybe.monad
+ [[parent temp] (text.split last_separator path)
+ [_ child] (text.split (text.size /) temp)]
+ (wrap [parent child])))))
+
+(def: #export (parent fs path)
+ (All [!] (-> (System !) Path (Maybe Path)))
+ (|> (..un_nest fs path)
+ (maybe\map product.left)))
+
+(def: #export (name fs path)
+ (All [!] (-> (System !) Path Text))
+ (|> (..un_nest fs path)
+ (maybe\map product.right)
+ (maybe.default path)))
+
+(def: #export (async fs)
+ (-> (System IO) (System Promise))
+ (`` (implementation
+ (def: separator
+ (\ fs separator))
+
+ (~~ (template [<name>]
+ [(def: <name>
+ (|>> (\ fs <name>)
+ promise.future))]
+
+ [file?]
+ [directory?]
+
+ [make_directory]
+ [directory_files]
+ [sub_directories]
+
+ [file_size]
+ [last_modified]
+ [can_execute?]
+ [read]
+ [delete]))
+
+ (~~ (template [<name>]
+ [(def: (<name> input path)
+ (promise.future (\ fs <name> input path)))]
+
+ [modify]
+ [write]
+ [append]
+ [move]))
+ )))
+
+(def: #export (nest fs parent child)
+ (All [!] (-> (System !) Path Text Path))
+ (format parent (\ fs separator) child))
+
+(template [<name>]
+ [(exception: #export (<name> {file Path})
+ (exception.report
+ ["Path" file]))]
+
+ [cannot_make_file]
+ [cannot_find_file]
+ [cannot_delete]
+
+ [cannot_make_directory]
+ [cannot_find_directory]
+
+ [cannot_read_all_data]
+ )
+
+(with_expansions [<extra> (as_is (exception: #export (cannot_move {target Path} {source Path})
+ (exception.report
+ ["Source" source]
+ ["Target" target])))]
+ (for {@.old (as_is <extra>)
+ @.jvm (as_is <extra>)
+ @.lua (as_is <extra>)}
+ (as_is)))
+
+(with_expansions [<for_jvm> (as_is (exception: #export (cannot_modify_file {instant Instant} {file Path})
+ (exception.report
+ ["Instant" (%.instant instant)]
+ ["Path" file]))
+
+ (ffi.import: java/lang/String)
+
+ (`` (ffi.import: java/io/File
+ ["#::."
+ (new [java/lang/String])
+ (~~ (template [<name>]
+ [(<name> [] #io #try boolean)]
+
+ [createNewFile] [mkdir]
+ [delete]
+ [isFile] [isDirectory]
+ [canRead] [canWrite] [canExecute]))
+
+ (length [] #io #try long)
+ (listFiles [] #io #try #? [java/io/File])
+ (getAbsolutePath [] #io #try java/lang/String)
+ (renameTo [java/io/File] #io #try boolean)
+ (lastModified [] #io #try long)
+ (setLastModified [long] #io #try boolean)
+ (#static separator java/lang/String)]))
+
+ (ffi.import: java/lang/AutoCloseable
+ ["#::."
+ (close [] #io #try void)])
+
+ (ffi.import: java/io/OutputStream
+ ["#::."
+ (write [[byte]] #io #try void)
+ (flush [] #io #try void)])
+
+ (ffi.import: java/io/FileOutputStream
+ ["#::."
+ (new [java/io/File boolean] #io #try)])
+
+ (ffi.import: java/io/InputStream
+ ["#::."
+ (read [[byte]] #io #try int)])
+
+ (ffi.import: java/io/FileInputStream
+ ["#::."
+ (new [java/io/File] #io #try)])
+
+ (`` (implementation: #export default
+ (System IO)
+
+ (def: separator
+ (java/io/File::separator))
+
+ (~~ (template [<name> <method>]
+ [(def: <name>
+ (|>> java/io/File::new
+ <method>
+ (io\map (|>> (try.default false)))))]
+
+ [file? java/io/File::isFile]
+ [directory? java/io/File::isDirectory]
+ ))
+
+ (def: (make_directory path)
+ (|> path
+ java/io/File::new
+ java/io/File::mkdir))
+
+ (~~ (template [<name> <method>]
+ [(def: (<name> path)
+ (do {! (try.with io.monad)}
+ [?children (java/io/File::listFiles (java/io/File::new path))]
+ (case ?children
+ (#.Some children)
+ (|> children
+ array.to_list
+ (monad.filter ! (|>> <method>))
+ (\ ! map (monad.map ! (|>> java/io/File::getAbsolutePath)))
+ (\ ! join))
+
+ #.None
+ (\ io.monad wrap (exception.throw ..cannot_find_directory [path])))))]
+
+ [directory_files java/io/File::isFile]
+ [sub_directories java/io/File::isDirectory]
+ ))
+
+ (def: file_size
+ (|>> java/io/File::new
+ java/io/File::length
+ (\ (try.with io.monad) map .nat)))
+
+ (def: last_modified
+ (|>> java/io/File::new
+ (java/io/File::lastModified)
+ (\ (try.with io.monad) map (|>> duration.from_millis instant.absolute))))
+
+ (def: can_execute?
+ (|>> java/io/File::new
+ java/io/File::canExecute))
+
+ (def: (read path)
+ (do (try.with io.monad)
+ [#let [file (java/io/File::new path)]
+ size (java/io/File::length file)
+ #let [data (binary.create (.nat size))]
+ stream (java/io/FileInputStream::new file)
+ bytes_read (java/io/InputStream::read data stream)
+ _ (java/lang/AutoCloseable::close stream)]
+ (if (i.= size bytes_read)
+ (wrap data)
+ (\ io.monad wrap (exception.throw ..cannot_read_all_data path)))))
+
+ (def: (delete path)
+ (|> path
+ java/io/File::new
+ java/io/File::delete))
+
+ (def: (modify time_stamp path)
+ (|> path
+ java/io/File::new
+ (java/io/File::setLastModified (|> time_stamp instant.relative duration.to_millis))))
+
+ (~~ (template [<name> <flag>]
+ [(def: (<name> data path)
+ (do (try.with io.monad)
+ [stream (java/io/FileOutputStream::new (java/io/File::new path) <flag>)
+ _ (java/io/OutputStream::write data stream)
+ _ (java/io/OutputStream::flush stream)]
+ (java/lang/AutoCloseable::close stream)))]
+
+ [write #0]
+ [append #1]
+ ))
+
+ (def: (move destination origin)
+ (|> origin
+ java/io/File::new
+ (java/io/File::renameTo (java/io/File::new destination))))
+ )))]
+ (for {@.old (as_is <for_jvm>)
+ @.jvm (as_is <for_jvm>)
+
+ @.js
+ (as_is (ffi.import: Buffer
+ ["#::."
+ (#static from [Binary] ..Buffer)])
+
+ (ffi.import: FileDescriptor)
+
+ (ffi.import: Stats
+ ["#::."
+ (size ffi.Number)
+ (mtimeMs ffi.Number)
+ (isFile [] #io #try ffi.Boolean)
+ (isDirectory [] #io #try ffi.Boolean)])
+
+ (ffi.import: FsConstants
+ ["#::."
+ (F_OK ffi.Number)
+ (R_OK ffi.Number)
+ (W_OK ffi.Number)
+ (X_OK ffi.Number)])
+
+ (ffi.import: Fs
+ ["#::."
+ (constants FsConstants)
+ (readFileSync [ffi.String] #io #try Binary)
+ (appendFileSync [ffi.String Buffer] #io #try Any)
+ (writeFileSync [ffi.String Buffer] #io #try Any)
+ (statSync [ffi.String] #io #try Stats)
+ (accessSync [ffi.String ffi.Number] #io #try Any)
+ (renameSync [ffi.String ffi.String] #io #try Any)
+ (utimesSync [ffi.String ffi.Number ffi.Number] #io #try Any)
+ (unlink [ffi.String] #io #try Any)
+ (readdirSync [ffi.String] #io #try (Array ffi.String))
+ (mkdirSync [ffi.String] #io #try Any)
+ (rmdirSync [ffi.String] #io #try Any)])
+
+ (ffi.import: JsPath
+ ["#::."
+ (sep ffi.String)])
+
+ (template [<name> <path>]
+ [(def: (<name> _)
+ (-> [] (Maybe (-> ffi.String Any)))
+ (ffi.constant (-> ffi.String Any) <path>))]
+
+ [normal_require [require]]
+ [global_require [global require]]
+ [process_load [global process mainModule constructor _load]]
+ )
+
+ (def: (require _)
+ (-> [] (-> ffi.String Any))
+ (case [(normal_require []) (global_require []) (process_load [])]
+ (^or [(#.Some require) _ _]
+ [_ (#.Some require) _]
+ [_ _ (#.Some require)])
+ require
+
+ _
+ (undefined)))
+
+ (template [<name> <module> <type>]
+ [(def: (<name> _)
+ (-> [] <type>)
+ (:as <type> (..require [] <module>)))]
+
+ [node_fs "fs" ..Fs]
+ [node_path "path" ..JsPath]
+ )
+
+ (`` (implementation: #export default
+ (System IO)
+
+ (def: separator
+ (if ffi.on_node_js?
+ (JsPath::sep (..node_path []))
+ "/"))
+
+ (~~ (template [<name> <method>]
+ [(def: (<name> path)
+ (do {! io.monad}
+ [?stats (Fs::statSync [path] (..node_fs []))]
+ (case ?stats
+ (#try.Success stats)
+ (|> stats
+ (<method> [])
+ (\ ! map (|>> (try.default false))))
+
+ (#try.Failure _)
+ (wrap false))))]
+
+ [file? Stats::isFile]
+ [directory? Stats::isDirectory]
+ ))
+
+ (def: (make_directory path)
+ (let [node_fs (..node_fs [])]
+ (do io.monad
+ [outcome (Fs::accessSync [path (|> node_fs Fs::constants FsConstants::F_OK)] node_fs)]
+ (case outcome
+ (#try.Success _)
+ (wrap (exception.throw ..cannot_make_directory [path]))
+
+ (#try.Failure _)
+ (Fs::mkdirSync [path] node_fs)))))
+
+ (~~ (template [<name> <method>]
+ [(def: (<name> path)
+ (do {! (try.with io.monad)}
+ [#let [node_fs (..node_fs [])]
+ subs (Fs::readdirSync [path] node_fs)]
+ (|> subs
+ array.to_list
+ (monad.map ! (function (_ sub)
+ (do !
+ [stats (Fs::statSync [sub] node_fs)]
+ (\ ! map (|>> [sub]) (<method> [] stats)))))
+ (\ ! map (|>> (list.filter product.right)
+ (list\map product.left))))))]
+
+ [directory_files Stats::isFile]
+ [sub_directories Stats::isDirectory]
+ ))
+
+ (def: (file_size path)
+ (let [! (try.with io.monad)]
+ (|> (..node_fs [])
+ (Fs::statSync [path])
+ (\ ! map (|>> Stats::size
+ f.nat)))))
+
+ (def: (last_modified path)
+ (let [! (try.with io.monad)]
+ (|> (..node_fs [])
+ (Fs::statSync [path])
+ (\ ! map (|>> Stats::mtimeMs
+ f.int
+ duration.from_millis
+ instant.absolute)))))
+
+ (def: (can_execute? path)
+ (let [node_fs (..node_fs [])]
+ (|> node_fs
+ (Fs::accessSync [path (|> node_fs Fs::constants FsConstants::X_OK)])
+ (io\map (|>> (case> (#try.Success _)
+ true
+
+ (#try.Failure _)
+ false)
+ #try.Success)))))
+
+ (def: (read path)
+ (Fs::readFileSync [path] (..node_fs [])))
+
+ (def: (delete path)
+ (do {! (try.with io.monad)}
+ [#let [node_fs (..node_fs [])]
+ stats (Fs::statSync [path] node_fs)
+ verdict (Stats::isFile [] stats)]
+ (if verdict
+ (Fs::unlink [path] node_fs)
+ (Fs::rmdirSync [path] node_fs))))
+
+ (def: (modify time_stamp path)
+ (let [when (|> time_stamp instant.relative duration.to_millis i.frac)]
+ (Fs::utimesSync [path when when] (..node_fs []))))
+
+ (~~ (template [<name> <method>]
+ [(def: (<name> data path)
+ (<method> [path (Buffer::from data)] (..node_fs [])))]
+
+ [write Fs::writeFileSync]
+ [append Fs::appendFileSync]
+ ))
+
+ (def: (move destination origin)
+ (Fs::renameSync [origin destination] (..node_fs [])))
+ )))
+
+ @.python
+ (as_is (type: (Tuple/2 left right)
+ (primitive "python_tuple[2]" [left right]))
+
+ (ffi.import: PyFile
+ ["#::."
+ (read [] #io #try Binary)
+ (write [Binary] #io #try #? Any)
+ (close [] #io #try #? Any)])
+
+ (ffi.import: (open [ffi.String ffi.String] #io #try PyFile))
+ (ffi.import: (tuple [[ffi.Integer ffi.Integer]] (Tuple/2 ffi.Integer ffi.Integer)))
+
+ (ffi.import: os
+ ["#::."
+ (#static F_OK ffi.Integer)
+ (#static R_OK ffi.Integer)
+ (#static W_OK ffi.Integer)
+ (#static X_OK ffi.Integer)
+
+ (#static mkdir [ffi.String] #io #try #? Any)
+ (#static access [ffi.String ffi.Integer] #io #try ffi.Boolean)
+ (#static remove [ffi.String] #io #try #? Any)
+ (#static rmdir [ffi.String] #io #try #? Any)
+ (#static rename [ffi.String ffi.String] #io #try #? Any)
+ (#static utime [ffi.String (Tuple/2 ffi.Integer ffi.Integer)] #io #try #? Any)
+ (#static listdir [ffi.String] #io #try (Array ffi.String))])
+
+ (ffi.import: os/path
+ ["#::."
+ (#static isfile [ffi.String] #io #try ffi.Boolean)
+ (#static isdir [ffi.String] #io #try ffi.Boolean)
+ (#static sep ffi.String)
+ (#static getsize [ffi.String] #io #try ffi.Integer)
+ (#static getmtime [ffi.String] #io #try ffi.Float)])
+
+ (`` (implementation: #export default
+ (System IO)
+
+ (def: separator
+ (os/path::sep))
+
+ (~~ (template [<name> <method>]
+ [(def: <name>
+ (|>> <method>
+ (io\map (|>> (try.default false)))))]
+
+ [file? os/path::isfile]
+ [directory? os/path::isdir]
+ ))
+
+ (def: make_directory
+ os::mkdir)
+
+ (~~ (template [<name> <method>]
+ [(def: <name>
+ (let [! (try.with io.monad)]
+ (|>> os::listdir
+ (\ ! map (|>> array.to_list
+ (monad.map ! (function (_ sub)
+ (\ ! map (|>> [sub]) (<method> [sub]))))
+ (\ ! map (|>> (list.filter product.right)
+ (list\map product.left)))))
+ (\ ! join))))]
+
+ [directory_files os/path::isfile]
+ [sub_directories os/path::isdir]
+ ))
+
+ (def: file_size
+ (|>> os/path::getsize
+ (\ (try.with io.monad) map .nat)))
+
+ (def: last_modified
+ (|>> os/path::getmtime
+ (\ (try.with io.monad) map (|>> f.int
+ (i.* +1,000)
+ duration.from_millis
+ instant.absolute))))
+
+ (def: (can_execute? path)
+ (os::access [path (os::X_OK)]))
+
+ (def: (read path)
+ (do (try.with io.monad)
+ [file (..open [path "rb"])
+ data (PyFile::read [] file)
+ _ (PyFile::close [] file)]
+ (wrap data)))
+
+ (def: (delete path)
+ (do (try.with io.monad)
+ [? (os/path::isfile [path])]
+ (if ?
+ (os::remove [path])
+ (os::rmdir [path]))))
+
+ (def: (modify time_stamp path)
+ (let [when (|> time_stamp instant.relative duration.to_millis (i./ +1,000))]
+ (os::utime [path (..tuple [when when])])))
+
+ (~~ (template [<name> <mode>]
+ [(def: (<name> data path)
+ (do (try.with io.monad)
+ [file (..open [path <mode>])
+ _ (PyFile::write [data] file)]
+ (PyFile::close [] file)))]
+
+ [write "w+b"]
+ [append "ab"]
+ ))
+
+ (def: (move destination origin)
+ (os::rename [origin destination]))
+ )))
+
+ @.ruby
+ (as_is (ffi.import: Time #as RubyTime
+ ["#::."
+ (#static at [Frac] RubyTime)
+ (to_f [] Frac)])
+
+ (ffi.import: Stat #as RubyStat
+ ["#::."
+ (executable? [] Bit)
+ (size Int)
+ (mtime [] RubyTime)])
+
+ (ffi.import: File #as RubyFile
+ ["#::."
+ (#static SEPARATOR ffi.String)
+ (#static open [Path ffi.String] #io #try RubyFile)
+ (#static stat [Path] #io #try RubyStat)
+ (#static delete [Path] #io #try Int)
+ (#static file? [Path] #io #try Bit)
+ (#static directory? [Path] #io #try Bit)
+ (#static utime [RubyTime RubyTime Path] #io #try Int)
+
+ (read [] #io #try Binary)
+ (write [Binary] #io #try Int)
+ (flush [] #io #try #? Any)
+ (close [] #io #try #? Any)])
+
+ (ffi.import: Dir #as RubyDir
+ ["#::."
+ (#static open [Path] #io #try RubyDir)
+
+ (children [] #io #try (Array Path))
+ (close [] #io #try #? Any)])
+
+ (ffi.import: "fileutils" FileUtils #as RubyFileUtils
+ ["#::."
+ (#static move [Path Path] #io #try #? Any)
+ (#static rmdir [Path] #io #try #? Any)
+ (#static mkdir [Path] #io #try #? Any)])
+
+ (def: ruby_separator
+ Text
+ (..RubyFile::SEPARATOR))
+
+ (`` (implementation: #export default
+ (System IO)
+
+ (def: separator
+ ..ruby_separator)
+
+ (~~ (template [<name> <test>]
+ [(def: <name>
+ (|>> <test>
+ (io\map (|>> (try.default false)))))]
+
+ [file? RubyFile::file?]
+ [directory? RubyFile::directory?]
+ ))
+
+ (def: make_directory
+ RubyFileUtils::mkdir)
+
+ (~~ (template [<name> <test>]
+ [(def: (<name> path)
+ (do {! (try.with io.monad)}
+ [self (RubyDir::open [path])
+ children (RubyDir::children [] self)
+ output (loop [input (|> children
+ array.to_list
+ (list\map (|>> (format path ..ruby_separator))))
+ output (: (List ..Path)
+ (list))]
+ (case input
+ #.Nil
+ (wrap output)
+
+ (#.Cons head tail)
+ (do !
+ [verdict (<test> head)]
+ (recur tail (if verdict
+ (#.Cons head output)
+ output)))))
+ _ (RubyDir::close [] self)]
+ (wrap output)))]
+
+ [directory_files RubyFile::file?]
+ [sub_directories RubyFile::directory?]
+ ))
+
+ (~~ (template [<name> <pipeline>]
+ [(def: <name>
+ (let [! (try.with io.monad)]
+ (|>> RubyFile::stat
+ (\ ! map (`` (|>> (~~ (template.splice <pipeline>))))))))]
+
+ [file_size [RubyStat::size .nat]]
+ [last_modified [(RubyStat::mtime [])
+ (RubyTime::to_f [])
+ (f.* +1,000.0)
+ f.int
+ duration.from_millis
+ instant.absolute]]
+ [can_execute? [(RubyStat::executable? [])]]
+ ))
+
+ (def: (read path)
+ (do (try.with io.monad)
+ [file (RubyFile::open [path "rb"])
+ data (RubyFile::read [] file)
+ _ (RubyFile::close [] file)]
+ (wrap data)))
+
+ (def: (delete path)
+ (do (try.with io.monad)
+ [? (RubyFile::file? path)]
+ (if ?
+ (RubyFile::delete [path])
+ (RubyFileUtils::rmdir [path]))))
+
+ (def: (modify moment path)
+ (let [moment (|> moment
+ instant.relative
+ duration.to_millis
+ i.frac
+ (f./ +1,000.0)
+ RubyTime::at)]
+ (RubyFile::utime [moment moment path])))
+
+ (~~ (template [<mode> <name>]
+ [(def: (<name> data path)
+ (do {! (try.with io.monad)}
+ [file (RubyFile::open [path <mode>])
+ data (RubyFile::write [data] file)
+ _ (RubyFile::flush [] file)
+ _ (RubyFile::close [] file)]
+ (wrap [])))]
+
+ ["wb" write]
+ ["ab" append]
+ ))
+
+ (def: (move destination origin)
+ (do (try.with io.monad)
+ [_ (RubyFileUtils::move [origin destination])]
+ (wrap [])))
+ )))
+
+ ## @.php
+ ## (as_is (ffi.import: (FILE_APPEND Int))
+ ## ## https://www.php.net/manual/en/dir.constants.php
+ ## (ffi.import: (DIRECTORY_SEPARATOR ffi.String))
+ ## ## https://www.php.net/manual/en/function.pack.php
+ ## ## https://www.php.net/manual/en/function.unpack.php
+ ## (ffi.import: (unpack [ffi.String ffi.String] Binary))
+ ## ## https://www.php.net/manual/en/ref.filesystem.php
+ ## ## https://www.php.net/manual/en/function.file-get-contents.php
+ ## (ffi.import: (file_get_contents [Path] #io #try ffi.String))
+ ## ## https://www.php.net/manual/en/function.file-put-contents.php
+ ## (ffi.import: (file_put_contents [Path ffi.String Int] #io #try ffi.Integer))
+ ## (ffi.import: (filemtime [Path] #io #try ffi.Integer))
+ ## (ffi.import: (filesize [Path] #io #try ffi.Integer))
+ ## (ffi.import: (is_executable [Path] #io #try ffi.Boolean))
+ ## (ffi.import: (touch [Path ffi.Integer] #io #try ffi.Boolean))
+ ## (ffi.import: (rename [Path Path] #io #try ffi.Boolean))
+ ## (ffi.import: (unlink [Path] #io #try ffi.Boolean))
+
+ ## ## https://www.php.net/manual/en/function.rmdir.php
+ ## (ffi.import: (rmdir [Path] #io #try ffi.Boolean))
+ ## ## https://www.php.net/manual/en/function.scandir.php
+ ## (ffi.import: (scandir [Path] #io #try (Array Path)))
+ ## ## https://www.php.net/manual/en/function.is-file.php
+ ## (ffi.import: (is_file [Path] #io #try ffi.Boolean))
+ ## ## https://www.php.net/manual/en/function.is-dir.php
+ ## (ffi.import: (is_dir [Path] #io #try ffi.Boolean))
+ ## ## https://www.php.net/manual/en/function.mkdir.php
+ ## (ffi.import: (mkdir [Path] #io #try ffi.Boolean))
+
+ ## (def: byte_array_format "C*")
+ ## (def: default_separator (..DIRECTORY_SEPARATOR))
+
+ ## (template [<name>]
+ ## [(exception: #export (<name> {file Path})
+ ## (exception.report
+ ## ["Path" file]))]
+
+ ## [cannot_write_to_file]
+ ## )
+
+ ## (`` (implementation: (file path)
+ ## (-> Path (File IO))
+
+ ## (~~ (template [<name> <mode>]
+ ## [(def: (<name> data)
+ ## (do {! (try.with io.monad)}
+ ## [outcome (..file_put_contents [path ("php pack" ..byte_array_format data) <mode>])]
+ ## (if (bit\= false (:as Bit outcome))
+ ## (\ io.monad wrap (exception.throw ..cannot_write_to_file [path]))
+ ## (wrap []))))]
+
+ ## [over_write +0]
+ ## [append (..FILE_APPEND)]
+ ## ))
+
+ ## (def: (content _)
+ ## (do {! (try.with io.monad)}
+ ## [data (..file_get_contents [path])]
+ ## (if (bit\= false (:as Bit data))
+ ## (\ io.monad wrap (exception.throw ..cannot_find_file [path]))
+ ## (wrap (..unpack [..byte_array_format data])))))
+
+ ## (def: path
+ ## path)
+
+ ## (~~ (template [<name> <ffi> <pipeline>]
+ ## [(def: (<name> _)
+ ## (do {! (try.with io.monad)}
+ ## [value (<ffi> [path])]
+ ## (if (bit\= false (:as Bit value))
+ ## (\ io.monad wrap (exception.throw ..cannot_find_file [path]))
+ ## (wrap (`` (|> value (~~ (template.splice <pipeline>))))))))]
+
+ ## [size ..filesize [.nat]]
+ ## [last_modified ..filemtime [(i.* +1,000) duration.from_millis instant.absolute]]
+ ## ))
+
+ ## (def: (can_execute? _)
+ ## (..is_executable [path]))
+
+ ## (def: (modify moment)
+ ## (do {! (try.with io.monad)}
+ ## [verdict (..touch [path (|> moment instant.relative duration.to_millis (i./ +1,000))])]
+ ## (if (bit\= false (:as Bit verdict))
+ ## (\ io.monad wrap (exception.throw ..cannot_find_file [path]))
+ ## (wrap []))))
+
+ ## (def: (move destination)
+ ## (do {! (try.with io.monad)}
+ ## [verdict (..rename [path destination])]
+ ## (if (bit\= false (:as Bit verdict))
+ ## (\ io.monad wrap (exception.throw ..cannot_find_file [path]))
+ ## (wrap (file destination)))))
+
+ ## (def: (delete _)
+ ## (do (try.with io.monad)
+ ## [verdict (..unlink [path])]
+ ## (if (bit\= false (:as Bit verdict))
+ ## (\ io.monad wrap (exception.throw ..cannot_find_file [path]))
+ ## (wrap []))))
+ ## ))
+
+ ## (`` (implementation: (directory path)
+ ## (-> Path (Directory IO))
+
+ ## (def: scope
+ ## path)
+
+ ## (~~ (template [<name> <test> <constructor> <capability>]
+ ## [(def: (<name> _)
+ ## (do {! (try.with io.monad)}
+ ## [children (..scandir [path])]
+ ## (loop [input (|> children
+ ## array.to_list
+ ## (list.filter (function (_ child)
+ ## (not (or (text\= "." child)
+ ## (text\= ".." child))))))
+ ## output (: (List (<capability> IO))
+ ## (list))]
+ ## (case input
+ ## #.Nil
+ ## (wrap output)
+
+ ## (#.Cons head tail)
+ ## (do !
+ ## [verdict (<test> head)]
+ ## (if verdict
+ ## (recur tail (#.Cons (<constructor> head) output))
+ ## (recur tail output)))))))]
+
+ ## [files ..is_file ..file File]
+ ## [directories ..is_dir directory Directory]
+ ## ))
+
+ ## (def: (discard _)
+ ## (do (try.with io.monad)
+ ## [verdict (..rmdir [path])]
+ ## (if (bit\= false (:as Bit verdict))
+ ## (\ io.monad wrap (exception.throw ..cannot_find_directory [path]))
+ ## (wrap []))))
+ ## ))
+
+ ## (`` (implementation: #export default
+ ## (System IO)
+
+ ## (~~ (template [<name> <test> <constructor> <exception>]
+ ## [(def: (<name> path)
+ ## (do {! (try.with io.monad)}
+ ## [verdict (<test> path)]
+ ## (\ io.monad wrap
+ ## (if verdict
+ ## (#try.Success (<constructor> path))
+ ## (exception.throw <exception> [path])))))]
+
+ ## [file ..is_file ..file ..cannot_find_file]
+ ## [directory ..is_dir ..directory ..cannot_find_directory]
+ ## ))
+
+ ## (def: (make_file path)
+ ## (do {! (try.with io.monad)}
+ ## [verdict (..touch [path (|> instant.now io.run instant.relative duration.to_millis (i./ +1,000))])]
+ ## (\ io.monad wrap
+ ## (if verdict
+ ## (#try.Success (..file path))
+ ## (exception.throw ..cannot_make_file [path])))))
+
+ ## (def: (make_directory path)
+ ## (do {! (try.with io.monad)}
+ ## [verdict (..mkdir path)]
+ ## (\ io.monad wrap
+ ## (if verdict
+ ## (#try.Success (..directory path))
+ ## (exception.throw ..cannot_make_directory [path])))))
+
+ ## (def: separator
+ ## ..default_separator)
+ ## ))
+ ## )
+ }
+ (as_is)))
+
+(def: #export (exists? monad fs path)
+ (All [!] (-> (Monad !) (System !) Path (! Bit)))
+ (do monad
+ [verdict (\ fs file? path)]
+ (if verdict
+ (wrap verdict)
+ (\ fs directory? path))))
+
+(type: Mock_File
+ {#mock_last_modified Instant
+ #mock_can_execute Bit
+ #mock_content Binary})
+
+(type: #rec Mock
+ (Dictionary Text (Either Mock_File Mock)))
+
+(def: empty_mock
+ Mock
+ (dictionary.new text.hash))
+
+(def: (retrieve_mock_file! separator path mock)
+ (-> Text Path Mock (Try [Text Mock_File]))
+ (loop [directory mock
+ trail (text.split_all_with separator path)]
+ (case trail
+ (#.Cons head tail)
+ (case (dictionary.get head directory)
+ #.None
+ (exception.throw ..cannot_find_file [path])
+
+ (#.Some node)
+ (case [node tail]
+ [(#.Left file) #.Nil]
+ (#try.Success [head file])
+
+ [(#.Right sub_directory) (#.Cons _)]
+ (recur sub_directory tail)
+
+ _
+ (exception.throw ..cannot_find_file [path])))
+
+ #.Nil
+ (exception.throw ..cannot_find_file [path]))))
+
+(def: (update_mock_file! / path now content mock)
+ (-> Text Path Instant Binary Mock (Try Mock))
+ (loop [directory mock
+ trail (text.split_all_with / path)]
+ (case trail
+ (#.Cons head tail)
+ (case (dictionary.get head directory)
+ #.None
+ (case tail
+ #.Nil
+ (#try.Success (dictionary.put head
+ (#.Left {#mock_last_modified now
+ #mock_can_execute false
+ #mock_content content})
+ directory))
+
+ (#.Cons _)
+ (exception.throw ..cannot_find_file [path]))
+
+ (#.Some node)
+ (case [node tail]
+ [(#.Left file) #.Nil]
+ (#try.Success (dictionary.put head
+ (#.Left (|> file
+ (set@ #mock_last_modified now)
+ (set@ #mock_content content)))
+ directory))
+
+ [(#.Right sub_directory) (#.Cons _)]
+ (do try.monad
+ [sub_directory (recur sub_directory tail)]
+ (wrap (dictionary.put head (#.Right sub_directory) directory)))
+
+ _
+ (exception.throw ..cannot_find_file [path])))
+
+ #.Nil
+ (exception.throw ..cannot_find_file [path]))))
+
+(def: (mock_delete! / path mock)
+ (-> Text Path Mock (Try Mock))
+ (loop [directory mock
+ trail (text.split_all_with / path)]
+ (case trail
+ (#.Cons head tail)
+ (case (dictionary.get head directory)
+ #.None
+ (exception.throw ..cannot_delete [path])
+
+ (#.Some node)
+ (case tail
+ #.Nil
+ (case node
+ (#.Left file)
+ (#try.Success (dictionary.remove head directory))
+
+ (#.Right sub_directory)
+ (if (dictionary.empty? sub_directory)
+ (#try.Success (dictionary.remove head directory))
+ (exception.throw ..cannot_delete [path])))
+
+ (#.Cons _)
+ (case node
+ (#.Left file)
+ (exception.throw ..cannot_delete [path])
+
+ (#.Right sub_directory)
+ (do try.monad
+ [sub_directory' (recur sub_directory tail)]
+ (wrap (dictionary.put head (#.Right sub_directory') directory))))))
+
+ #.Nil
+ (exception.throw ..cannot_delete [path]))))
+
+(def: (try_update! transform var)
+ (All [a] (-> (-> a (Try a)) (Var a) (STM (Try Any))))
+ (do {! stm.monad}
+ [|var| (stm.read var)]
+ (case (transform |var|)
+ (#try.Success |var|)
+ (do !
+ [_ (stm.write |var| var)]
+ (wrap (#try.Success [])))
+
+ (#try.Failure error)
+ (wrap (#try.Failure error)))))
+
+(def: (make_mock_directory! / path mock)
+ (-> Text Path Mock (Try Mock))
+ (loop [directory mock
+ trail (text.split_all_with / path)]
+ (case trail
+ (#.Cons head tail)
+ (case (dictionary.get head directory)
+ #.None
+ (case tail
+ #.Nil
+ (#try.Success (dictionary.put head (#.Right ..empty_mock) directory))
+
+ (#.Cons _)
+ (exception.throw ..cannot_make_directory [path]))
+
+ (#.Some node)
+ (case [node tail]
+ [(#.Right sub_directory) (#.Cons _)]
+ (do try.monad
+ [sub_directory (recur sub_directory tail)]
+ (wrap (dictionary.put head (#.Right sub_directory) directory)))
+
+ _
+ (exception.throw ..cannot_make_directory [path])))
+
+ #.Nil
+ (exception.throw ..cannot_make_directory [path]))))
+
+(def: (retrieve_mock_directory! / path mock)
+ (-> Text Path Mock (Try Mock))
+ (loop [directory mock
+ trail (text.split_all_with / path)]
+ (case trail
+ #.Nil
+ (#try.Success directory)
+
+ (#.Cons head tail)
+ (case (dictionary.get head directory)
+ #.None
+ (exception.throw ..cannot_find_directory [path])
+
+ (#.Some node)
+ (case node
+ (#.Left _)
+ (exception.throw ..cannot_find_directory [path])
+
+ (#.Right sub_directory)
+ (case tail
+ #.Nil
+ (#try.Success sub_directory)
+
+ (#.Cons _)
+ (recur sub_directory tail)))))))
+
+(def: #export (mock separator)
+ (-> Text (System Promise))
+ (let [store (stm.var ..empty_mock)]
+ (`` (implementation
+ (def: separator
+ separator)
+
+ (~~ (template [<method> <retrieve>]
+ [(def: (<method> path)
+ (|> store
+ stm.read
+ (\ stm.monad map
+ (|>> (<retrieve> separator path)
+ (try\map (function.constant true))
+ (try.default false)))
+ stm.commit))]
+
+ [file? ..retrieve_mock_file!]
+ [directory? ..retrieve_mock_directory!]))
+
+ (def: (make_directory path)
+ (stm.commit
+ (do {! stm.monad}
+ [|store| (stm.read store)]
+ (case (..make_mock_directory! separator path |store|)
+ (#try.Success |store|)
+ (do !
+ [_ (stm.write |store| store)]
+ (wrap (#try.Success [])))
+
+ (#try.Failure error)
+ (wrap (#try.Failure error))))))
+
+ (~~ (template [<method> <tag>]
+ [(def: (<method> path)
+ (stm.commit
+ (do stm.monad
+ [|store| (stm.read store)]
+ (wrap (do try.monad
+ [directory (..retrieve_mock_directory! separator path |store|)]
+ (wrap (|> directory
+ dictionary.entries
+ (list.all (function (_ [node_name node])
+ (case node
+ (<tag> _)
+ (#.Some (format path separator node_name))
+
+ _
+ #.None))))))))))]
+
+ [directory_files #.Left]
+ [sub_directories #.Right]
+ ))
+
+ (def: (file_size path)
+ (stm.commit
+ (do stm.monad
+ [|store| (stm.read store)]
+ (wrap (|> |store|
+ (..retrieve_mock_file! separator path)
+ (try\map (|>> product.right
+ (get@ #mock_content)
+ binary.size)))))))
+
+ (def: (last_modified path)
+ (stm.commit
+ (do stm.monad
+ [|store| (stm.read store)]
+ (wrap (|> |store|
+ (..retrieve_mock_file! separator path)
+ (try\map (|>> product.right
+ (get@ #mock_last_modified))))))))
+
+ (def: (can_execute? path)
+ (stm.commit
+ (do stm.monad
+ [|store| (stm.read store)]
+ (wrap (|> |store|
+ (..retrieve_mock_file! separator path)
+ (try\map (|>> product.right
+ (get@ #mock_can_execute))))))))
+
+ (def: (read path)
+ (stm.commit
+ (do stm.monad
+ [|store| (stm.read store)]
+ (wrap (|> |store|
+ (..retrieve_mock_file! separator path)
+ (try\map (|>> product.right
+ (get@ #mock_content))))))))
+
+ (def: (delete path)
+ (stm.commit
+ (..try_update! (..mock_delete! separator path) store)))
+
+ (def: (modify now path)
+ (stm.commit
+ (..try_update! (function (_ |store|)
+ (do try.monad
+ [[name file] (..retrieve_mock_file! separator path |store|)]
+ (..update_mock_file! separator path now (get@ #mock_content file) |store|)))
+ store)))
+
+ (def: (write content path)
+ (do promise.monad
+ [now (promise.future instant.now)]
+ (stm.commit
+ (..try_update! (..update_mock_file! separator path now content) store))))
+
+ (def: (append content path)
+ (do promise.monad
+ [now (promise.future instant.now)]
+ (stm.commit
+ (..try_update! (function (_ |store|)
+ (do try.monad
+ [[name file] (..retrieve_mock_file! separator path |store|)]
+ (..update_mock_file! separator path now
+ (\ binary.monoid compose
+ (get@ #mock_content file)
+ content)
+ |store|)))
+ store))))
+
+ (def: (move destination origin)
+ (stm.commit
+ (do {! stm.monad}
+ [|store| (stm.read store)]
+ (case (do try.monad
+ [[name file] (..retrieve_mock_file! separator origin |store|)
+ |store| (..mock_delete! separator origin |store|)]
+ (..update_mock_file! separator destination (get@ #mock_last_modified file) (get@ #mock_content file) |store|))
+ (#try.Success |store|)
+ (do !
+ [_ (stm.write |store| store)]
+ (wrap (#try.Success [])))
+
+ (#try.Failure error)
+ (wrap (#try.Failure error))))))
+ ))))
+
+(def: (check_or_make_directory monad fs path)
+ (All [!] (-> (Monad !) (System !) Path (! (Try Any))))
+ (do monad
+ [? (\ fs directory? path)]
+ (if ?
+ (wrap (#try.Success []))
+ (\ fs make_directory path))))
+
+(def: #export (make_directories monad fs path)
+ (All [!] (-> (Monad !) (System !) Path (! (Try Any))))
+ (let [rooted? (text.starts_with? (\ fs separator) path)
+ segments (text.split_all_with (\ fs separator) path)]
+ (case (if rooted?
+ (list.drop 1 segments)
+ segments)
+ #.Nil
+ (\ monad wrap (exception.throw ..cannot_make_directory [path]))
+
+ (#.Cons head tail)
+ (case head
+ "" (\ monad wrap (exception.throw ..cannot_make_directory [path]))
+ _ (loop [current (if rooted?
+ (format (\ fs separator) head)
+ head)
+ next tail]
+ (do monad
+ [? (..check_or_make_directory monad fs current)]
+ (case ?
+ (#try.Success _)
+ (case next
+ #.Nil
+ (wrap (#try.Success []))
+
+ (#.Cons head tail)
+ (recur (format current (\ fs separator) head)
+ tail))
+
+ (#try.Failure error)
+ (wrap (#try.Failure error)))))))))
+
+(def: #export (make_file monad fs content path)
+ (All [!] (-> (Monad !) (System !) Binary Path (! (Try Any))))
+ (do monad
+ [? (\ fs file? path)]
+ (if ?
+ (wrap (exception.throw ..cannot_make_file [path]))
+ (\ fs write content path))))
diff --git a/stdlib/source/library/lux/world/file/watch.lux b/stdlib/source/library/lux/world/file/watch.lux
new file mode 100644
index 000000000..df655ed9c
--- /dev/null
+++ b/stdlib/source/library/lux/world/file/watch.lux
@@ -0,0 +1,459 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ ["." ffi (#+ import:)]
+ [abstract
+ [predicate (#+ Predicate)]
+ ["." monad (#+ do)]]
+ [control
+ ["." io (#+ IO)]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ [concurrency
+ ["." promise (#+ Promise)]
+ ["." stm (#+ STM Var)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary (#+ Dictionary)]
+ ["." list ("#\." functor monoid fold)]
+ ["." set]
+ ["." array]]]
+ [math
+ [number
+ ["n" nat]]]
+ [time
+ ["." instant (#+ Instant) ("#\." equivalence)]]
+ [type
+ [abstract (#+ abstract: :representation :abstraction)]]]]
+ ["." //])
+
+(abstract: #export Concern
+ {#create Bit
+ #modify Bit
+ #delete Bit}
+
+ (def: none
+ Concern
+ (:abstraction
+ {#create false
+ #modify false
+ #delete false}))
+
+ (template [<concern> <predicate> <event> <create> <modify> <delete>]
+ [(def: #export <concern>
+ Concern
+ (:abstraction
+ {#create <create>
+ #modify <modify>
+ #delete <delete>}))
+
+ (def: #export <predicate>
+ (Predicate Concern)
+ (|>> :representation (get@ <event>)))]
+
+ [creation creation? #create
+ true false false]
+ [modification modification? #modify
+ false true false]
+ [deletion deletion? #delete
+ false false true]
+ )
+
+ (def: #export (also left right)
+ (-> Concern Concern Concern)
+ (:abstraction
+ {#create (or (..creation? left) (..creation? right))
+ #modify (or (..modification? left) (..modification? right))
+ #delete (or (..deletion? left) (..deletion? right))}))
+
+ (def: #export all
+ Concern
+ ($_ ..also
+ ..creation
+ ..modification
+ ..deletion
+ ))
+ )
+
+(interface: #export (Watcher !)
+ (: (-> Concern //.Path (! (Try Any)))
+ start)
+ (: (-> //.Path (! (Try Concern)))
+ concern)
+ (: (-> //.Path (! (Try Concern)))
+ stop)
+ (: (-> [] (! (Try (List [Concern //.Path]))))
+ poll))
+
+(template [<name>]
+ [(exception: #export (<name> {path //.Path})
+ (exception.report
+ ["Path" (%.text path)]))]
+
+ [not_being_watched]
+ [cannot_poll_a_non_existent_directory]
+ )
+
+(type: File_Tracker
+ (Dictionary //.Path Instant))
+
+(type: Directory_Tracker
+ (Dictionary //.Path [Concern File_Tracker]))
+
+(def: (update_watch! new_concern path tracker)
+ (-> Concern //.Path (Var Directory_Tracker) (STM Bit))
+ (do {! stm.monad}
+ [@tracker (stm.read tracker)]
+ (case (dictionary.get path @tracker)
+ (#.Some [old_concern last_modified])
+ (do !
+ [_ (stm.update (dictionary.put path [new_concern last_modified]) tracker)]
+ (wrap true))
+
+ #.None
+ (wrap false))))
+
+(def: (file_tracker fs directory)
+ (-> (//.System Promise) //.Path (Promise (Try File_Tracker)))
+ (do {! (try.with promise.monad)}
+ [files (\ fs directory_files directory)]
+ (monad.fold !
+ (function (_ file tracker)
+ (do !
+ [last_modified (\ fs last_modified file)]
+ (wrap (dictionary.put file last_modified tracker))))
+ (: File_Tracker
+ (dictionary.new text.hash))
+ files)))
+
+(def: (poll_files fs directory)
+ (-> (//.System Promise) //.Path (Promise (Try (List [//.Path Instant]))))
+ (do {! (try.with promise.monad)}
+ [files (\ fs directory_files directory)]
+ (monad.map ! (function (_ file)
+ (|> file
+ (\ fs last_modified)
+ (\ ! map (|>> [file]))))
+ files)))
+
+(def: (poll_directory_changes fs [directory [concern file_tracker]])
+ (-> (//.System Promise) [//.Path [Concern File_Tracker]]
+ (Promise (Try [[//.Path [Concern File_Tracker]]
+ [(List [//.Path Instant])
+ (List [//.Path Instant Instant])
+ (List //.Path)]])))
+ (do {! (try.with promise.monad)}
+ [current_files (..poll_files fs directory)
+ #let [creations (if (..creation? concern)
+ (list.filter (|>> product.left (dictionary.key? file_tracker) not)
+ current_files)
+ (list))
+ available (|> current_files
+ (list\map product.left)
+ (set.from_list text.hash))
+ deletions (if (..deletion? concern)
+ (|> (dictionary.entries file_tracker)
+ (list\map product.left)
+ (list.filter (|>> (set.member? available) not)))
+ (list))
+ modifications (list.all (function (_ [path current_modification])
+ (do maybe.monad
+ [previous_modification (dictionary.get path file_tracker)]
+ (wrap [path previous_modification current_modification])))
+ current_files)]]
+ (wrap [[directory
+ [concern
+ (let [with_deletions (list\fold dictionary.remove file_tracker deletions)
+ with_creations (list\fold (function (_ [path last_modified] tracker)
+ (dictionary.put path last_modified tracker))
+ with_deletions
+ creations)
+ with_modifications (list\fold (function (_ [path previous_modification current_modification] tracker)
+ (dictionary.put path current_modification tracker))
+ with_creations
+ modifications)]
+ with_modifications)]]
+ [creations
+ modifications
+ deletions]])))
+
+(def: #export (polling fs)
+ (-> (//.System Promise) (Watcher Promise))
+ (let [tracker (: (Var Directory_Tracker)
+ (stm.var (dictionary.new text.hash)))]
+ (implementation
+ (def: (start new_concern path)
+ (do {! promise.monad}
+ [exists? (\ fs directory? path)]
+ (if exists?
+ (do !
+ [updated? (stm.commit (..update_watch! new_concern path tracker))]
+ (if updated?
+ (wrap (#try.Success []))
+ (do (try.with !)
+ [file_tracker (..file_tracker fs path)]
+ (do !
+ [_ (stm.commit (stm.update (dictionary.put path [new_concern file_tracker]) tracker))]
+ (wrap (#try.Success []))))))
+ (wrap (exception.throw ..cannot_poll_a_non_existent_directory [path])))))
+ (def: (concern path)
+ (stm.commit
+ (do stm.monad
+ [@tracker (stm.read tracker)]
+ (wrap (case (dictionary.get path @tracker)
+ (#.Some [concern file_tracker])
+ (#try.Success concern)
+
+ #.None
+ (exception.throw ..not_being_watched [path]))))))
+ (def: (stop path)
+ (stm.commit
+ (do {! stm.monad}
+ [@tracker (stm.read tracker)]
+ (case (dictionary.get path @tracker)
+ (#.Some [concern file_tracker])
+ (do !
+ [_ (stm.update (dictionary.remove path) tracker)]
+ (wrap (#try.Success concern)))
+
+ #.None
+ (wrap (exception.throw ..not_being_watched [path]))))))
+ (def: (poll _)
+ (do promise.monad
+ [@tracker (stm.commit (stm.read tracker))]
+ (do {! (try.with promise.monad)}
+ [changes (|> @tracker
+ dictionary.entries
+ (monad.map ! (..poll_directory_changes fs)))
+ _ (do promise.monad
+ [_ (stm.commit (stm.write (|> changes
+ (list\map product.left)
+ (dictionary.from_list text.hash))
+ tracker))]
+ (wrap (#try.Success [])))
+ #let [[creations modifications deletions]
+ (list\fold (function (_ [_ [creations modifications deletions]]
+ [all_creations all_modifications all_deletions])
+ [(list\compose creations all_creations)
+ (list\compose modifications all_modifications)
+ (list\compose deletions all_deletions)])
+ [(list) (list) (list)]
+ changes)]]
+ (wrap ($_ list\compose
+ (list\map (|>> product.left [..creation]) creations)
+ (|> modifications
+ (list.filter (function (_ [path previous_modification current_modification])
+ (not (instant\= previous_modification current_modification))))
+ (list\map (|>> product.left [..modification])))
+ (list\map (|>> [..deletion]) deletions)
+ )))))
+ )))
+
+(def: #export (mock separator)
+ (-> Text [(//.System Promise) (Watcher Promise)])
+ (let [fs (//.mock separator)]
+ [fs
+ (..polling fs)]))
+
+(with_expansions [<jvm> (as_is (import: java/lang/Object)
+
+ (import: java/lang/String)
+
+ (import: (java/util/List a)
+ ["#::."
+ (size [] int)
+ (get [int] a)])
+
+ (def: (default_list list)
+ (All [a] (-> (java/util/List a) (List a)))
+ (let [size (.nat (java/util/List::size list))]
+ (loop [idx 0
+ output #.Nil]
+ (if (n.< size idx)
+ (recur (inc idx)
+ (#.Cons (java/util/List::get (.int idx) list)
+ output))
+ output))))
+
+ (import: (java/nio/file/WatchEvent$Kind a))
+
+ (import: (java/nio/file/WatchEvent a)
+ ["#::."
+ (kind [] (java/nio/file/WatchEvent$Kind a))])
+
+ (import: java/nio/file/Watchable)
+
+ (import: java/nio/file/Path
+ ["#::."
+ (register [java/nio/file/WatchService [(java/nio/file/WatchEvent$Kind [? < java/lang/Object])]] #io #try java/nio/file/WatchKey)
+ (toString [] java/lang/String)])
+
+ (import: java/nio/file/StandardWatchEventKinds
+ ["#::."
+ (#static ENTRY_CREATE (java/nio/file/WatchEvent$Kind java/nio/file/Path))
+ (#static ENTRY_MODIFY (java/nio/file/WatchEvent$Kind java/nio/file/Path))
+ (#static ENTRY_DELETE (java/nio/file/WatchEvent$Kind java/nio/file/Path))])
+
+ (def: (default_event_concern event)
+ (All [a]
+ (-> (java/nio/file/WatchEvent a) Concern))
+ (let [kind (:as (java/nio/file/WatchEvent$Kind java/nio/file/Path)
+ (java/nio/file/WatchEvent::kind event))]
+ (cond (is? (java/nio/file/StandardWatchEventKinds::ENTRY_CREATE)
+ kind)
+ ..creation
+
+ (is? (java/nio/file/StandardWatchEventKinds::ENTRY_MODIFY)
+ kind)
+ ..modification
+
+ (is? (java/nio/file/StandardWatchEventKinds::ENTRY_DELETE)
+ kind)
+ ..deletion
+
+ ## else
+ ..none
+ )))
+
+ (import: java/nio/file/WatchKey
+ ["#::."
+ (reset [] #io boolean)
+ (cancel [] #io void)
+ (watchable [] java/nio/file/Watchable)
+ (pollEvents [] #io (java/util/List (java/nio/file/WatchEvent ?)))])
+
+ (def: default_key_concern
+ (-> java/nio/file/WatchKey (IO Concern))
+ (|>> java/nio/file/WatchKey::pollEvents
+ (\ io.monad map (|>> ..default_list
+ (list\map default_event_concern)
+ (list\fold ..also ..none)))))
+
+ (import: java/nio/file/WatchService
+ ["#::."
+ (poll [] #io #try #? java/nio/file/WatchKey)])
+
+ (import: java/nio/file/FileSystem
+ ["#::."
+ (newWatchService [] #io #try java/nio/file/WatchService)])
+
+ (import: java/nio/file/FileSystems
+ ["#::."
+ (#static getDefault [] java/nio/file/FileSystem)])
+
+ (import: java/io/File
+ ["#::."
+ (new [java/lang/String])
+ (toPath [] java/nio/file/Path)])
+
+ (type: Watch_Event
+ (java/nio/file/WatchEvent$Kind java/lang/Object))
+
+ (def: (default_start watch_events watcher path)
+ (-> (List Watch_Event) java/nio/file/WatchService //.Path (Promise (Try java/nio/file/WatchKey)))
+ (let [watch_events' (list\fold (function (_ [index watch_event] watch_events')
+ (ffi.array_write index watch_event watch_events'))
+ (ffi.array (java/nio/file/WatchEvent$Kind java/lang/Object)
+ (list.size watch_events))
+ (list.enumeration watch_events))]
+ (promise.future
+ (java/nio/file/Path::register watcher
+ watch_events'
+ (|> path java/io/File::new java/io/File::toPath)))))
+
+ (def: (default_poll watcher)
+ (-> java/nio/file/WatchService (IO (Try (List [Concern //.Path]))))
+ (loop [output (: (List [Concern //.Path])
+ (list))]
+ (do (try.with io.monad)
+ [?key (java/nio/file/WatchService::poll watcher)]
+ (case ?key
+ (#.Some key)
+ (do {! io.monad}
+ [valid? (java/nio/file/WatchKey::reset key)]
+ (if valid?
+ (do !
+ [#let [path (|> key
+ java/nio/file/WatchKey::watchable
+ (:as java/nio/file/Path)
+ java/nio/file/Path::toString
+ (:as //.Path))]
+ concern (..default_key_concern key)]
+ (recur (#.Cons [concern path]
+ output)))
+ (recur output)))
+
+ #.None
+ (wrap output)))))
+
+ (def: (watch_events concern)
+ (-> Concern (List Watch_Event))
+ ($_ list\compose
+ (if (..creation? concern)
+ (list (:as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_CREATE)))
+ (list))
+ (if (..modification? concern)
+ (list (:as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_MODIFY)))
+ (list))
+ (if (..deletion? concern)
+ (list (:as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_DELETE)))
+ (list))
+ ))
+
+ (def: #export default
+ (IO (Try (Watcher Promise)))
+ (do (try.with io.monad)
+ [watcher (java/nio/file/FileSystem::newWatchService
+ (java/nio/file/FileSystems::getDefault))
+ #let [tracker (stm.var (: (Dictionary //.Path [Concern java/nio/file/WatchKey])
+ (dictionary.new text.hash)))
+
+ stop (: (-> //.Path (Promise (Try Concern)))
+ (function (_ path)
+ (do {! promise.monad}
+ [@tracker (stm.commit (stm.read tracker))]
+ (case (dictionary.get path @tracker)
+ (#.Some [concern key])
+ (do !
+ [_ (promise.future
+ (java/nio/file/WatchKey::cancel key))
+ _ (stm.commit (stm.update (dictionary.remove path) tracker))]
+ (wrap (#try.Success concern)))
+
+ #.None
+ (wrap (exception.throw ..not_being_watched [path]))))))]]
+ (wrap (: (Watcher Promise)
+ (implementation
+ (def: (start concern path)
+ (do promise.monad
+ [?concern (stop path)]
+ (do (try.with promise.monad)
+ [key (..default_start (..watch_events (..also (try.default ..none ?concern)
+ concern))
+ watcher
+ path)]
+ (do promise.monad
+ [_ (stm.commit (stm.update (dictionary.put path [concern key]) tracker))]
+ (wrap (#try.Success []))))))
+ (def: (concern path)
+ (do promise.monad
+ [@tracker (stm.commit (stm.read tracker))]
+ (case (dictionary.get path @tracker)
+ (#.Some [concern key])
+ (wrap (#try.Success concern))
+
+ #.None
+ (wrap (exception.throw ..not_being_watched [path])))))
+ (def: stop stop)
+ (def: (poll _)
+ (promise.future (..default_poll watcher)))
+ )))))
+ )]
+ (for {@.old (as_is <jvm>)
+ @.jvm (as_is <jvm>)}
+ (as_is)))
diff --git a/stdlib/source/library/lux/world/input/keyboard.lux b/stdlib/source/library/lux/world/input/keyboard.lux
new file mode 100644
index 000000000..8c65fe493
--- /dev/null
+++ b/stdlib/source/library/lux/world/input/keyboard.lux
@@ -0,0 +1,112 @@
+(.module:
+ [library
+ [lux #*]])
+
+(type: #export Key
+ Nat)
+
+(template [<code> <name>]
+ [(def: #export <name> Key <code>)]
+
+ [00008 back_space]
+ [00010 enter]
+ [00016 shift]
+ [00017 control]
+ [00018 alt]
+ [00020 caps_lock]
+ [00027 escape]
+ [00032 space]
+ [00033 page_up]
+ [00034 page_down]
+ [00035 end]
+ [00036 home]
+
+ [00037 left]
+ [00038 up]
+ [00039 right]
+ [00040 down]
+
+ [00065 a]
+ [00066 b]
+ [00067 c]
+ [00068 d]
+ [00069 e]
+ [00070 f]
+ [00071 g]
+ [00072 h]
+ [00073 i]
+ [00074 j]
+ [00075 k]
+ [00076 l]
+ [00077 m]
+ [00078 n]
+ [00079 o]
+ [00080 p]
+ [00081 q]
+ [00082 r]
+ [00083 s]
+ [00084 t]
+ [00085 u]
+ [00086 v]
+ [00087 w]
+ [00088 x]
+ [00089 y]
+ [00090 z]
+
+ [00096 num_pad_0]
+ [00097 num_pad_1]
+ [00098 num_pad_2]
+ [00099 num_pad_3]
+ [00100 num_pad_4]
+ [00101 num_pad_5]
+ [00102 num_pad_6]
+ [00103 num_pad_7]
+ [00104 num_pad_8]
+ [00105 num_pad_9]
+
+ [00127 delete]
+ [00144 num_lock]
+ [00145 scroll_lock]
+ [00154 print_screen]
+ [00155 insert]
+ [00524 windows]
+
+ [00112 f1]
+ [00113 f2]
+ [00114 f3]
+ [00115 f4]
+ [00116 f5]
+ [00117 f6]
+ [00118 f7]
+ [00119 f8]
+ [00120 f9]
+ [00121 f10]
+ [00122 f11]
+ [00123 f12]
+ [61440 f13]
+ [61441 f14]
+ [61442 f15]
+ [61443 f16]
+ [61444 f17]
+ [61445 f18]
+ [61446 f19]
+ [61447 f20]
+ [61448 f21]
+ [61449 f22]
+ [61450 f23]
+ [61451 f24]
+ )
+
+(type: #export Press
+ {#pressed? Bit
+ #input Key})
+
+(template [<bit> <name>]
+ [(def: #export (<name> key)
+ (-> Key Press)
+ {#pressed? <bit>
+ #input key})]
+
+ [#0 release]
+ [#1 press]
+ )
diff --git a/stdlib/source/library/lux/world/net.lux b/stdlib/source/library/lux/world/net.lux
new file mode 100644
index 000000000..cea1b4a7d
--- /dev/null
+++ b/stdlib/source/library/lux/world/net.lux
@@ -0,0 +1,13 @@
+(.module:
+ [library
+ [lux (#- Location)]])
+
+(type: #export Address Text)
+
+(type: #export Port Nat)
+
+(type: #export URL Text)
+
+(type: #export Location
+ {#address Address
+ #port Port})
diff --git a/stdlib/source/library/lux/world/net/http.lux b/stdlib/source/library/lux/world/net/http.lux
new file mode 100644
index 000000000..8e205e2a0
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http.lux
@@ -0,0 +1,80 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ [try (#+ Try)]
+ [concurrency
+ [promise (#+ Promise)]
+ [frp (#+ Channel)]]
+ [parser
+ ["." environment (#+ Environment)]]]
+ [data
+ [binary (#+ Binary)]]]]
+ [// (#+ URL)
+ [uri (#+ URI)]])
+
+(type: #export Version
+ Text)
+
+(type: #export Method
+ #Post
+ #Get
+ #Put
+ #Patch
+ #Delete
+ #Head
+ #Connect
+ #Options
+ #Trace)
+
+(type: #export Port
+ Nat)
+
+(type: #export Status
+ Nat)
+
+(type: #export Headers
+ Environment)
+
+(def: #export empty
+ Headers
+ environment.empty)
+
+(type: #export Header
+ (-> Headers Headers))
+
+(type: #export (Body !)
+ (-> (Maybe Nat) (! (Try [Nat Binary]))))
+
+(type: #export Scheme
+ #HTTP
+ #HTTPS)
+
+(type: #export Address
+ {#port Port
+ #host Text})
+
+(type: #export Identification
+ {#local Address
+ #remote Address})
+
+(type: #export Protocol
+ {#version Version
+ #scheme Scheme})
+
+(type: #export Resource
+ {#method Method
+ #uri URI})
+
+(type: #export (Message !)
+ {#headers Headers
+ #body (Body !)})
+
+(type: #export (Request !)
+ [Identification Protocol Resource (Message !)])
+
+(type: #export (Response !)
+ [Status (Message !)])
+
+(type: #export (Server !)
+ (-> (Request !) (! (Response !))))
diff --git a/stdlib/source/library/lux/world/net/http/client.lux b/stdlib/source/library/lux/world/net/http/client.lux
new file mode 100644
index 000000000..5a7a93e31
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/client.lux
@@ -0,0 +1,227 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ ["." ffi]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." io (#+ IO)]
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." binary (#+ Binary)]
+ ["." maybe ("#\." functor)]
+ ["." text]
+ [collection
+ ["." dictionary]]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]]]]]
+ ["." //
+ [// (#+ URL)]])
+
+(interface: #export (Client !)
+ (: (-> //.Method URL //.Headers (Maybe Binary)
+ (! (Try (//.Response !))))
+ request))
+
+(template [<name> <method>]
+ [(def: #export (<name> url headers data client)
+ (All [!]
+ (-> URL //.Headers (Maybe Binary) (Client !)
+ (! (Try (//.Response !)))))
+ (\ client request <method> url headers data))]
+
+ [post #//.Post]
+ [get #//.Get]
+ [put #//.Put]
+ [patch #//.Patch]
+ [delete #//.Delete]
+ [head #//.Head]
+ [connect #//.Connect]
+ [options #//.Options]
+ [trace #//.Trace]
+ )
+
+(def: default_buffer_size
+ (n.* 1,024 1,024))
+
+(def: empty_body
+ [Nat Binary]
+ [0 (binary.create 0)])
+
+(def: (body_of data)
+ (-> Binary [Nat Binary])
+ [(binary.size data) data])
+
+(with_expansions [<jvm> (as_is (ffi.import: java/lang/String)
+
+ (ffi.import: java/lang/AutoCloseable
+ ["#::."
+ (close [] #io #try void)])
+
+ (ffi.import: java/io/InputStream)
+
+ (ffi.import: java/io/OutputStream
+ ["#::."
+ (flush [] #io #try void)
+ (write [[byte]] #io #try void)])
+
+ (ffi.import: java/net/URLConnection
+ ["#::."
+ (setDoOutput [boolean] #io #try void)
+ (setRequestProperty [java/lang/String java/lang/String] #io #try void)
+ (getInputStream [] #io #try java/io/InputStream)
+ (getOutputStream [] #io #try java/io/OutputStream)
+ (getHeaderFieldKey [int] #io #try #? java/lang/String)
+ (getHeaderField [int] #io #try #? java/lang/String)])
+
+ (ffi.import: java/net/HttpURLConnection
+ ["#::."
+ (setRequestMethod [java/lang/String] #io #try void)
+ (getResponseCode [] #io #try int)])
+
+ (ffi.import: java/net/URL
+ ["#::."
+ (new [java/lang/String])
+ (openConnection [] #io #try java/net/URLConnection)])
+
+ (ffi.import: java/io/BufferedInputStream
+ ["#::."
+ (new [java/io/InputStream])
+ (read [[byte] int int] #io #try int)])
+
+ (def: jvm_method
+ (-> //.Method Text)
+ (|>> (case> #//.Post "POST"
+ #//.Get "GET"
+ #//.Put "PUT"
+ #//.Patch "PATCH"
+ #//.Delete "DELETE"
+ #//.Head "HEAD"
+ #//.Connect "CONNECT"
+ #//.Options "OPTIONS"
+ #//.Trace "TRACE")))
+
+ (def: (default_body input)
+ (-> java/io/BufferedInputStream (//.Body IO))
+ (|>> (maybe\map (|>> [true]))
+ (maybe.default [false ..default_buffer_size])
+ (case> [_ 0]
+ (do (try.with io.monad)
+ [_ (java/lang/AutoCloseable::close input)]
+ (wrap ..empty_body))
+
+ [partial? buffer_size]
+ (let [buffer (binary.create buffer_size)]
+ (if partial?
+ (loop [so_far +0]
+ (do {! (try.with io.monad)}
+ [#let [remaining (i.- so_far (.int buffer_size))]
+ bytes_read (java/io/BufferedInputStream::read buffer so_far remaining input)]
+ (case bytes_read
+ -1 (do !
+ [_ (java/lang/AutoCloseable::close input)]
+ (wrap [(.nat so_far) buffer]))
+ +0 (recur so_far)
+ _ (if (i.= remaining bytes_read)
+ (wrap [buffer_size buffer])
+ (recur (i.+ bytes_read so_far))))))
+ (loop [so_far +0
+ output (\ binary.monoid identity)]
+ (do {! (try.with io.monad)}
+ [#let [remaining (i.- so_far (.int buffer_size))]
+ bytes_read (java/io/BufferedInputStream::read buffer so_far remaining input)]
+ (case bytes_read
+ -1 (do !
+ [_ (java/lang/AutoCloseable::close input)]
+ (case so_far
+ +0 (wrap (..body_of output))
+ _ (|> buffer
+ (binary.slice 0 (.nat so_far))
+ (\ try.functor map
+ (|>> (\ binary.monoid compose output)
+ ..body_of))
+ (\ io.monad wrap))))
+ +0 (recur so_far output)
+ _ (if (i.= remaining bytes_read)
+ (recur +0
+ (\ binary.monoid compose output buffer))
+ (recur (i.+ bytes_read so_far)
+ output))))))))))
+
+ (def: (default_headers connection)
+ (-> java/net/HttpURLConnection (IO (Try //.Headers)))
+ (loop [index +0
+ headers //.empty]
+ (do {! (try.with io.monad)}
+ [?name (java/net/URLConnection::getHeaderFieldKey index connection)]
+ (case ?name
+ (#.Some name)
+ (do !
+ [?value (java/net/URLConnection::getHeaderField index connection)]
+ (recur (inc index)
+ (dictionary.put name (maybe.default "" ?value) headers)))
+
+ #.None
+ (wrap headers)))))
+
+ (implementation: #export default
+ (Client IO)
+
+ (def: (request method url headers data)
+ (: (IO (Try (//.Response IO)))
+ (do {! (try.with io.monad)}
+ [connection (|> url java/net/URL::new java/net/URL::openConnection)
+ #let [connection (:as java/net/HttpURLConnection connection)]
+ _ (java/net/HttpURLConnection::setRequestMethod (..jvm_method method) connection)
+ _ (monad.map ! (function (_ [name value])
+ (java/net/URLConnection::setRequestProperty name value connection))
+ (dictionary.entries headers))
+ _ (case data
+ (#.Some data)
+ (do !
+ [_ (java/net/URLConnection::setDoOutput true connection)
+ stream (java/net/URLConnection::getOutputStream connection)
+ _ (java/io/OutputStream::write data stream)
+ _ (java/io/OutputStream::flush stream)
+ _ (java/lang/AutoCloseable::close stream)]
+ (wrap []))
+
+ #.None
+ (wrap []))
+ status (java/net/HttpURLConnection::getResponseCode connection)
+ headers (..default_headers connection)
+ input (|> connection
+ java/net/URLConnection::getInputStream
+ (\ ! map (|>> java/io/BufferedInputStream::new)))]
+ (wrap [(.nat status)
+ {#//.headers headers
+ #//.body (..default_body input)}]))))))]
+ (for {@.old (as_is <jvm>)
+ @.jvm (as_is <jvm>)}
+ (as_is)))
+
+(implementation: #export (async client)
+ (-> (Client IO) (Client Promise))
+
+ (def: (request method url headers data)
+ (|> (\ client request method url headers data)
+ promise.future
+ (\ promise.monad map
+ (|>> (case> (#try.Success [status message])
+ (#try.Success [status (update@ #//.body (: (-> (//.Body IO) (//.Body Promise))
+ (function (_ body)
+ (|>> body promise.future)))
+ message)])
+
+ (#try.Failure error)
+ (#try.Failure error)))))))
+
+(def: #export headers
+ (-> (List [Text Text]) //.Headers)
+ (dictionary.from_list text.hash))
diff --git a/stdlib/source/library/lux/world/net/http/cookie.lux b/stdlib/source/library/lux/world/net/http/cookie.lux
new file mode 100644
index 000000000..08a75fecc
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/cookie.lux
@@ -0,0 +1,88 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ [monad (#+ do)]
+ ["." try (#+ Try)]
+ ["p" parser ("#\." monad)
+ ["l" text (#+ Parser)]]]
+ [data
+ [number
+ ["i" int]]
+ [text
+ ["%" format (#+ format)]]
+ [format
+ ["." context (#+ Context)]]
+ [collection
+ ["." dictionary]]]
+ [time
+ ["." duration (#+ Duration)]]]]
+ ["." // (#+ Header)
+ ["." header]])
+
+(type: #export Directive (-> Text Text))
+
+(def: (directive extension)
+ (-> Text Directive)
+ (function (_ so-far)
+ (format so-far "; " extension)))
+
+(def: #export (set name value)
+ (-> Text Text Header)
+ (header.add "Set-Cookie" (format name "=" value)))
+
+(def: #export (max-age duration)
+ (-> Duration Directive)
+ (let [seconds (duration.query duration.second duration)]
+ (..directive (format "Max-Age=" (if (i.< +0 seconds)
+ (%.int seconds)
+ (%.nat (.nat seconds)))))))
+
+(template [<name> <prefix>]
+ [(def: #export (<name> value)
+ (-> Text Directive)
+ (..directive (format <prefix> "=" value)))]
+
+ [domain "Domain"]
+ [path "Path"]
+ )
+
+(template [<name> <tag>]
+ [(def: #export <name>
+ Directive
+ (..directive <tag>))]
+
+ [secure "Secure"]
+ [http-only "HttpOnly"]
+ )
+
+(type: #export CSRF-Policy
+ #Strict
+ #Lax)
+
+(def: #export (same-site policy)
+ (-> CSRF-Policy Directive)
+ (..directive (format "SameSite=" (case policy
+ #Strict "Strict"
+ #Lax "Lax"))))
+
+(def: (cookie context)
+ (-> Context (Parser Context))
+ (do p.monad
+ [key (l.slice (l.many! (l.none-of! "=")))
+ _ (l.this "=")
+ value (l.slice (l.many! (l.none-of! ";")))]
+ (wrap (dictionary.put key value context))))
+
+(def: (cookies context)
+ (-> Context (Parser Context))
+ ($_ p.either
+ (do p.monad
+ [context' (..cookie context)
+ _ (l.this "; ")]
+ (cookies context'))
+ (p\wrap context)))
+
+(def: #export (get header)
+ (-> Text (Try Context))
+ (l.run header (..cookies context.empty)))
diff --git a/stdlib/source/library/lux/world/net/http/header.lux b/stdlib/source/library/lux/world/net/http/header.lux
new file mode 100644
index 000000000..e5b1882ad
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/header.lux
@@ -0,0 +1,35 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ [pipe (#+ case>)]]
+ [data
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary (#+ Dictionary)]]]]]
+ [// (#+ Header)
+ ["." mime (#+ MIME)]
+ [// (#+ URL)]])
+
+(def: #export (add name value)
+ (-> Text Text Header)
+ (dictionary.upsert name ""
+ (|>> (case>
+ ""
+ value
+
+ previous
+ (format previous "," value)))))
+
+(def: #export content-length
+ (-> Nat Header)
+ (|>> %.nat (..add "Content-Length")))
+
+(def: #export content-type
+ (-> MIME Header)
+ (|>> mime.name (..add "Content-Type")))
+
+(def: #export location
+ (-> URL Header)
+ (..add "Location"))
diff --git a/stdlib/source/library/lux/world/net/http/mime.lux b/stdlib/source/library/lux/world/net/http/mime.lux
new file mode 100644
index 000000000..859b0840e
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/mime.lux
@@ -0,0 +1,100 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ ["." text
+ ["%" format (#+ format)]
+ ["." encoding (#+ Encoding)]]]
+ [type
+ abstract]]])
+
+(abstract: #export MIME
+ Text
+
+ {#doc "Multipurpose Internet Mail Extensions"}
+
+ (def: #export mime
+ (-> Text MIME)
+ (|>> :abstraction))
+
+ (def: #export name
+ (-> MIME Text)
+ (|>> :representation))
+ )
+
+## https://developer.mozilla.org/en-US/docs/Web/HTTP/Basics_of_HTTP/MIME_types/Complete_list_of_MIME_types
+(template [<name> <type>]
+ [(def: #export <name> MIME (..mime <type>))]
+
+ [aac-audio "audio/aac"]
+ [abiword "application/x-abiword"]
+ [avi "video/x-msvideo"]
+ [amazon-kindle-ebook "application/vnd.amazon.ebook"]
+ [binary "application/octet-stream"]
+ [bitmap "image/bmp"]
+ [bzip "application/x-bzip"]
+ [bzip2 "application/x-bzip2"]
+ [c-shell "application/x-csh"]
+ [css "text/css"]
+ [csv "text/csv"]
+ [microsoft-word "application/msword"]
+ [microsoft-word-openxml "application/vnd.openxmlformats-officedocument.wordprocessingml.document"]
+ [ms-embedded-opentype-fonts "application/vnd.ms-fontobject"]
+ [epub "application/epub+zip"]
+ [ecmascript "application/ecmascript"]
+ [gif "image/gif"]
+ [html "text/html"]
+ [icon "image/x-icon"]
+ [icalendar "text/calendar"]
+ [jar "application/java-archive"]
+ [jpeg "image/jpeg"]
+ [javascript "application/javascript"]
+ [json "application/json"]
+ [midi "audio/midi"]
+ [mpeg "video/mpeg"]
+ [apple-installer-package "application/vnd.apple.installer+xml"]
+ [opendocument-presentation "application/vnd.oasis.opendocument.presentation"]
+ [opendocument-spreadsheet "application/vnd.oasis.opendocument.spreadsheet"]
+ [opendocument-text "application/vnd.oasis.opendocument.text"]
+ [ogg-audio "audio/ogg"]
+ [ogg-video "video/ogg"]
+ [ogg "application/ogg"]
+ [opentype-font "font/otf"]
+ [png "image/png"]
+ [pdf "application/pdf"]
+ [microsoft-powerpoint "application/vnd.ms-powerpoint"]
+ [microsoft-powerpoint-openxml "application/vnd.openxmlformats-officedocument.presentationml.presentation"]
+ [rar "application/x-rar-compressed"]
+ [rtf "application/rtf"]
+ [bourne-shell "application/x-sh"]
+ [svg "image/svg+xml"]
+ [flash "application/x-shockwave-flash"]
+ [tar "application/x-tar"]
+ [tiff "image/tiff"]
+ [typescript "application/typescript"]
+ [truetype-font "font/ttf"]
+ [microsoft-visio "application/vnd.visio"]
+ [wav "audio/wav"]
+ [webm-audio "audio/webm"]
+ [webm-video "video/webm"]
+ [webp "image/webp"]
+ [woff "font/woff"]
+ [woff2 "font/woff2"]
+ [xhtml "application/xhtml+xml"]
+ [microsoft-excel "application/vnd.ms-excel"]
+ [microsoft-excel-openxml "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"]
+ [xml "application/xml"]
+ [xul "application/vnd.mozilla.xul+xml"]
+ [zip "application/zip"]
+ [!3gpp-audio "audio/3gpp"]
+ [!3gpp "video/3gpp"]
+ [!3gpp2-audio "audio/3gpp2"]
+ [!3gpp2 "video/3gpp2"]
+ [!7z "application/x-7z-compressed"]
+ )
+
+(def: #export (text encoding)
+ (-> Encoding MIME)
+ (..mime (format "text/plain; charset=" text.double-quote (encoding.name encoding) text.double-quote)))
+
+(def: #export utf-8 MIME (..text encoding.utf-8))
diff --git a/stdlib/source/library/lux/world/net/http/query.lux b/stdlib/source/library/lux/world/net/http/query.lux
new file mode 100644
index 000000000..b6b8936b7
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/query.lux
@@ -0,0 +1,65 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ pipe
+ [monad (#+ do)]
+ ["." try (#+ Try)]
+ ["p" parser
+ ["l" text (#+ Parser)]]]
+ [data
+ [number
+ ["." nat]]
+ ["." text
+ ["%" format (#+ format)]]
+ [format
+ ["." context (#+ Context)]]
+ [collection
+ ["." dictionary]]]]])
+
+(def: component
+ (Parser Text)
+ (p.rec
+ (function (_ component)
+ (do {! p.monad}
+ [head (l.some (l.none-of "+%&;"))]
+ ($_ p.either
+ (p.after (p.either l.end
+ (l.this "&"))
+ (wrap head))
+ (do !
+ [_ (l.this "+")
+ tail component]
+ (wrap (format head " " tail)))
+ (do !
+ [_ (l.this "%")
+ code (|> (l.exactly 2 l.hexadecimal)
+ (p.codec nat.hex)
+ (\ ! map text.from-code))
+ tail component]
+ (wrap (format head code tail))))))))
+
+(def: (form context)
+ (-> Context (Parser Context))
+ ($_ p.either
+ (do p.monad
+ [_ l.end]
+ (wrap context))
+ (do {! p.monad}
+ [key (l.some (l.none-of "=&;"))
+ key (l.local key ..component)]
+ (p.either (do !
+ [_ (l.this "=")
+ value ..component]
+ (form (dictionary.put key value context)))
+ (do !
+ [_ ($_ p.or
+ (l.one-of "&;")
+ l.end)]
+ (form (dictionary.put key "" context)))))
+ ## if invalid form data, just stop parsing...
+ (\ p.monad wrap context)))
+
+(def: #export (parameters raw)
+ (-> Text (Try Context))
+ (l.run raw (..form context.empty)))
diff --git a/stdlib/source/library/lux/world/net/http/request.lux b/stdlib/source/library/lux/world/net/http/request.lux
new file mode 100644
index 000000000..4a6911798
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/request.lux
@@ -0,0 +1,128 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ pipe
+ ["." monad (#+ do)]
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]
+ ["." frp]]
+ [parser
+ ["<.>" json]]]
+ [data
+ ["." maybe]
+ ["." number
+ ["n" nat]]
+ ["." text
+ ["." encoding]]
+ [format
+ ["." json (#+ JSON)]
+ ["." context (#+ Context Property)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." dictionary]]]
+ [world
+ ["." binary (#+ Binary)]]]]
+ ["." // (#+ Body Response Server)
+ ["#." response]
+ ["#." query]
+ ["#." cookie]])
+
+(def: (merge inputs)
+ (-> (List Binary) Binary)
+ (let [[_ output] (try.assume
+ (monad.fold try.monad
+ (function (_ input [offset output])
+ (let [amount (binary.size input)]
+ (\ try.functor map (|>> [(n.+ amount offset)])
+ (binary.copy amount 0 input offset output))))
+ [0 (|> inputs
+ (list\map binary.size)
+ (list\fold n.+ 0)
+ binary.create)]
+ inputs))]
+ output))
+
+(def: (read-text-body body)
+ (-> Body (Promise (Try Text)))
+ (do promise.monad
+ [blobs (frp.consume body)]
+ (wrap (\ encoding.utf8 decode (merge blobs)))))
+
+(def: failure (//response.bad-request ""))
+
+(def: #export (json reader server)
+ (All [a] (-> (<json>.Reader a) (-> a Server) Server))
+ (function (_ (^@ request [identification protocol resource message]))
+ (do promise.monad
+ [?raw (read-text-body (get@ #//.body message))]
+ (case (do try.monad
+ [raw ?raw
+ content (\ json.codec decode raw)]
+ (json.run content reader))
+ (#try.Success input)
+ (server input request)
+
+ (#try.Failure error)
+ (promise.resolved ..failure)))))
+
+(def: #export (text server)
+ (-> (-> Text Server) Server)
+ (function (_ (^@ request [identification protocol resource message]))
+ (do promise.monad
+ [?raw (read-text-body (get@ #//.body message))]
+ (case ?raw
+ (#try.Success content)
+ (server content request)
+
+ (#try.Failure error)
+ (promise.resolved ..failure)))))
+
+(def: #export (query property server)
+ (All [a] (-> (Property a) (-> a Server) Server))
+ (function (_ [identification protocol resource message])
+ (let [full (get@ #//.uri resource)
+ [uri query] (|> full
+ (text.split-with "?")
+ (maybe.default [full ""]))]
+ (case (do try.monad
+ [query (//query.parameters query)
+ input (context.run query property)]
+ (wrap [[identification protocol (set@ #//.uri uri resource) message]
+ input]))
+ (#try.Success [request input])
+ (server input request)
+
+ (#try.Failure error)
+ (promise.resolved ..failure)))))
+
+(def: #export (form property server)
+ (All [a] (-> (Property a) (-> a Server) Server))
+ (function (_ (^@ request [identification protocol resource message]))
+ (do promise.monad
+ [?body (read-text-body (get@ #//.body message))]
+ (case (do try.monad
+ [body ?body
+ form (//query.parameters body)]
+ (context.run form property))
+ (#try.Success input)
+ (server input request)
+
+ (#try.Failure error)
+ (promise.resolved ..failure)))))
+
+(def: #export (cookies property server)
+ (All [a] (-> (Property a) (-> a Server) Server))
+ (function (_ (^@ request [identification protocol resource message]))
+ (case (do try.monad
+ [cookies (|> (get@ #//.headers message)
+ (dictionary.get "Cookie")
+ (maybe.default "")
+ //cookie.get)]
+ (context.run cookies property))
+ (#try.Success input)
+ (server input request)
+
+ (#try.Failure error)
+ (promise.resolved ..failure))))
diff --git a/stdlib/source/library/lux/world/net/http/response.lux b/stdlib/source/library/lux/world/net/http/response.lux
new file mode 100644
index 000000000..0ca825a44
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/response.lux
@@ -0,0 +1,74 @@
+(.module:
+ [library
+ [lux (#- static)
+ [control
+ [concurrency
+ ["." promise]
+ ["." frp ("#\." monad)]]]
+ [data
+ ["." text
+ ["." encoding]]
+ [format
+ ["." html]
+ ["." css (#+ CSS)]
+ ["." context]
+ ["." json (#+ JSON) ("#\." codec)]]]
+ ["." io]
+ [world
+ ["." binary (#+ Binary)]]]]
+ ["." // (#+ Status Body Response Server)
+ ["." status]
+ ["." mime (#+ MIME)]
+ ["." header]
+ [// (#+ URL)]])
+
+(def: #export (static response)
+ (-> Response Server)
+ (function (_ request)
+ (promise.resolved response)))
+
+(def: #export empty
+ (-> Status Response)
+ (let [body (frp\wrap (\ encoding.utf8 encode ""))]
+ (function (_ status)
+ [status
+ {#//.headers (|> context.empty
+ (header.content-length 0)
+ (header.content-type mime.utf-8))
+ #//.body body}])))
+
+(def: #export (temporary-redirect to)
+ (-> URL Response)
+ (let [[status message] (..empty status.temporary-redirect)]
+ [status (update@ #//.headers (header.location to) message)]))
+
+(def: #export not-found
+ Response
+ (..empty status.not-found))
+
+(def: #export (content status type data)
+ (-> Status MIME Binary Response)
+ [status
+ {#//.headers (|> context.empty
+ (header.content-length (binary.size data))
+ (header.content-type type))
+ #//.body (frp\wrap data)}])
+
+(def: #export bad-request
+ (-> Text Response)
+ (|>> (\ encoding.utf8 encode) (content status.bad-request mime.utf-8)))
+
+(def: #export ok
+ (-> MIME Binary Response)
+ (content status.ok))
+
+(template [<name> <type> <mime> <pre>]
+ [(def: #export <name>
+ (-> <type> Response)
+ (|>> <pre> (\ encoding.utf8 encode) (..ok <mime>)))]
+
+ [text Text mime.utf-8 (<|)]
+ [html html.Document mime.html html.html]
+ [css CSS mime.css css.css]
+ [json JSON mime.json json\encode]
+ )
diff --git a/stdlib/source/library/lux/world/net/http/route.lux b/stdlib/source/library/lux/world/net/http/route.lux
new file mode 100644
index 000000000..456ed9e36
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/route.lux
@@ -0,0 +1,74 @@
+(.module:
+ [library
+ [lux (#- or)
+ [control
+ [monad (#+ do)]
+ [concurrency
+ ["." promise]]]
+ [data
+ ["." maybe]
+ ["." text]
+ [number
+ ["n" nat]]]]]
+ ["." // (#+ URI Server)
+ ["#." status]
+ ["#." response]])
+
+(template [<scheme> <name>]
+ [(def: #export (<name> server)
+ (-> Server Server)
+ (function (_ (^@ request [identification protocol resource message]))
+ (case (get@ #//.scheme protocol)
+ <scheme>
+ (server request)
+
+ _
+ (promise.resolved //response.not-found))))]
+
+ [#//.HTTP http]
+ [#//.HTTPS https]
+ )
+
+(template [<method> <name>]
+ [(def: #export (<name> server)
+ (-> Server Server)
+ (function (_ (^@ request [identification protocol resource message]))
+ (case (get@ #//.method resource)
+ <method>
+ (server request)
+
+ _
+ (promise.resolved //response.not-found))))]
+
+ [#//.Get get]
+ [#//.Post post]
+ [#//.Put put]
+ [#//.Patch patch]
+ [#//.Delete delete]
+ [#//.Head head]
+ [#//.Connect connect]
+ [#//.Options options]
+ [#//.Trace trace]
+ )
+
+(def: #export (uri path server)
+ (-> URI Server Server)
+ (function (_ [identification protocol resource message])
+ (if (text.starts-with? path (get@ #//.uri resource))
+ (server [identification
+ protocol
+ (update@ #//.uri
+ (|>> (text.clip' (text.size path)) maybe.assume)
+ resource)
+ message])
+ (promise.resolved //response.not-found))))
+
+(def: #export (or primary alternative)
+ (-> Server Server Server)
+ (function (_ request)
+ (do promise.monad
+ [response (primary request)
+ #let [[status message] response]]
+ (if (n.= //status.not-found status)
+ (alternative request)
+ (wrap response)))))
diff --git a/stdlib/source/library/lux/world/net/http/status.lux b/stdlib/source/library/lux/world/net/http/status.lux
new file mode 100644
index 000000000..fe3f7d90d
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/status.lux
@@ -0,0 +1,83 @@
+(.module:
+ [library
+ [lux #*]]
+ [// (#+ Status)])
+
+## https://en.wikipedia.org/wiki/List_of_HTTP_status_codes
+(template [<status> <name>]
+ [(def: #export <name>
+ Status
+ <status>)]
+
+ ## 1xx Informational response
+ [100 continue]
+ [101 switching_protocols]
+ [102 processing]
+ [103 early_hints]
+
+ ## 2xx Success
+ [200 ok]
+ [201 created]
+ [202 accepted]
+ [203 non_authoritative_information]
+ [204 no_content]
+ [205 reset_content]
+ [206 partial_content]
+ [207 multi_status]
+ [208 already_reported]
+ [226 im_used]
+
+ ## 3xx Redirection
+ [300 multiple_choices]
+ [301 moved_permanently]
+ [302 found]
+ [303 see_other]
+ [304 not_modified]
+ [305 use_proxy]
+ [306 switch_proxy]
+ [307 temporary_redirect]
+ [308 permanent_redirect]
+
+ ## 4xx Client errors
+ [400 bad_request]
+ [401 unauthorized]
+ [402 payment_required]
+ [403 forbidden]
+ [404 not_found]
+ [405 method_not_allowed]
+ [406 not_acceptable]
+ [407 proxy_authentication_required]
+ [408 request_timeout]
+ [409 conflict]
+ [410 gone]
+ [411 length_required]
+ [412 precondition_failed]
+ [413 payload_too_large]
+ [414 uri_too_long]
+ [415 unsupported_media_type]
+ [416 range_not_satisfiable]
+ [417 expectation_failed]
+ [418 im_a_teapot]
+ [421 misdirected_request]
+ [422 unprocessable_entity]
+ [423 locked]
+ [424 failed_dependency]
+ [426 upgrade_required]
+ [428 precondition_required]
+ [429 too_many_requests]
+ [431 request_header_fields_too_large]
+ [451 unavailable_for_legal_reasons]
+
+ ## 5xx Server errors
+ [500 internal_server_error]
+ [501 not_implemented]
+ [502 bad_gateway]
+ [503 service_unavailable]
+ [504 gateway_timeout]
+ [505 http_version_not_supported]
+ [506 variant_also_negotiates]
+ [507 insufficient_storage]
+ [508 loop_detected]
+ [510 not_extended]
+ [511 network_authentication_required]
+ )
diff --git a/stdlib/source/library/lux/world/net/http/version.lux b/stdlib/source/library/lux/world/net/http/version.lux
new file mode 100644
index 000000000..2443fda12
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/version.lux
@@ -0,0 +1,13 @@
+(.module:
+ [library
+ [lux #*]]
+ [// (#+ Version)])
+
+(template [<name> <version>]
+ [(def: #export <name> Version <version>)]
+
+ [v0_9 "0.9"]
+ [v1_0 "1.0"]
+ [v1_1 "1.1"]
+ [v2_0 "2.0"]
+ )
diff --git a/stdlib/source/library/lux/world/net/uri.lux b/stdlib/source/library/lux/world/net/uri.lux
new file mode 100644
index 000000000..2c43cbbd3
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/uri.lux
@@ -0,0 +1,9 @@
+(.module:
+ [library
+ [lux #*]])
+
+(type: #export URI
+ Text)
+
+(def: #export separator
+ "/")
diff --git a/stdlib/source/library/lux/world/output/video/resolution.lux b/stdlib/source/library/lux/world/output/video/resolution.lux
new file mode 100644
index 000000000..24f48182c
--- /dev/null
+++ b/stdlib/source/library/lux/world/output/video/resolution.lux
@@ -0,0 +1,47 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]]
+ [data
+ ["." product]]
+ [math
+ [number
+ ["." nat]]]]])
+
+(type: #export Resolution
+ {#width Nat
+ #height Nat})
+
+(def: #export hash
+ (Hash Resolution)
+ (product.hash nat.hash nat.hash))
+
+(def: #export equivalence
+ (Equivalence Resolution)
+ (\ ..hash &equivalence))
+
+## https://en.wikipedia.org/wiki/Display_resolution#Common_display_resolutions
+(template [<name> <width> <height>]
+ [(def: #export <name>
+ Resolution
+ {#width <width>
+ #height <height>})]
+
+ [svga 800 600]
+ [wsvga 1024 600]
+ [xga 1024 768]
+ [xga+ 1152 864]
+ [wxga/16:9 1280 720]
+ [wxga/5:3 1280 768]
+ [wxga/16:10 1280 800]
+ [sxga 1280 1024]
+ [wxga+ 1440 900]
+ [hd+ 1600 900]
+ [wsxga+ 1680 1050]
+ [fhd 1920 1080]
+ [wuxga 1920 1200]
+ [wqhd 2560 1440]
+ [uhd-4k 3840 2160]
+ )
diff --git a/stdlib/source/library/lux/world/program.lux b/stdlib/source/library/lux/world/program.lux
new file mode 100644
index 000000000..8c8a0ac05
--- /dev/null
+++ b/stdlib/source/library/lux/world/program.lux
@@ -0,0 +1,451 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ ["." ffi (#+ import:)]
+ [abstract
+ ["." monad (#+ Monad do)]]
+ [control
+ ["." function]
+ ["." io (#+ IO)]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ [concurrency
+ ["." atom]
+ ["." promise (#+ Promise)]]
+ [parser
+ ["." environment (#+ Environment)]]]
+ [data
+ ["." bit ("#\." equivalence)]
+ ["." maybe]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." array (#+ Array)]
+ ["." dictionary (#+ Dictionary)]
+ ["." list ("#\." functor)]]]
+ ["." macro
+ ["." template]]
+ [math
+ [number
+ ["i" int]]]
+ [type
+ abstract]]]
+ [//
+ [file (#+ Path)]
+ [shell (#+ Exit)]])
+
+(exception: #export (unknown_environment_variable {name Text})
+ (exception.report
+ ["Name" (%.text name)]))
+
+(interface: #export (Program !)
+ (: (-> Any (! (List Text)))
+ available_variables)
+ (: (-> Text (! (Try Text)))
+ variable)
+ (: Path
+ home)
+ (: Path
+ directory)
+ (: (-> Exit (! Nothing))
+ exit))
+
+(def: #export (environment monad program)
+ (All [!] (-> (Monad !) (Program !) (! Environment)))
+ (do {! monad}
+ [variables (\ program available_variables [])
+ entries (monad.map ! (function (_ name)
+ (\ ! map (|>> [name]) (\ program variable name)))
+ variables)]
+ (wrap (|> entries
+ (list.all (function (_ [name value])
+ (case value
+ (#try.Success value)
+ (#.Some [name value])
+
+ (#try.Failure _)
+ #.None)))
+ (dictionary.from_list text.hash)))))
+
+(`` (implementation: #export (async program)
+ (-> (Program IO) (Program Promise))
+
+ (~~ (template [<method>]
+ [(def: <method>
+ (\ program <method>))]
+
+ [home]
+ [directory]
+ ))
+
+ (~~ (template [<method>]
+ [(def: <method>
+ (|>> (\ program <method>) promise.future))]
+
+ [available_variables]
+ [variable]
+ [exit]
+ ))))
+
+(def: #export (mock environment home directory)
+ (-> Environment Path Path (Program IO))
+ (let [@dead? (atom.atom false)]
+ (implementation
+ (def: available_variables
+ (function.constant (io.io (dictionary.keys environment))))
+ (def: (variable name)
+ (io.io (case (dictionary.get name environment)
+ (#.Some value)
+ (#try.Success value)
+
+ #.None
+ (exception.throw ..unknown_environment_variable [name]))))
+ (def: home
+ home)
+ (def: directory
+ directory)
+ (def: (exit code)
+ (io.io (error! (%.int code)))))))
+
+## Do not trust the values of environment variables
+## https://wiki.sei.cmu.edu/confluence/display/java/ENV02-J.+Do+not+trust+the+values+of+environment+variables
+
+(with_expansions [<jvm> (as_is (import: java/lang/String)
+
+ (import: (java/util/Iterator a)
+ ["#::."
+ (hasNext [] boolean)
+ (next [] a)])
+
+ (import: (java/util/Set a)
+ ["#::."
+ (iterator [] (java/util/Iterator a))])
+
+ (import: (java/util/Map k v)
+ ["#::."
+ (keySet [] (java/util/Set k))])
+
+ (import: java/lang/System
+ ["#::."
+ (#static getenv [] (java/util/Map java/lang/String java/lang/String))
+ (#static getenv #as resolveEnv [java/lang/String] #io #? java/lang/String)
+ (#static getProperty [java/lang/String] #? java/lang/String)
+ (#static exit [int] #io void)])
+
+ (def: (jvm\\consume iterator)
+ (All [a] (-> (java/util/Iterator a) (List a)))
+ (if (java/util/Iterator::hasNext iterator)
+ (#.Cons (java/util/Iterator::next iterator)
+ (jvm\\consume iterator))
+ #.Nil))
+ )]
+ (for {@.old (as_is <jvm>)
+ @.jvm (as_is <jvm>)
+ @.js (as_is (def: default_exit!
+ (-> Exit (IO Nothing))
+ (|>> %.int error! io.io))
+
+ (import: NodeJs_Process
+ ["#::."
+ (exit [ffi.Number] #io Nothing)
+ (cwd [] #io Path)])
+
+ (def: (exit_node_js! code)
+ (-> Exit (IO Nothing))
+ (case (ffi.constant ..NodeJs_Process [process])
+ (#.Some process)
+ (NodeJs_Process::exit (i.frac code) process)
+
+ #.None
+ (..default_exit! code)))
+
+ (import: Browser_Window
+ ["#::."
+ (close [] Nothing)])
+
+ (import: Browser_Location
+ ["#::."
+ (reload [] Nothing)])
+
+ (def: (exit_browser! code)
+ (-> Exit (IO Nothing))
+ (case [(ffi.constant ..Browser_Window [window])
+ (ffi.constant ..Browser_Location [location])]
+ [(#.Some window) (#.Some location)]
+ (exec
+ (Browser_Window::close [] window)
+ (Browser_Location::reload [] location)
+ (..default_exit! code))
+
+ [(#.Some window) #.None]
+ (exec
+ (Browser_Window::close [] window)
+ (..default_exit! code))
+
+ [#.None (#.Some location)]
+ (exec
+ (Browser_Location::reload [] location)
+ (..default_exit! code))
+
+ [#.None #.None]
+ (..default_exit! code)))
+
+ (import: Object
+ ["#::."
+ (#static entries [Object] (Array (Array ffi.String)))])
+
+ (import: NodeJs_OS
+ ["#::."
+ (homedir [] #io Path)])
+
+ (template [<name> <path>]
+ [(def: (<name> _)
+ (-> [] (Maybe (-> ffi.String Any)))
+ (ffi.constant (-> ffi.String Any) <path>))]
+
+ [normal_require [require]]
+ [global_require [global require]]
+ [process_load [global process mainModule constructor _load]]
+ )
+
+ (def: (require _)
+ (-> [] (-> ffi.String Any))
+ (case [(normal_require []) (global_require []) (process_load [])]
+ (^or [(#.Some require) _ _]
+ [_ (#.Some require) _]
+ [_ _ (#.Some require)])
+ require
+
+ _
+ (undefined))))
+ @.python (as_is (import: os
+ ["#::."
+ (#static getcwd [] #io ffi.String)
+ (#static _exit [ffi.Integer] #io Nothing)])
+
+ (import: os/path
+ ["#::."
+ (#static expanduser [ffi.String] #io ffi.String)])
+
+ (import: os/environ
+ ["#::."
+ (#static keys [] #io (Array ffi.String))
+ (#static get [ffi.String] #io #? ffi.String)]))
+ @.lua (as_is (ffi.import: LuaFile
+ ["#::."
+ (read [ffi.String] #io #? ffi.String)
+ (close [] #io ffi.Boolean)])
+
+ (ffi.import: (io/popen [ffi.String] #io #try #? LuaFile))
+ (ffi.import: (os/getenv [ffi.String] #io #? ffi.String))
+ (ffi.import: (os/exit [ffi.Integer] #io Nothing))
+
+ (def: (run_command default command)
+ (-> Text Text (IO Text))
+ (do {! io.monad}
+ [outcome (io/popen [command])]
+ (case outcome
+ (#try.Success outcome)
+ (case outcome
+ (#.Some file)
+ (do !
+ [?output (LuaFile::read ["*l"] file)
+ _ (LuaFile::close [] file)]
+ (wrap (maybe.default default ?output)))
+
+ #.None
+ (wrap default))
+
+ (#try.Failure _)
+ (wrap default)))))
+ @.ruby (as_is (ffi.import: Env #as RubyEnv
+ ["#::."
+ (#static keys [] (Array Text))
+ (#static fetch [Text] #io #? Text)])
+
+ (ffi.import: "fileutils" FileUtils #as RubyFileUtils
+ ["#::."
+ (#static pwd Path)])
+
+ (ffi.import: Dir #as RubyDir
+ ["#::."
+ (#static home Path)])
+
+ (ffi.import: Kernel #as RubyKernel
+ ["#::."
+ (#static exit [Int] #io Nothing)]))
+
+ ## @.php
+ ## (as_is (ffi.import: (exit [Int] #io Nothing))
+ ## ## https://www.php.net/manual/en/function.exit.php
+ ## (ffi.import: (getcwd [] #io ffi.String))
+ ## ## https://www.php.net/manual/en/function.getcwd.php
+ ## (ffi.import: (getenv #as getenv/1 [ffi.String] #io ffi.String))
+ ## (ffi.import: (getenv #as getenv/0 [] #io (Array ffi.String)))
+ ## ## https://www.php.net/manual/en/function.getenv.php
+ ## ## https://www.php.net/manual/en/function.array-keys.php
+ ## (ffi.import: (array_keys [(Array ffi.String)] (Array ffi.String)))
+ ## )
+
+ ## @.scheme
+ ## (as_is (ffi.import: (exit [Int] #io Nothing))
+ ## ## https://srfi.schemers.org/srfi-98/srfi-98.html
+ ## (abstract: Pair Any)
+ ## (abstract: PList Any)
+ ## (ffi.import: (get-environment-variables [] #io PList))
+ ## (ffi.import: (car [Pair] Text))
+ ## (ffi.import: (cdr [Pair] Text))
+ ## (ffi.import: (car #as head [PList] Pair))
+ ## (ffi.import: (cdr #as tail [PList] PList)))
+ }
+ (as_is)))
+
+(implementation: #export default
+ (Program IO)
+
+ (def: (available_variables _)
+ (with_expansions [<jvm> (io.io (|> (java/lang/System::getenv)
+ java/util/Map::keySet
+ java/util/Set::iterator
+ ..jvm\\consume))]
+ (for {@.old <jvm>
+ @.jvm <jvm>
+ @.js (io.io (if ffi.on_node_js?
+ (case (ffi.constant Object [process env])
+ (#.Some process/env)
+ (|> (Object::entries [process/env])
+ array.to_list
+ (list\map (|>> (array.read 0) maybe.assume)))
+
+ #.None
+ (list))
+ (list)))
+ @.python (\ io.monad map array.to_list (os/environ::keys []))
+ ## Lua offers no way to get all the environment variables available.
+ @.lua (io.io (list))
+ @.ruby (|> (RubyEnv::keys [])
+ array.to_list
+ io.io)
+ ## @.php (do io.monad
+ ## [environment (..getenv/0 [])]
+ ## (wrap (|> environment
+ ## ..array_keys
+ ## array.to_list
+ ## (list\map (function (_ variable)
+ ## [variable ("php array read" (:as Nat variable) environment)]))
+ ## (dictionary.from_list text.hash))))
+ ## @.scheme (do io.monad
+ ## [input (..get-environment-variables [])]
+ ## (loop [input input
+ ## output environment.empty]
+ ## (if ("scheme object nil?" input)
+ ## (wrap output)
+ ## (let [entry (..head input)]
+ ## (recur (..tail input)
+ ## (dictionary.put (..car entry) (..cdr entry) output))))))
+ })))
+
+ (def: (variable name)
+ (template.let [(!fetch <method>)
+ [(do io.monad
+ [value (<method> name)]
+ (wrap (case value
+ (#.Some value)
+ (#try.Success value)
+
+ #.None
+ (exception.throw ..unknown_environment_variable [name]))))]]
+ (with_expansions [<jvm> (!fetch java/lang/System::resolveEnv)]
+ (for {@.old <jvm>
+ @.jvm <jvm>
+ @.js (io.io (if ffi.on_node_js?
+ (case (do maybe.monad
+ [process/env (ffi.constant Object [process env])]
+ (array.read (:as Nat name)
+ (:as (Array Text) process/env)))
+ (#.Some value)
+ (#try.Success value)
+
+ #.None
+ (exception.throw ..unknown_environment_variable [name]))
+ (exception.throw ..unknown_environment_variable [name])))
+ @.python (!fetch os/environ::get)
+ @.lua (!fetch os/getenv)
+ @.ruby (!fetch RubyEnv::fetch)
+ }))))
+
+ (def: home
+ (io.run
+ (with_expansions [<default> (io.io "~")
+ <jvm> (io.io (maybe.default "" (java/lang/System::getProperty "user.home")))]
+ (for {@.old <jvm>
+ @.jvm <jvm>
+ @.js (if ffi.on_node_js?
+ (|> (..require [] "os")
+ (:as NodeJs_OS)
+ (NodeJs_OS::homedir []))
+ <default>)
+ @.python (os/path::expanduser ["~"])
+ @.lua (..run_command "~" "echo ~")
+ @.ruby (io.io (RubyDir::home))
+ ## @.php (do io.monad
+ ## [output (..getenv/1 ["HOME"])]
+ ## (wrap (if (bit\= false (:as Bit output))
+ ## "~"
+ ## output)))
+ }
+ ## TODO: Replace dummy implementation.
+ <default>))))
+
+ (def: directory
+ (io.run
+ (with_expansions [<default> "."
+ <jvm> (io.io (maybe.default "" (java/lang/System::getProperty "user.dir")))]
+ (for {@.old <jvm>
+ @.jvm <jvm>
+ @.js (if ffi.on_node_js?
+ (case (ffi.constant ..NodeJs_Process [process])
+ (#.Some process)
+ (NodeJs_Process::cwd [] process)
+
+ #.None
+ (io.io <default>))
+ (io.io <default>))
+ @.python (os::getcwd [])
+ @.lua (do io.monad
+ [#let [default <default>]
+ on_windows (..run_command default "cd")]
+ (if (is? default on_windows)
+ (..run_command default "pwd")
+ (wrap on_windows)))
+ @.ruby (io.io (RubyFileUtils::pwd))
+ ## @.php (do io.monad
+ ## [output (..getcwd [])]
+ ## (wrap (if (bit\= false (:as Bit output))
+ ## "."
+ ## output)))
+ }
+ ## TODO: Replace dummy implementation.
+ (io.io <default>)))))
+
+ (def: (exit code)
+ (with_expansions [<jvm> (do io.monad
+ [_ (java/lang/System::exit code)]
+ (wrap (undefined)))]
+ (for {@.old <jvm>
+ @.jvm <jvm>
+ @.js (cond ffi.on_node_js?
+ (..exit_node_js! code)
+
+ ffi.on_browser?
+ (..exit_browser! code)
+
+ ## else
+ (..default_exit! code))
+ @.python (os::_exit [code])
+ @.lua (os/exit [code])
+ @.ruby (RubyKernel::exit [code])
+ ## @.php (..exit [code])
+ ## @.scheme (..exit [code])
+ }))))
diff --git a/stdlib/source/library/lux/world/service/authentication.lux b/stdlib/source/library/lux/world/service/authentication.lux
new file mode 100644
index 000000000..4c66ddc1c
--- /dev/null
+++ b/stdlib/source/library/lux/world/service/authentication.lux
@@ -0,0 +1,25 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ [try (#+ Try)]
+ [security
+ [capability (#+ Capability)]]]]])
+
+(type: #export (Can-Register ! account secret value)
+ (Capability [account secret value] (! (Try Any))))
+
+(type: #export (Can-Authenticate ! account secret value)
+ (Capability [account secret] (! (Try value))))
+
+(type: #export (Can-Reset ! account secret)
+ (Capability [account secret] (! (Try Any))))
+
+(type: #export (Can-Forget ! account)
+ (Capability [account] (! (Try Any))))
+
+(type: #export (Service ! account secret value)
+ {#can-register (Can-Register ! account secret value)
+ #can-authenticate (Can-Authenticate ! account secret value)
+ #can-reset (Can-Reset ! account secret)
+ #can-forget (Can-Forget ! account)})
diff --git a/stdlib/source/library/lux/world/service/crud.lux b/stdlib/source/library/lux/world/service/crud.lux
new file mode 100644
index 000000000..bd47744f4
--- /dev/null
+++ b/stdlib/source/library/lux/world/service/crud.lux
@@ -0,0 +1,33 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ ["." try (#+ Try)]
+ [security
+ ["!" capability (#+ capability:)]]]
+ [time
+ ["." instant (#+ Instant)]]]])
+
+(type: #export ID Nat)
+
+(type: #export Time
+ {#created Instant
+ #updated Instant})
+
+(capability: #export (Can-Create ! entity)
+ (can-create [Instant entity] (! (Try ID))))
+
+(capability: #export (Can-Retrieve ! entity)
+ (can-retrieve ID (! (Try [Time entity]))))
+
+(capability: #export (Can-Update ! entity)
+ (can-update [ID Instant entity] (! (Try Any))))
+
+(capability: #export (Can-Delete ! entity)
+ (can-delete ID (! (Try Any))))
+
+(type: #export (CRUD ! entity)
+ {#can-create (Can-Create ! entity)
+ #can-retrieve (Can-Retrieve ! entity)
+ #can-update (Can-Update ! entity)
+ #can-delete (Can-Delete ! entity)})
diff --git a/stdlib/source/library/lux/world/service/inventory.lux b/stdlib/source/library/lux/world/service/inventory.lux
new file mode 100644
index 000000000..b6f023075
--- /dev/null
+++ b/stdlib/source/library/lux/world/service/inventory.lux
@@ -0,0 +1,31 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ [try (#+ Try)]
+ [security
+ ["!" capability (#+ capability:)]]]]])
+
+(type: #export ID Nat)
+
+(type: #export Ownership
+ {#owner ID
+ #property ID})
+
+(capability: #export (Can-Own !)
+ (can-own Ownership (! (Try Any))))
+
+(capability: #export (Can-Disown !)
+ (can-disown Ownership (! (Try Any))))
+
+(capability: #export (Can-Check !)
+ (can-check Ownership (! (Try Bit))))
+
+(capability: #export (Can-List-Property !)
+ (can-list-property ID (! (Try (List ID)))))
+
+(type: #export (Inventory !)
+ {#can-own (Can-Own !)
+ #can-disown (Can-Disown !)
+ #can-check (Can-Check !)
+ #can-list-property (Can-List-Property !)})
diff --git a/stdlib/source/library/lux/world/service/journal.lux b/stdlib/source/library/lux/world/service/journal.lux
new file mode 100644
index 000000000..ba42af209
--- /dev/null
+++ b/stdlib/source/library/lux/world/service/journal.lux
@@ -0,0 +1,51 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ [equivalence (#+ Equivalence)]
+ [interval (#+ Interval)]
+ [try (#+ Try)]
+ [security
+ ["!" capability (#+ capability:)]]]
+ [data
+ ["." text ("#\." equivalence)]]
+ [time
+ ["." instant (#+ Instant) ("#\." equivalence)]]]])
+
+(type: #export (Entry a)
+ {#what a
+ #why Text
+ #how Text
+ #who Text
+ #where Text
+ #when Instant})
+
+(type: #export Range
+ (Interval Instant))
+
+(def: #export (range start end)
+ (-> Instant Instant Range)
+ (implementation
+ (def: &enum instant.enum)
+ (def: bottom start)
+ (def: top end)))
+
+(implementation: #export (equivalence (^open "_\."))
+ (All [a] (-> (Equivalence a) (Equivalence (Entry a))))
+ (def: (= reference sample)
+ (and (_\= (get@ #what reference) (get@ #what sample))
+ (text\= (get@ #why reference) (get@ #why sample))
+ (text\= (get@ #how reference) (get@ #how sample))
+ (text\= (get@ #who reference) (get@ #who sample))
+ (text\= (get@ #where reference) (get@ #where sample))
+ (instant\= (get@ #when reference) (get@ #when sample)))))
+
+(capability: #export (Can-Write ! a)
+ (can-write (Entry a) (! (Try Any))))
+
+(capability: #export (Can-Read ! a)
+ (can-read Range (! (Try (List (Entry a))))))
+
+(type: #export (Journal ! a)
+ {#can-write (Can-Write ! a)
+ #can-read (Can-Read ! a)})
diff --git a/stdlib/source/library/lux/world/service/mail.lux b/stdlib/source/library/lux/world/service/mail.lux
new file mode 100644
index 000000000..2b2cc9dd1
--- /dev/null
+++ b/stdlib/source/library/lux/world/service/mail.lux
@@ -0,0 +1,19 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ [try (#+ Try)]
+ [concurrency
+ [frp (#+ Channel)]]
+ [security
+ ["!" capability (#+ capability:)]]]]])
+
+(capability: #export (Can-Send ! address message)
+ (can-send [address message] (! (Try Any))))
+
+(capability: #export (Can-Subscribe ! address message)
+ (can-subscribe [address] (! (Try (Channel message)))))
+
+(type: #export (Service ! address message)
+ {#can-send (Can-Send ! address message)
+ #can-subscribe (Can-Subscribe ! address message)})
diff --git a/stdlib/source/library/lux/world/shell.lux b/stdlib/source/library/lux/world/shell.lux
new file mode 100644
index 000000000..52cd3efd4
--- /dev/null
+++ b/stdlib/source/library/lux/world/shell.lux
@@ -0,0 +1,374 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ ["jvm" ffi (#+ import:)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO)]
+ [security
+ ["?" policy (#+ Context Safety Safe)]]
+ [concurrency
+ ["." atom (#+ Atom)]
+ ["." promise (#+ Promise)]]
+ [parser
+ [environment (#+ Environment)]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." array (#+ Array)]
+ ["." list ("#\." fold functor)]
+ ["." dictionary]]]
+ [math
+ [number (#+ hex)
+ ["n" nat]]]]]
+ [//
+ [file (#+ Path)]])
+
+(type: #export Exit
+ Int)
+
+(template [<code> <name>]
+ [(def: #export <name>
+ Exit
+ <code>)]
+
+ [+0 normal]
+ [+1 error]
+ )
+
+(interface: #export (Process !)
+ (: (-> [] (! (Try Text)))
+ read)
+ (: (-> [] (! (Try Text)))
+ error)
+ (: (-> Text (! (Try Any)))
+ write)
+ (: (-> [] (! (Try Any)))
+ destroy)
+ (: (-> [] (! (Try Exit)))
+ await))
+
+(def: (async_process process)
+ (-> (Process IO) (Process Promise))
+ (`` (implementation
+ (~~ (template [<method>]
+ [(def: <method>
+ (|>> (\ process <method>)
+ promise.future))]
+
+ [read]
+ [error]
+ [write]
+ [destroy]
+ [await]
+ )))))
+
+(type: #export Command
+ Text)
+
+(type: #export Argument
+ Text)
+
+(interface: #export (Shell !)
+ (: (-> [Environment Path Command (List Argument)] (! (Try (Process !))))
+ execute))
+
+(def: #export (async shell)
+ (-> (Shell IO) (Shell Promise))
+ (implementation
+ (def: (execute input)
+ (promise.future
+ (do (try.with io.monad)
+ [process (\ shell execute input)]
+ (wrap (..async_process process)))))))
+
+## https://en.wikipedia.org/wiki/Code_injection#Shell_injection
+(interface: (Policy ?)
+ (: (-> Command (Safe Command ?))
+ command)
+ (: (-> Argument (Safe Argument ?))
+ argument)
+ (: (All [a] (-> (Safe a ?) a))
+ value))
+
+(type: (Sanitizer a)
+ (-> a a))
+
+(type: Replacer
+ (-> Text Text))
+
+(def: (replace bad replacer)
+ (-> Text Replacer (-> Text Text))
+ (text.replace_all bad (replacer bad)))
+
+(def: sanitize_common_command
+ (-> Replacer (Sanitizer Command))
+ (let [x0A (text.from_code (hex "0A"))
+ xFF (text.from_code (hex "FF"))]
+ (function (_ replacer)
+ (|>> (..replace x0A replacer)
+ (..replace xFF replacer)
+ (..replace "\" replacer)
+ (..replace "&" replacer)
+ (..replace "#" replacer)
+ (..replace ";" replacer)
+ (..replace "`" replacer)
+ (..replace "|" replacer)
+ (..replace "*" replacer)
+ (..replace "?" replacer)
+ (..replace "~" replacer)
+ (..replace "^" replacer)
+ (..replace "$" replacer)
+ (..replace "<" replacer) (..replace ">" replacer)
+ (..replace "(" replacer) (..replace ")" replacer)
+ (..replace "[" replacer) (..replace "]" replacer)
+ (..replace "{" replacer) (..replace "}" replacer)))))
+
+(def: (policy sanitize_command sanitize_argument)
+ (Ex [?] (-> (Sanitizer Command) (Sanitizer Argument) (Policy ?)))
+ (?.with_policy
+ (: (Context Safety Policy)
+ (function (_ (^open "?\."))
+ (implementation
+ (def: command (|>> sanitize_command ?\can_upgrade))
+ (def: argument (|>> sanitize_argument ?\can_upgrade))
+ (def: value ?\can_downgrade))))))
+
+(def: unix_policy
+ (let [replacer (: Replacer
+ (|>> (format "\")))
+ sanitize_command (: (Sanitizer Command)
+ (..sanitize_common_command replacer))
+ sanitize_argument (: (Sanitizer Argument)
+ (|>> (..replace "'" replacer)
+ (text.enclose' "'")))]
+ (..policy sanitize_command sanitize_argument)))
+
+(def: windows_policy
+ (let [replacer (: Replacer
+ (function.constant " "))
+ sanitize_command (: (Sanitizer Command)
+ (|>> (..sanitize_common_command replacer)
+ (..replace "%" replacer)
+ (..replace "!" replacer)))
+ sanitize_argument (: (Sanitizer Argument)
+ (|>> (..replace "%" replacer)
+ (..replace "!" replacer)
+ (..replace text.double_quote replacer)
+ (text.enclose' text.double_quote)))]
+ (..policy sanitize_command sanitize_argument)))
+
+(with_expansions [<jvm> (as_is (import: java/lang/String
+ ["#::."
+ (toLowerCase [] java/lang/String)])
+
+ (def: (jvm::arguments_array arguments)
+ (-> (List Argument) (Array java/lang/String))
+ (product.right
+ (list\fold (function (_ argument [idx output])
+ [(inc idx) (jvm.array_write idx
+ (:as java/lang/String argument)
+ output)])
+ [0 (jvm.array java/lang/String (list.size arguments))]
+ arguments)))
+
+ (import: (java/util/Map k v)
+ ["#::."
+ (put [k v] v)])
+
+ (def: (jvm::load_environment input target)
+ (-> Environment
+ (java/util/Map java/lang/String java/lang/String)
+ (java/util/Map java/lang/String java/lang/String))
+ (list\fold (function (_ [key value] target')
+ (exec (java/util/Map::put (:as java/lang/String key)
+ (:as java/lang/String value)
+ target')
+ target'))
+ target
+ (dictionary.entries input)))
+
+ (import: java/io/Reader
+ ["#::."
+ (read [] #io #try int)])
+
+ (import: java/io/BufferedReader
+ ["#::."
+ (new [java/io/Reader])
+ (readLine [] #io #try #? java/lang/String)])
+
+ (import: java/io/InputStream)
+
+ (import: java/io/InputStreamReader
+ ["#::."
+ (new [java/io/InputStream])])
+
+ (import: java/io/OutputStream
+ ["#::."
+ (write [[byte]] #io #try void)])
+
+ (import: java/lang/Process
+ ["#::."
+ (getInputStream [] #io #try java/io/InputStream)
+ (getErrorStream [] #io #try java/io/InputStream)
+ (getOutputStream [] #io #try java/io/OutputStream)
+ (destroy [] #io #try void)
+ (waitFor [] #io #try int)])
+
+ (exception: #export no_more_output)
+
+ (def: (default_process process)
+ (-> java/lang/Process (IO (Try (Process IO))))
+ (do {! (try.with io.monad)}
+ [jvm_input (java/lang/Process::getInputStream process)
+ jvm_error (java/lang/Process::getErrorStream process)
+ jvm_output (java/lang/Process::getOutputStream process)
+ #let [jvm_input (|> jvm_input
+ java/io/InputStreamReader::new
+ java/io/BufferedReader::new)
+ jvm_error (|> jvm_error
+ java/io/InputStreamReader::new
+ java/io/BufferedReader::new)]]
+ (wrap (: (Process IO)
+ (`` (implementation
+ (~~ (template [<name> <stream>]
+ [(def: (<name> _)
+ (do !
+ [output (java/io/BufferedReader::readLine <stream>)]
+ (case output
+ (#.Some output)
+ (wrap output)
+
+ #.None
+ (\ io.monad wrap (exception.throw ..no_more_output [])))))]
+
+ [read jvm_input]
+ [error jvm_error]
+ ))
+ (def: (write message)
+ (java/io/OutputStream::write (\ utf8.codec encode message) jvm_output))
+ (~~ (template [<name> <method>]
+ [(def: (<name> _)
+ (<method> process))]
+
+ [destroy java/lang/Process::destroy]
+ [await java/lang/Process::waitFor]
+ ))))))))
+
+ (import: java/io/File
+ ["#::."
+ (new [java/lang/String])])
+
+ (import: java/lang/ProcessBuilder
+ ["#::."
+ (new [[java/lang/String]])
+ (environment [] #try (java/util/Map java/lang/String java/lang/String))
+ (directory [java/io/File] java/lang/ProcessBuilder)
+ (start [] #io #try java/lang/Process)])
+
+ (import: java/lang/System
+ ["#::."
+ (#static getProperty [java/lang/String] #io #try java/lang/String)])
+
+ ## https://en.wikipedia.org/wiki/Code_injection#Shell_injection
+ (def: windows?
+ (IO (Try Bit))
+ (\ (try.with io.monad) map
+ (|>> java/lang/String::toLowerCase (text.starts_with? "windows"))
+ (java/lang/System::getProperty "os.name")))
+
+ (implementation: #export default
+ (Shell IO)
+
+ (def: (execute [environment working_directory command arguments])
+ (do {! (try.with io.monad)}
+ [#let [builder (|> (list& command arguments)
+ ..jvm::arguments_array
+ java/lang/ProcessBuilder::new
+ (java/lang/ProcessBuilder::directory (java/io/File::new working_directory)))]
+ _ (|> builder
+ java/lang/ProcessBuilder::environment
+ (\ try.functor map (..jvm::load_environment environment))
+ (\ io.monad wrap))
+ process (java/lang/ProcessBuilder::start builder)]
+ (..default_process process))))
+ )]
+ (for {@.old (as_is <jvm>)
+ @.jvm (as_is <jvm>)}
+ (as_is)))
+
+(interface: #export (Mock s)
+ (: (-> s (Try [s Text]))
+ on_read)
+ (: (-> s (Try [s Text]))
+ on_error)
+ (: (-> Text s (Try s))
+ on_write)
+ (: (-> s (Try s))
+ on_destroy)
+ (: (-> s (Try [s Exit]))
+ on_await))
+
+(`` (implementation: (mock_process mock state)
+ (All [s] (-> (Mock s) (Atom s) (Process IO)))
+
+ (~~ (template [<name> <mock>]
+ [(def: (<name> _)
+ (do {! io.monad}
+ [|state| (atom.read state)]
+ (case (\ mock <mock> |state|)
+ (#try.Success [|state| output])
+ (do !
+ [_ (atom.write |state| state)]
+ (wrap (#try.Success output)))
+
+ (#try.Failure error)
+ (wrap (#try.Failure error)))))]
+
+ [read on_read]
+ [error on_error]
+ [await on_await]
+ ))
+ (def: (write message)
+ (do {! io.monad}
+ [|state| (atom.read state)]
+ (case (\ mock on_write message |state|)
+ (#try.Success |state|)
+ (do !
+ [_ (atom.write |state| state)]
+ (wrap (#try.Success [])))
+
+ (#try.Failure error)
+ (wrap (#try.Failure error)))))
+ (def: (destroy _)
+ (do {! io.monad}
+ [|state| (atom.read state)]
+ (case (\ mock on_destroy |state|)
+ (#try.Success |state|)
+ (do !
+ [_ (atom.write |state| state)]
+ (wrap (#try.Success [])))
+
+ (#try.Failure error)
+ (wrap (#try.Failure error)))))))
+
+(implementation: #export (mock mock init)
+ (All [s]
+ (-> (-> [Environment Path Command (List Argument)]
+ (Try (Mock s)))
+ s
+ (Shell IO)))
+
+ (def: (execute input)
+ (io.io (do try.monad
+ [mock (mock input)]
+ (wrap (..mock_process mock (atom.atom init)))))))
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
deleted file mode 100644
index da491b2c8..000000000
--- a/stdlib/source/lux.lux
+++ /dev/null
@@ -1,5953 +0,0 @@
-("lux def" dummy_location
- ["" 0 0]
- [["" 0 0] (9 #1 (0 #0))]
- #0)
-
-("lux def" double_quote
- ("lux i64 char" +34)
- [dummy_location (9 #1 (0 #0))]
- #0)
-
-("lux def" \n
- ("lux i64 char" +10)
- [dummy_location (9 #1 (0 #0))]
- #0)
-
-("lux def" __paragraph
- ("lux text concat" \n \n)
- [dummy_location (9 #1 (0 #0))]
- #0)
-
-## (type: Any
-## (Ex [a] a))
-("lux def" Any
- ("lux type check type"
- (9 #1 ["lux" "Any"]
- (8 #0 (0 #0) (4 #0 1))))
- [dummy_location
- (9 #1 (0 #1 [[dummy_location (7 #0 ["lux" "doc"])]
- [dummy_location (5 #0 ("lux text concat"
- ("lux text concat" "The type of things whose type is irrelevant." __paragraph)
- "It can be used to write functions or data-structures that can take, or return, anything."))]]
- (0 #0)))]
- #1)
-
-## (type: Nothing
-## (All [a] a))
-("lux def" Nothing
- ("lux type check type"
- (9 #1 ["lux" "Nothing"]
- (7 #0 (0 #0) (4 #0 1))))
- [dummy_location
- (9 #1 (0 #1 [[dummy_location (7 #0 ["lux" "doc"])]
- [dummy_location (5 #0 ("lux text concat"
- ("lux text concat" "The type of things whose type is undefined." __paragraph)
- "Useful for expressions that cause errors or other 'extraordinary' conditions."))]]
- (0 #0)))]
- #1)
-
-## (type: (List a)
-## #Nil
-## (#Cons a (List a)))
-("lux def type tagged" List
- (9 #1 ["lux" "List"]
- (7 #0 (0 #0)
- (1 #0 ## "lux.Nil"
- Any
- ## "lux.Cons"
- (2 #0 (4 #0 1)
- (9 #0 (4 #0 1) (4 #0 0))))))
- [dummy_location
- (9 #1 (0 #1 [[dummy_location (7 #0 ["lux" "type-args"])]
- [dummy_location (9 #0 (0 #1 [dummy_location (5 #0 "a")] (0 #0)))]]
- (0 #1 [[dummy_location (7 #0 ["lux" "doc"])]
- [dummy_location (5 #0 "A potentially empty list of values.")]]
- (0 #0))))]
- ["Nil" "Cons"]
- #1)
-
-("lux def" Bit
- ("lux type check type"
- (9 #1 ["lux" "Bit"]
- (0 #0 "#Bit" #Nil)))
- [dummy_location
- (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])]
- [dummy_location (5 #0 "Your standard, run-of-the-mill boolean values (as bits).")]]
- #Nil))]
- #1)
-
-("lux def" I64
- ("lux type check type"
- (9 #1 ["lux" "I64"]
- (7 #0 (0 #0)
- (0 #0 "#I64" (#Cons (4 #0 1) #Nil)))))
- [dummy_location
- (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])]
- [dummy_location (5 #0 "64-bit integers without any semantics.")]]
- #Nil))]
- #1)
-
-("lux def" Nat
- ("lux type check type"
- (9 #1 ["lux" "Nat"]
- (0 #0 "#I64" (#Cons (0 #0 "#Nat" #Nil) #Nil))))
- [dummy_location
- (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])]
- [dummy_location (5 #0 ("lux text concat"
- ("lux text concat" "Natural numbers (unsigned integers)." __paragraph)
- "They start at zero (0) and extend in the positive direction."))]]
- #Nil))]
- #1)
-
-("lux def" Int
- ("lux type check type"
- (9 #1 ["lux" "Int"]
- (0 #0 "#I64" (#Cons (0 #0 "#Int" #Nil) #Nil))))
- [dummy_location
- (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])]
- [dummy_location (5 #0 "Your standard, run-of-the-mill integer numbers.")]]
- #Nil))]
- #1)
-
-("lux def" Rev
- ("lux type check type"
- (9 #1 ["lux" "Rev"]
- (0 #0 "#I64" (#Cons (0 #0 "#Rev" #Nil) #Nil))))
- [dummy_location
- (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])]
- [dummy_location (5 #0 ("lux text concat"
- ("lux text concat" "Fractional numbers that live in the interval [0,1)." __paragraph)
- "Useful for probability, and other domains that work within that interval."))]]
- #Nil))]
- #1)
-
-("lux def" Frac
- ("lux type check type"
- (9 #1 ["lux" "Frac"]
- (0 #0 "#Frac" #Nil)))
- [dummy_location
- (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])]
- [dummy_location (5 #0 "Your standard, run-of-the-mill floating-point (fractional) numbers.")]]
- #Nil))]
- #1)
-
-("lux def" Text
- ("lux type check type"
- (9 #1 ["lux" "Text"]
- (0 #0 "#Text" #Nil)))
- [dummy_location
- (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])]
- [dummy_location (5 #0 "Your standard, run-of-the-mill string values.")]]
- #Nil))]
- #1)
-
-("lux def" Name
- ("lux type check type"
- (9 #1 ["lux" "Name"]
- (2 #0 Text Text)))
- [dummy_location
- (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])]
- [dummy_location (5 #0 "A name. It is used as part of Lux syntax to represent identifiers and tags.")]]
- #Nil))]
- #1)
-
-## (type: (Maybe a)
-## #None
-## (#Some a))
-("lux def type tagged" Maybe
- (9 #1 ["lux" "Maybe"]
- (7 #0 #Nil
- (1 #0 ## "lux.None"
- Any
- ## "lux.Some"
- (4 #0 1))))
- [dummy_location
- (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "type-args"])]
- [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "a")] #Nil))]]
- (#Cons [[dummy_location (7 #0 ["lux" "doc"])]
- [dummy_location (5 #0 "A potentially missing value.")]]
- #Nil)))]
- ["None" "Some"]
- #1)
-
-## (type: #rec Type
-## (#Primitive Text (List Type))
-## (#Sum Type Type)
-## (#Product Type Type)
-## (#Function Type Type)
-## (#Parameter Nat)
-## (#Var Nat)
-## (#Ex Nat)
-## (#UnivQ (List Type) Type)
-## (#ExQ (List Type) Type)
-## (#Apply Type Type)
-## (#Named Name Type)
-## )
-("lux def type tagged" Type
- (9 #1 ["lux" "Type"]
- ({Type
- ({Type_List
- ({Type_Pair
- (9 #0 Nothing
- (7 #0 #Nil
- (1 #0 ## "lux.Primitive"
- (2 #0 Text Type_List)
- (1 #0 ## "lux.Sum"
- Type_Pair
- (1 #0 ## "lux.Product"
- Type_Pair
- (1 #0 ## "lux.Function"
- Type_Pair
- (1 #0 ## "lux.Parameter"
- Nat
- (1 #0 ## "lux.Var"
- Nat
- (1 #0 ## "lux.Ex"
- Nat
- (1 #0 ## "lux.UnivQ"
- (2 #0 Type_List Type)
- (1 #0 ## "lux.ExQ"
- (2 #0 Type_List Type)
- (1 #0 ## "lux.Apply"
- Type_Pair
- ## "lux.Named"
- (2 #0 Name Type)))))))))))))}
- ("lux type check type" (2 #0 Type Type)))}
- ("lux type check type" (9 #0 Type List)))}
- ("lux type check type" (9 #0 (4 #0 1) (4 #0 0)))))
- [dummy_location
- (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])]
- [dummy_location (5 #0 "This type represents the data-structures that are used to specify types themselves.")]]
- (#Cons [[dummy_location (7 #0 ["lux" "type-rec?"])]
- [dummy_location (0 #0 #1)]]
- #Nil)))]
- ["Primitive" "Sum" "Product" "Function" "Parameter" "Var" "Ex" "UnivQ" "ExQ" "Apply" "Named"]
- #1)
-
-## (type: Location
-## {#module Text
-## #line Nat
-## #column Nat})
-("lux def type tagged" Location
- (#Named ["lux" "Location"]
- (#Product Text (#Product Nat Nat)))
- [dummy_location
- (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])]
- [dummy_location (5 #0 "Locations are for specifying the location of Code nodes in Lux files during compilation.")]]
- #Nil))]
- ["module" "line" "column"]
- #1)
-
-## (type: (Ann m v)
-## {#meta m
-## #datum v})
-("lux def type tagged" Ann
- (#Named ["lux" "Ann"]
- (#UnivQ #Nil
- (#UnivQ #Nil
- (#Product (#Parameter 3)
- (#Parameter 1)))))
- [dummy_location
- (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "doc"])]
- [dummy_location (5 #0 "The type of things that can be annotated with meta-data of arbitrary types.")]]
- (#Cons [[dummy_location (7 #0 ["lux" "type-args"])]
- [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "m")] (#Cons [dummy_location (5 #0 "v")] #Nil)))]]
- #Nil)))]
- ["meta" "datum"]
- #1)
-
-## (type: (Code' w)
-## (#Bit Bit)
-## (#Nat Nat)
-## (#Int Int)
-## (#Rev Rev)
-## (#Frac Frac)
-## (#Text Text)
-## (#Identifier Name)
-## (#Tag Name)
-## (#Form (List (w (Code' w))))
-## (#Tuple (List (w (Code' w))))
-## (#Record (List [(w (Code' w)) (w (Code' w))])))
-("lux def type tagged" Code'
- (#Named ["lux" "Code'"]
- ({Code
- ({Code_List
- (#UnivQ #Nil
- (#Sum ## "lux.Bit"
- Bit
- (#Sum ## "lux.Nat"
- Nat
- (#Sum ## "lux.Int"
- Int
- (#Sum ## "lux.Rev"
- Rev
- (#Sum ## "lux.Frac"
- Frac
- (#Sum ## "lux.Text"
- Text
- (#Sum ## "lux.Identifier"
- Name
- (#Sum ## "lux.Tag"
- Name
- (#Sum ## "lux.Form"
- Code_List
- (#Sum ## "lux.Tuple"
- Code_List
- ## "lux.Record"
- (#Apply (#Product Code Code) List)
- ))))))))))
- )}
- ("lux type check type" (#Apply Code List)))}
- ("lux type check type" (#Apply (#Apply (#Parameter 1)
- (#Parameter 0))
- (#Parameter 1)))))
- [dummy_location
- (9 #1 (#Cons [[dummy_location (7 #0 ["lux" "type-args"])]
- [dummy_location (9 #0 (#Cons [dummy_location (5 #0 "w")] #Nil))]]
- #Nil))]
- ["Bit" "Nat" "Int" "Rev" "Frac" "Text" "Identifier" "Tag" "Form" "Tuple" "Record"]
- #1)
-
-## (type: Code
-## (Ann Location (Code' (Ann Location))))
-("lux def" Code
- (#Named ["lux" "Code"]
- ({w
- (#Apply (#Apply w Code') w)}
- ("lux type check type" (#Apply Location Ann))))
- [dummy_location
- (#Record (#Cons [[dummy_location (#Tag ["lux" "doc"])]
- [dummy_location (#Text "The type of Code nodes for Lux syntax.")]]
- #Nil))]
- #1)
-
-("lux def" _ann
- ("lux type check"
- (#Function (#Apply (#Apply Location Ann)
- Code')
- Code)
- ([_ data]
- [dummy_location data]))
- [dummy_location (#Record #Nil)]
- #0)
-
-("lux def" bit$
- ("lux type check" (#Function Bit Code)
- ([_ value] (_ann (#Bit value))))
- [dummy_location (#Record #Nil)]
- #0)
-
-("lux def" nat$
- ("lux type check" (#Function Nat Code)
- ([_ value] (_ann (#Nat value))))
- [dummy_location (#Record #Nil)]
- #0)
-
-("lux def" int$
- ("lux type check" (#Function Int Code)
- ([_ value] (_ann (#Int value))))
- [dummy_location (#Record #Nil)]
- #0)
-
-("lux def" rev$
- ("lux type check" (#Function Rev Code)
- ([_ value] (_ann (#Rev value))))
- [dummy_location (#Record #Nil)]
- #0)
-
-("lux def" frac$
- ("lux type check" (#Function Frac Code)
- ([_ value] (_ann (#Frac value))))
- [dummy_location (#Record #Nil)]
- #0)
-
-("lux def" text$
- ("lux type check" (#Function Text Code)
- ([_ text] (_ann (#Text text))))
- [dummy_location (#Record #Nil)]
- #0)
-
-("lux def" identifier$
- ("lux type check" (#Function Name Code)
- ([_ name] (_ann (#Identifier name))))
- [dummy_location (#Record #Nil)]
- #0)
-
-("lux def" local_identifier$
- ("lux type check" (#Function Text Code)
- ([_ name] (_ann (#Identifier ["" name]))))
- [dummy_location (#Record #Nil)]
- #0)
-
-("lux def" tag$
- ("lux type check" (#Function Name Code)
- ([_ name] (_ann (#Tag name))))
- [dummy_location (#Record #Nil)]
- #0)
-
-("lux def" local_tag$
- ("lux type check" (#Function Text Code)
- ([_ name] (_ann (#Tag ["" name]))))
- [dummy_location (#Record #Nil)]
- #0)
-
-("lux def" form$
- ("lux type check" (#Function (#Apply Code List) Code)
- ([_ tokens] (_ann (#Form tokens))))
- [dummy_location (#Record #Nil)]
- #0)
-
-("lux def" tuple$
- ("lux type check" (#Function (#Apply Code List) Code)
- ([_ tokens] (_ann (#Tuple tokens))))
- [dummy_location (#Record #Nil)]
- #0)
-
-("lux def" record$
- ("lux type check" (#Function (#Apply (#Product Code Code) List) Code)
- ([_ tokens] (_ann (#Record tokens))))
- [dummy_location (#Record #Nil)]
- #0)
-
-## (type: Definition
-## [Bit Type Code Any])
-("lux def" Definition
- ("lux type check type"
- (#Named ["lux" "Definition"]
- (#Product Bit (#Product Type (#Product Code Any)))))
- (record$ (#Cons [(tag$ ["lux" "doc"])
- (text$ "Represents all the data associated with a definition: its type, its annotations, and its value.")]
- #Nil))
- #1)
-
-## (type: Alias
-## Name)
-("lux def" Alias
- ("lux type check type"
- (#Named ["lux" "Alias"]
- Name))
- (record$ #Nil)
- #1)
-
-## (type: Global
-## (#Alias Alias)
-## (#Definition Definition))
-("lux def type tagged" Global
- (#Named ["lux" "Global"]
- (#Sum Alias
- Definition))
- (record$ (#Cons [(tag$ ["lux" "doc"])
- (text$ "Represents all the data associated with a global constant.")]
- #Nil))
- ["Alias" "Definition"]
- #1)
-
-## (type: (Bindings k v)
-## {#counter Nat
-## #mappings (List [k v])})
-("lux def type tagged" Bindings
- (#Named ["lux" "Bindings"]
- (#UnivQ #Nil
- (#UnivQ #Nil
- (#Product ## "lux.counter"
- Nat
- ## "lux.mappings"
- (#Apply (#Product (#Parameter 3)
- (#Parameter 1))
- List)))))
- (record$ (#Cons [(tag$ ["lux" "type-args"])
- (tuple$ (#Cons (text$ "k") (#Cons (text$ "v") #Nil)))]
- #Nil))
- ["counter" "mappings"]
- #1)
-
-## (type: #export Ref
-## (#Local Nat)
-## (#Captured Nat))
-("lux def type tagged" Ref
- (#Named ["lux" "Ref"]
- (#Sum ## Local
- Nat
- ## Captured
- Nat))
- (record$ #Nil)
- ["Local" "Captured"]
- #1)
-
-## (type: Scope
-## {#name (List Text)
-## #inner Nat
-## #locals (Bindings Text [Type Nat])
-## #captured (Bindings Text [Type Ref])})
-("lux def type tagged" Scope
- (#Named ["lux" "Scope"]
- (#Product ## name
- (#Apply Text List)
- (#Product ## inner
- Nat
- (#Product ## locals
- (#Apply (#Product Type Nat) (#Apply Text Bindings))
- ## captured
- (#Apply (#Product Type Ref) (#Apply Text Bindings))))))
- (record$ #Nil)
- ["name" "inner" "locals" "captured"]
- #1)
-
-("lux def" Code_List
- ("lux type check type"
- (#Apply Code List))
- (record$ #Nil)
- #0)
-
-## (type: (Either l r)
-## (#Left l)
-## (#Right r))
-("lux def type tagged" Either
- (#Named ["lux" "Either"]
- (#UnivQ #Nil
- (#UnivQ #Nil
- (#Sum ## "lux.Left"
- (#Parameter 3)
- ## "lux.Right"
- (#Parameter 1)))))
- (record$ (#Cons [(tag$ ["lux" "type-args"])
- (tuple$ (#Cons (text$ "l") (#Cons (text$ "r") #Nil)))]
- (#Cons [(tag$ ["lux" "doc"])
- (text$ "A choice between two values of different types.")]
- #Nil)))
- ["Left" "Right"]
- #1)
-
-## (type: Source
-## [Location Nat Text])
-("lux def" Source
- ("lux type check type"
- (#Named ["lux" "Source"]
- (#Product Location (#Product Nat Text))))
- (record$ #Nil)
- #1)
-
-## (type: Module_State
-## #Active
-## #Compiled
-## #Cached)
-("lux def type tagged" Module_State
- (#Named ["lux" "Module_State"]
- (#Sum
- ## #Active
- Any
- (#Sum
- ## #Compiled
- Any
- ## #Cached
- Any)))
- (record$ #Nil)
- ["Active" "Compiled" "Cached"]
- #1)
-
-## (type: Module
-## {#module_hash Nat
-## #module_aliases (List [Text Text])
-## #definitions (List [Text Global])
-## #imports (List Text)
-## #tags (List [Text [Nat (List Name) Bit Type]])
-## #types (List [Text [(List Name) Bit Type]])
-## #module_annotations (Maybe Code)
-## #module_state Module_State})
-("lux def type tagged" Module
- (#Named ["lux" "Module"]
- (#Product ## "lux.module_hash"
- Nat
- (#Product ## "lux.module_aliases"
- (#Apply (#Product Text Text) List)
- (#Product ## "lux.definitions"
- (#Apply (#Product Text Global) List)
- (#Product ## "lux.imports"
- (#Apply Text List)
- (#Product ## "lux.tags"
- (#Apply (#Product Text
- (#Product Nat
- (#Product (#Apply Name List)
- (#Product Bit
- Type))))
- List)
- (#Product ## "lux.types"
- (#Apply (#Product Text
- (#Product (#Apply Name List)
- (#Product Bit
- Type)))
- List)
- (#Product ## "lux.module_annotations"
- (#Apply Code Maybe)
- Module_State))
- ))))))
- (record$ (#Cons [(tag$ ["lux" "doc"])
- (text$ "All the information contained within a Lux module.")]
- #Nil))
- ["module_hash" "module_aliases" "definitions" "imports" "tags" "types" "module_annotations" "module_state"]
- #1)
-
-## (type: Type_Context
-## {#ex_counter Nat
-## #var_counter Nat
-## #var_bindings (List [Nat (Maybe Type)])})
-("lux def type tagged" Type_Context
- (#Named ["lux" "Type_Context"]
- (#Product ## ex_counter
- Nat
- (#Product ## var_counter
- Nat
- ## var_bindings
- (#Apply (#Product Nat (#Apply Type Maybe))
- List))))
- (record$ #Nil)
- ["ex_counter" "var_counter" "var_bindings"]
- #1)
-
-## (type: Mode
-## #Build
-## #Eval
-## #Interpreter)
-("lux def type tagged" Mode
- (#Named ["lux" "Mode"]
- (#Sum ## Build
- Any
- (#Sum ## Eval
- Any
- ## Interpreter
- Any)))
- (record$ (#Cons [(tag$ ["lux" "doc"])
- (text$ "A sign that shows the conditions under which the compiler is running.")]
- #Nil))
- ["Build" "Eval" "Interpreter"]
- #1)
-
-## (type: Info
-## {#target Text
-## #version Text
-## #mode Mode})
-("lux def type tagged" Info
- (#Named ["lux" "Info"]
- (#Product
- ## target
- Text
- (#Product
- ## version
- Text
- ## mode
- Mode)))
- (record$ (#Cons [(tag$ ["lux" "doc"])
- (text$ "Information about the current version and type of compiler that is running.")]
- #Nil))
- ["target" "version" "mode"]
- #1)
-
-## (type: Lux
-## {#info Info
-## #source Source
-## #location Location
-## #current_module (Maybe Text)
-## #modules (List [Text Module])
-## #scopes (List Scope)
-## #type_context Type_Context
-## #expected (Maybe Type)
-## #seed Nat
-## #scope_type_vars (List Nat)
-## #extensions Any
-## #host Any})
-("lux def type tagged" Lux
- (#Named ["lux" "Lux"]
- (#Product ## "lux.info"
- Info
- (#Product ## "lux.source"
- Source
- (#Product ## "lux.location"
- Location
- (#Product ## "lux.current_module"
- (#Apply Text Maybe)
- (#Product ## "lux.modules"
- (#Apply (#Product Text Module) List)
- (#Product ## "lux.scopes"
- (#Apply Scope List)
- (#Product ## "lux.type_context"
- Type_Context
- (#Product ## "lux.expected"
- (#Apply Type Maybe)
- (#Product ## "lux.seed"
- Nat
- (#Product ## scope_type_vars
- (#Apply Nat List)
- (#Product ## extensions
- Any
- ## "lux.host"
- Any))))))))))))
- (record$ (#Cons [(tag$ ["lux" "doc"])
- (text$ ("lux text concat"
- ("lux text concat" "Represents the state of the Lux compiler during a run." __paragraph)
- ("lux text concat"
- ("lux text concat" "It is provided to macros during their invocation, so they can access compiler data." __paragraph)
- "Caveat emptor: Avoid fiddling with it, unless you know what you're doing.")))]
- #Nil))
- ["info" "source" "location" "current_module" "modules" "scopes" "type_context" "expected" "seed" "scope_type_vars" "extensions" "host"]
- #1)
-
-## (type: (Meta a)
-## (-> Lux (Either Text [Lux a])))
-("lux def" Meta
- ("lux type check type"
- (#Named ["lux" "Meta"]
- (#UnivQ #Nil
- (#Function Lux
- (#Apply (#Product Lux (#Parameter 1))
- (#Apply Text Either))))))
- (record$ (#Cons [(tag$ ["lux" "doc"])
- (text$ ("lux text concat"
- ("lux text concat" "Computations that can have access to the state of the compiler." __paragraph)
- "These computations may fail, or modify the state of the compiler."))]
- (#Cons [(tag$ ["lux" "type-args"])
- (tuple$ (#Cons (text$ "a") #Nil))]
- #Nil)))
- #1)
-
-## (type: Macro'
-## (-> (List Code) (Meta (List Code))))
-("lux def" Macro'
- ("lux type check type"
- (#Named ["lux" "Macro'"]
- (#Function Code_List (#Apply Code_List Meta))))
- (record$ #Nil)
- #1)
-
-## (type: Macro
-## (primitive "#Macro"))
-("lux def" Macro
- ("lux type check type"
- (#Named ["lux" "Macro"]
- (#Primitive "#Macro" #Nil)))
- (record$ (#Cons [(tag$ ["lux" "doc"])
- (text$ "Functions that run at compile-time and allow you to transform and extend the language in powerful ways.")]
- #Nil))
- #1)
-
-## Base functions & macros
-("lux def" return
- ("lux type check"
- (#UnivQ #Nil
- (#Function (#Parameter 1)
- (#Function Lux
- (#Apply (#Product Lux
- (#Parameter 1))
- (#Apply Text Either)))))
- ([_ val]
- ([_ state]
- (#Right state val))))
- (record$ #Nil)
- #0)
-
-("lux def" fail
- ("lux type check"
- (#UnivQ #Nil
- (#Function Text
- (#Function Lux
- (#Apply (#Product Lux
- (#Parameter 1))
- (#Apply Text Either)))))
- ([_ msg]
- ([_ state]
- (#Left msg))))
- (record$ #Nil)
- #0)
-
-("lux def" let''
- ("lux macro"
- ([_ tokens]
- ({(#Cons lhs (#Cons rhs (#Cons body #Nil)))
- (return (#Cons (form$ (#Cons (record$ (#Cons [lhs body] #Nil)) (#Cons rhs #Nil)))
- #Nil))
-
- _
- (fail "Wrong syntax for let''")}
- tokens)))
- (record$ #.Nil)
- #0)
-
-("lux def" function''
- ("lux macro"
- ([_ tokens]
- ({(#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil))
- (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" ""]))
- (#Cons arg #Nil))))
- (#Cons ({#Nil
- body
-
- _
- (_ann (#Form (#Cons (_ann (#Identifier ["lux" "function''"]))
- (#Cons (_ann (#Tuple args'))
- (#Cons body #Nil)))))}
- args')
- #Nil))))
- #Nil))
-
- (#Cons [_ (#Identifier ["" self])] (#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil)))
- (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" self]))
- (#Cons arg #Nil))))
- (#Cons ({#Nil
- body
-
- _
- (_ann (#Form (#Cons (_ann (#Identifier ["lux" "function''"]))
- (#Cons (_ann (#Tuple args'))
- (#Cons body #Nil)))))}
- args')
- #Nil))))
- #Nil))
-
- _
- (fail "Wrong syntax for function''")}
- tokens)))
- (record$ #.Nil)
- #0)
-
-("lux def" location_code
- ("lux type check" Code
- (tuple$ (#Cons (text$ "") (#Cons (nat$ 0) (#Cons (nat$ 0) #Nil)))))
- (record$ #Nil)
- #0)
-
-("lux def" meta_code
- ("lux type check" (#Function Name (#Function Code Code))
- ([_ tag]
- ([_ value]
- (tuple$ (#Cons location_code
- (#Cons (form$ (#Cons (tag$ tag) (#Cons value #Nil)))
- #Nil))))))
- (record$ #Nil)
- #0)
-
-("lux def" flag_meta
- ("lux type check" (#Function Text Code)
- ([_ tag]
- (tuple$ (#Cons [(meta_code ["lux" "Tag"] (tuple$ (#Cons (text$ "lux") (#Cons (text$ tag) #Nil))))
- (#Cons [(meta_code ["lux" "Bit"] (bit$ #1))
- #Nil])]))))
- (record$ #Nil)
- #0)
-
-("lux def" doc_meta
- ("lux type check" (#Function Text (#Product Code Code))
- (function'' [doc] [(tag$ ["lux" "doc"]) (text$ doc)]))
- (record$ #Nil)
- #0)
-
-("lux def" as_def
- ("lux type check" (#Function Code (#Function Code (#Function Code (#Function Bit Code))))
- (function'' [name value annotations exported?]
- (form$ (#Cons (text$ "lux def") (#Cons name (#Cons value (#Cons annotations (#Cons (bit$ exported?) #Nil))))))))
- (record$ #Nil)
- #0)
-
-("lux def" as_checked
- ("lux type check" (#Function Code (#Function Code Code))
- (function'' [type value]
- (form$ (#Cons (text$ "lux type check") (#Cons type (#Cons value #Nil))))))
- (record$ #Nil)
- #0)
-
-("lux def" as_function
- ("lux type check" (#Function Code (#Function (#Apply Code List) (#Function Code Code)))
- (function'' [self inputs output]
- (form$ (#Cons (identifier$ ["lux" "function''"])
- (#Cons self
- (#Cons (tuple$ inputs)
- (#Cons output #Nil)))))))
- (record$ #Nil)
- #0)
-
-("lux def" as_macro
- ("lux type check" (#Function Code Code)
- (function'' [expression]
- (form$ (#Cons (text$ "lux macro")
- (#Cons expression
- #Nil)))))
- (record$ #Nil)
- #0)
-
-("lux def" def:''
- ("lux macro"
- (function'' [tokens]
- ({(#Cons [[_ (#Tag ["" "export"])]
- (#Cons [[_ (#Form (#Cons [name args]))]
- (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])])
- (return (#Cons [(as_def name (as_checked type (as_function name args body))
- (form$ (#Cons (identifier$ ["lux" "record$"])
- (#Cons meta
- #Nil)))
- #1)
- #Nil]))
-
- (#Cons [[_ (#Tag ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])])
- (return (#Cons [(as_def name (as_checked type body)
- (form$ (#Cons (identifier$ ["lux" "record$"])
- (#Cons meta
- #Nil)))
- #1)
- #Nil]))
-
- (#Cons [[_ (#Form (#Cons [name args]))]
- (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])
- (return (#Cons [(as_def name (as_checked type (as_function name args body))
- (form$ (#Cons (identifier$ ["lux" "record$"])
- (#Cons meta
- #Nil)))
- #0)
- #Nil]))
-
- (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])
- (return (#Cons [(as_def name (as_checked type body)
- (form$ (#Cons (identifier$ ["lux" "record$"])
- (#Cons meta
- #Nil)))
- #0)
- #Nil]))
-
- _
- (fail "Wrong syntax for def''")}
- tokens)))
- (record$ #.Nil)
- #0)
-
-("lux def" macro:'
- ("lux macro"
- (function'' [tokens]
- ({(#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil))
- (return (#Cons (as_def name (as_macro (as_function name args body))
- (form$ (#Cons (identifier$ ["lux" "record$"])
- (#Cons (tag$ ["lux" "Nil"])
- #Nil)))
- #0)
- #Nil))
-
- (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil)))
- (return (#Cons (as_def name (as_macro (as_function name args body))
- (form$ (#Cons (identifier$ ["lux" "record$"])
- (#Cons (tag$ ["lux" "Nil"])
- #Nil)))
- #1)
- #Nil))
-
- (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons meta_data (#Cons body #Nil))))
- (return (#Cons (as_def name (as_macro (as_function name args body))
- (form$ (#Cons (identifier$ ["lux" "record$"])
- (#Cons meta_data
- #Nil)))
- #1)
- #Nil))
-
- _
- (fail "Wrong syntax for macro:'")}
- tokens)))
- (record$ #.Nil)
- #0)
-
-(macro:' #export (comment tokens)
- (#Cons [(tag$ ["lux" "doc"])
- (text$ ("lux text concat"
- ("lux text concat" "## Throws away any code given to it." __paragraph)
- ("lux text concat"
- ("lux text concat" "## Great for commenting-out code, while retaining syntax high-lighting and formatting in your text editor." __paragraph)
- "(comment +1 +2 +3 +4)")))]
- #Nil)
- (return #Nil))
-
-(macro:' ($' tokens)
- ({(#Cons x #Nil)
- (return tokens)
-
- (#Cons x (#Cons y xs))
- (return (#Cons (form$ (#Cons (identifier$ ["lux" "$'"])
- (#Cons (form$ (#Cons (tag$ ["lux" "Apply"])
- (#Cons y (#Cons x #Nil))))
- xs)))
- #Nil))
-
- _
- (fail "Wrong syntax for $'")}
- tokens))
-
-(def:'' (list\map f xs)
- #Nil
- (#UnivQ #Nil
- (#UnivQ #Nil
- (#Function (#Function (#Parameter 3) (#Parameter 1))
- (#Function ($' List (#Parameter 3))
- ($' List (#Parameter 1))))))
- ({#Nil
- #Nil
-
- (#Cons x xs')
- (#Cons (f x) (list\map f xs'))}
- xs))
-
-(def:'' RepEnv
- #Nil
- Type
- ($' List (#Product Text Code)))
-
-(def:'' (make_env xs ys)
- #Nil
- (#Function ($' List Text) (#Function ($' List Code) RepEnv))
- ({[(#Cons x xs') (#Cons y ys')]
- (#Cons [x y] (make_env xs' ys'))
-
- _
- #Nil}
- [xs ys]))
-
-(def:'' (text\= reference sample)
- #Nil
- (#Function Text (#Function Text Bit))
- ("lux text =" reference sample))
-
-(def:'' (get_rep key env)
- #Nil
- (#Function Text (#Function RepEnv ($' Maybe Code)))
- ({#Nil
- #None
-
- (#Cons [k v] env')
- ({#1
- (#Some v)
-
- #0
- (get_rep key env')}
- (text\= k key))}
- env))
-
-(def:'' (replace_syntax reps syntax)
- #Nil
- (#Function RepEnv (#Function Code Code))
- ({[_ (#Identifier "" name)]
- ({(#Some replacement)
- replacement
-
- #None
- syntax}
- (get_rep name reps))
-
- [meta (#Form parts)]
- [meta (#Form (list\map (replace_syntax reps) parts))]
-
- [meta (#Tuple members)]
- [meta (#Tuple (list\map (replace_syntax reps) members))]
-
- [meta (#Record slots)]
- [meta (#Record (list\map ("lux type check" (#Function (#Product Code Code) (#Product Code Code))
- (function'' [slot]
- ({[k v]
- [(replace_syntax reps k) (replace_syntax reps v)]}
- slot)))
- slots))]
-
- _
- syntax}
- syntax))
-
-(def:'' (n/* param subject)
- (#.Cons (doc_meta "Nat(ural) multiplication.") #.Nil)
- (#Function Nat (#Function Nat Nat))
- ("lux type as" Nat
- ("lux i64 *"
- ("lux type as" Int param)
- ("lux type as" Int subject))))
-
-(def:'' (update_parameters code)
- #Nil
- (#Function Code Code)
- ({[_ (#Tuple members)]
- (tuple$ (list\map update_parameters members))
-
- [_ (#Record pairs)]
- (record$ (list\map ("lux type check" (#Function (#Product Code Code) (#Product Code Code))
- (function'' [pair]
- (let'' [name val] pair
- [name (update_parameters val)])))
- pairs))
-
- [_ (#Form (#Cons [_ (#Tag "lux" "Parameter")] (#Cons [_ (#Nat idx)] #Nil)))]
- (form$ (#Cons (tag$ ["lux" "Parameter"]) (#Cons (nat$ ("lux i64 +" 2 idx)) #Nil)))
-
- [_ (#Form members)]
- (form$ (list\map update_parameters members))
-
- _
- code}
- code))
-
-(def:'' (parse_quantified_args args next)
- #Nil
- ## (-> (List Code) (-> (List Text) (Meta (List Code))) (Meta (List Code)))
- (#Function ($' List Code)
- (#Function (#Function ($' List Text) (#Apply ($' List Code) Meta))
- (#Apply ($' List Code) Meta)
- ))
- ({#Nil
- (next #Nil)
-
- (#Cons [_ (#Identifier "" arg_name)] args')
- (parse_quantified_args args' (function'' [names] (next (#Cons arg_name names))))
-
- _
- (fail "Expected identifier.")}
- args))
-
-(def:'' (make_parameter idx)
- #Nil
- (#Function Nat Code)
- (form$ (#Cons (tag$ ["lux" "Parameter"]) (#Cons (nat$ idx) #Nil))))
-
-(def:'' (list\fold f init xs)
- #Nil
- ## (All [a b] (-> (-> b a a) a (List b) a))
- (#UnivQ #Nil (#UnivQ #Nil (#Function (#Function (#Parameter 1)
- (#Function (#Parameter 3)
- (#Parameter 3)))
- (#Function (#Parameter 3)
- (#Function ($' List (#Parameter 1))
- (#Parameter 3))))))
- ({#Nil
- init
-
- (#Cons x xs')
- (list\fold f (f x init) xs')}
- xs))
-
-(def:'' (list\size list)
- #Nil
- (#UnivQ #Nil
- (#Function ($' List (#Parameter 1)) Nat))
- (list\fold (function'' [_ acc] ("lux i64 +" 1 acc)) 0 list))
-
-(macro:' #export (All tokens)
- (#Cons [(tag$ ["lux" "doc"])
- (text$ ("lux text concat"
- ("lux text concat" "## Universal quantification." __paragraph)
- ("lux text concat"
- ("lux text concat" "(All [a] (-> a a))" __paragraph)
- ("lux text concat"
- ("lux text concat" "## A name can be provided, to specify a recursive type." __paragraph)
- "(All List [a] (| Any [a (List a)]))"))))]
- #Nil)
- (let'' [self_name tokens] ({(#Cons [_ (#Identifier "" self_name)] tokens)
- [self_name tokens]
-
- _
- ["" tokens]}
- tokens)
- ({(#Cons [_ (#Tuple args)] (#Cons body #Nil))
- (parse_quantified_args args
- (function'' [names]
- (let'' body' (list\fold ("lux type check" (#Function Text (#Function Code Code))
- (function'' [name' body']
- (form$ (#Cons (tag$ ["lux" "UnivQ"])
- (#Cons (tag$ ["lux" "Nil"])
- (#Cons (replace_syntax (#Cons [name' (make_parameter 1)] #Nil)
- (update_parameters body')) #Nil))))))
- body
- names)
- (return (#Cons ({[#1 _]
- body'
-
- [_ #Nil]
- body'
-
- [#0 _]
- (replace_syntax (#Cons [self_name (make_parameter (n/* 2 ("lux i64 -" 1 (list\size names))))]
- #Nil)
- body')}
- [(text\= "" self_name) names])
- #Nil)))))
-
- _
- (fail "Wrong syntax for All")}
- tokens)))
-
-(macro:' #export (Ex tokens)
- (#Cons [(tag$ ["lux" "doc"])
- (text$ ("lux text concat"
- ("lux text concat" "## Existential quantification." __paragraph)
- ("lux text concat"
- ("lux text concat" "(Ex [a] [(Codec Text a) a])" __paragraph)
- ("lux text concat"
- ("lux text concat" "## A name can be provided, to specify a recursive type." __paragraph)
- "(Ex Self [a] [(Codec Text a) a (List (Self a))])"))))]
- #Nil)
- (let'' [self_name tokens] ({(#Cons [_ (#Identifier "" self_name)] tokens)
- [self_name tokens]
-
- _
- ["" tokens]}
- tokens)
- ({(#Cons [_ (#Tuple args)] (#Cons body #Nil))
- (parse_quantified_args args
- (function'' [names]
- (let'' body' (list\fold ("lux type check" (#Function Text (#Function Code Code))
- (function'' [name' body']
- (form$ (#Cons (tag$ ["lux" "ExQ"])
- (#Cons (tag$ ["lux" "Nil"])
- (#Cons (replace_syntax (#Cons [name' (make_parameter 1)] #Nil)
- (update_parameters body')) #Nil))))))
- body
- names)
- (return (#Cons ({[#1 _]
- body'
-
- [_ #Nil]
- body'
-
- [#0 _]
- (replace_syntax (#Cons [self_name (make_parameter (n/* 2 ("lux i64 -" 1 (list\size names))))]
- #Nil)
- body')}
- [(text\= "" self_name) names])
- #Nil)))))
-
- _
- (fail "Wrong syntax for Ex")}
- tokens)))
-
-(def:'' (list\reverse list)
- #Nil
- (All [a] (#Function ($' List a) ($' List a)))
- (list\fold ("lux type check" (All [a] (#Function a (#Function ($' List a) ($' List a))))
- (function'' [head tail] (#Cons head tail)))
- #Nil
- list))
-
-(macro:' #export (-> tokens)
- (#Cons [(tag$ ["lux" "doc"])
- (text$ ("lux text concat"
- ("lux text concat" "## Function types:" __paragraph)
- ("lux text concat"
- ("lux text concat" "(-> Int Int Int)" __paragraph)
- "## This is the type of a function that takes 2 Ints and returns an Int.")))]
- #Nil)
- ({(#Cons output inputs)
- (return (#Cons (list\fold ("lux type check" (#Function Code (#Function Code Code))
- (function'' [i o] (form$ (#Cons (tag$ ["lux" "Function"]) (#Cons i (#Cons o #Nil))))))
- output
- inputs)
- #Nil))
-
- _
- (fail "Wrong syntax for ->")}
- (list\reverse tokens)))
-
-(macro:' #export (list xs)
- (#Cons [(tag$ ["lux" "doc"])
- (text$ ("lux text concat"
- ("lux text concat" "## List-construction macro." __paragraph)
- "(list +1 +2 +3)"))]
- #Nil)
- (return (#Cons (list\fold (function'' [head tail]
- (form$ (#Cons (tag$ ["lux" "Cons"])
- (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])]))
- #Nil))))
- (tag$ ["lux" "Nil"])
- (list\reverse xs))
- #Nil)))
-
-(macro:' #export (list& xs)
- (#Cons [(tag$ ["lux" "doc"])
- (text$ ("lux text concat"
- ("lux text concat" "## List-construction macro, with the last element being a tail-list." __paragraph)
- ("lux text concat"
- ("lux text concat" "## In other words, this macro prepends elements to another list." __paragraph)
- "(list& +1 +2 +3 (list +4 +5 +6))")))]
- #Nil)
- ({(#Cons last init)
- (return (list (list\fold (function'' [head tail]
- (form$ (list (tag$ ["lux" "Cons"])
- (tuple$ (list head tail)))))
- last
- init)))
-
- _
- (fail "Wrong syntax for list&")}
- (list\reverse xs)))
-
-(macro:' #export (& tokens)
- (#Cons [(tag$ ["lux" "doc"])
- (text$ ("lux text concat"
- ("lux text concat" "## Tuple types:" __paragraph)
- ("lux text concat"
- ("lux text concat" "(& Text Int Bit)" __paragraph)
- ("lux text concat"
- ("lux text concat" "## Any." __paragraph)
- "(&)"))))]
- #Nil)
- ({#Nil
- (return (list (identifier$ ["lux" "Any"])))
-
- (#Cons last prevs)
- (return (list (list\fold (function'' [left right] (form$ (list (tag$ ["lux" "Product"]) left right)))
- last
- prevs)))}
- (list\reverse tokens)))
-
-(macro:' #export (| tokens)
- (#Cons [(tag$ ["lux" "doc"])
- (text$ ("lux text concat"
- ("lux text concat" "## Variant types:" __paragraph)
- ("lux text concat"
- ("lux text concat" "(| Text Int Bit)" __paragraph)
- ("lux text concat"
- ("lux text concat" "## Nothing." __paragraph)
- "(|)"))))]
- #Nil)
- ({#Nil
- (return (list (identifier$ ["lux" "Nothing"])))
-
- (#Cons last prevs)
- (return (list (list\fold (function'' [left right] (form$ (list (tag$ ["lux" "Sum"]) left right)))
- last
- prevs)))}
- (list\reverse tokens)))
-
-(macro:' (function' tokens)
- (let'' [name tokens'] ({(#Cons [[_ (#Identifier ["" name])] tokens'])
- [name tokens']
-
- _
- ["" tokens]}
- tokens)
- ({(#Cons [[_ (#Tuple args)] (#Cons [body #Nil])])
- ({#Nil
- (fail "function' requires a non-empty arguments tuple.")
-
- (#Cons [harg targs])
- (return (list (form$ (list (tuple$ (list (local_identifier$ name)
- harg))
- (list\fold (function'' [arg body']
- (form$ (list (tuple$ (list (local_identifier$ "")
- arg))
- body')))
- body
- (list\reverse targs))))))}
- args)
-
- _
- (fail "Wrong syntax for function'")}
- tokens')))
-
-(macro:' (def:''' tokens)
- ({(#Cons [[_ (#Tag ["" "export"])]
- (#Cons [[_ (#Form (#Cons [name args]))]
- (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])])
- (return (list (form$ (list (text$ "lux def")
- name
- (form$ (list (text$ "lux type check")
- type
- (form$ (list (identifier$ ["lux" "function'"])
- name
- (tuple$ args)
- body))))
- (form$ (#Cons (identifier$ ["lux" "record$"])
- (#Cons meta
- #Nil)))
- (bit$ #1)))))
-
- (#Cons [[_ (#Tag ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])])
- (return (list (form$ (list (text$ "lux def")
- name
- (form$ (list (text$ "lux type check")
- type
- body))
- (form$ (#Cons (identifier$ ["lux" "record$"])
- (#Cons meta
- #Nil)))
- (bit$ #1)))))
-
- (#Cons [[_ (#Form (#Cons [name args]))]
- (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])
- (return (list (form$ (list (text$ "lux def")
- name
- (form$ (list (text$ "lux type check")
- type
- (form$ (list (identifier$ ["lux" "function'"])
- name
- (tuple$ args)
- body))))
- (form$ (#Cons (identifier$ ["lux" "record$"])
- (#Cons meta
- #Nil)))
- (bit$ #0)))))
-
- (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])
- (return (list (form$ (list (text$ "lux def")
- name
- (form$ (list (text$ "lux type check") type body))
- (form$ (#Cons (identifier$ ["lux" "record$"])
- (#Cons meta
- #Nil)))
- (bit$ #0)))))
-
- _
- (fail "Wrong syntax for def:'''")}
- tokens))
-
-(def:''' (as_pairs xs)
- #Nil
- (All [a] (-> ($' List a) ($' List (& a a))))
- ({(#Cons x (#Cons y xs'))
- (#Cons [x y] (as_pairs xs'))
-
- _
- #Nil}
- xs))
-
-(macro:' (let' tokens)
- ({(#Cons [[_ (#Tuple bindings)] (#Cons [body #Nil])])
- (return (list (list\fold ("lux type check" (-> (& Code Code) Code
- Code)
- (function' [binding body]
- ({[label value]
- (form$ (list (record$ (list [label body])) value))}
- binding)))
- body
- (list\reverse (as_pairs bindings)))))
-
- _
- (fail "Wrong syntax for let'")}
- tokens))
-
-(def:''' (any? p xs)
- #Nil
- (All [a]
- (-> (-> a Bit) ($' List a) Bit))
- ({#Nil
- #0
-
- (#Cons x xs')
- ({#1 #1
- #0 (any? p xs')}
- (p x))}
- xs))
-
-(def:''' (wrap_meta content)
- #Nil
- (-> Code Code)
- (tuple$ (list (tuple$ (list (text$ "") (nat$ 0) (nat$ 0)))
- content)))
-
-(def:''' (untemplate_list tokens)
- #Nil
- (-> ($' List Code) Code)
- ({#Nil
- (_ann (#Tag ["lux" "Nil"]))
-
- (#Cons [token tokens'])
- (_ann (#Form (list (_ann (#Tag ["lux" "Cons"])) token (untemplate_list tokens'))))}
- tokens))
-
-(def:''' (list\compose xs ys)
- #Nil
- (All [a] (-> ($' List a) ($' List a) ($' List a)))
- ({(#Cons x xs')
- (#Cons x (list\compose xs' ys))
-
- #Nil
- ys}
- xs))
-
-(def:''' (_$_joiner op a1 a2)
- #Nil
- (-> Code Code Code Code)
- ({[_ (#Form parts)]
- (form$ (list\compose parts (list a1 a2)))
-
- _
- (form$ (list op a1 a2))}
- op))
-
-(def:''' (function/flip func)
- #Nil
- (All [a b c]
- (-> (-> a b c) (-> b a c)))
- (function' [right left]
- (func left right)))
-
-(macro:' #export (_$ tokens)
- (#Cons [(tag$ ["lux" "doc"])
- (text$ ("lux text concat"
- ("lux text concat" "## Left-association for the application of binary functions over variadic arguments." ..\n)
- ("lux text concat"
- ("lux text concat" "(_$ text\compose ''Hello, '' name ''. How are you?'')" ..\n)
- ("lux text concat"
- ("lux text concat" "## =>" ..\n)
- "(text\compose (text\compose ''Hello, '' name) ''. How are you?'')"))))]
- #Nil)
- ({(#Cons op tokens')
- ({(#Cons first nexts)
- (return (list (list\fold (function/flip (_$_joiner op)) first nexts)))
-
- _
- (fail "Wrong syntax for _$")}
- tokens')
-
- _
- (fail "Wrong syntax for _$")}
- tokens))
-
-(macro:' #export ($_ tokens)
- (#Cons [(tag$ ["lux" "doc"])
- (text$ ("lux text concat"
- ("lux text concat" "## Right-association for the application of binary functions over variadic arguments." ..\n)
- ("lux text concat"
- ("lux text concat" "($_ text\compose ''Hello, '' name ''. How are you?'')" ..\n)
- ("lux text concat"
- ("lux text concat" "## =>" ..\n)
- "(text\compose ''Hello, '' (text\compose name ''. How are you?''))"))))]
- #Nil)
- ({(#Cons op tokens')
- ({(#Cons last prevs)
- (return (list (list\fold (_$_joiner op) last prevs)))
-
- _
- (fail "Wrong syntax for $_")}
- (list\reverse tokens'))
-
- _
- (fail "Wrong syntax for $_")}
- tokens))
-
-## (interface: (Monad m)
-## (: (All [a] (-> a (m a)))
-## wrap)
-## (: (All [a b] (-> (-> a (m b)) (m a) (m b)))
-## bind))
-("lux def type tagged" Monad
- (#Named ["lux" "Monad"]
- (All [m]
- (& (All [a] (-> a ($' m a)))
- (All [a b] (-> (-> a ($' m b))
- ($' m a)
- ($' m b))))))
- (record$ (list))
- ["wrap" "bind"]
- #0)
-
-(def:''' maybe_monad
- #Nil
- ($' Monad Maybe)
- {#wrap
- (function' [x] (#Some x))
-
- #bind
- (function' [f ma]
- ({#None #None
- (#Some a) (f a)}
- ma))})
-
-(def:''' meta_monad
- #Nil
- ($' Monad Meta)
- {#wrap
- (function' [x]
- (function' [state]
- (#Right state x)))
-
- #bind
- (function' [f ma]
- (function' [state]
- ({(#Left msg)
- (#Left msg)
-
- (#Right [state' a])
- (f a state')}
- (ma state))))})
-
-(macro:' (do tokens)
- ({(#Cons monad (#Cons [_ (#Tuple bindings)] (#Cons body #Nil)))
- (let' [g!wrap (local_identifier$ "wrap")
- g!bind (local_identifier$ " bind ")
- body' (list\fold ("lux type check" (-> (& Code Code) Code Code)
- (function' [binding body']
- (let' [[var value] binding]
- ({[_ (#Tag "" "let")]
- (form$ (list (identifier$ ["lux" "let'"]) value body'))
-
- _
- (form$ (list g!bind
- (form$ (list (tuple$ (list (local_identifier$ "") var)) body'))
- value))}
- var))))
- body
- (list\reverse (as_pairs bindings)))]
- (return (list (form$ (list (record$ (list [(record$ (list [(tag$ ["lux" "wrap"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind]))
- body']))
- monad)))))
-
- _
- (fail "Wrong syntax for do")}
- tokens))
-
-(def:''' (monad\map 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]
- ({#Nil
- (wrap #Nil)
-
- (#Cons x xs')
- (do m
- [y (f x)
- ys (monad\map m f xs')]
- (wrap (#Cons y ys)))}
- xs)))
-
-(def:''' (monad\fold m f y xs)
- #Nil
- ## (All [m a b]
- ## (-> (Monad m) (-> a b (m b)) b (List a) (m b)))
- (All [m a b]
- (-> ($' Monad m)
- (-> a b ($' m b))
- b
- ($' List a)
- ($' m b)))
- (let' [{#wrap wrap #bind _} m]
- ({#Nil
- (wrap y)
-
- (#Cons x xs')
- (do m
- [y' (f x y)]
- (monad\fold m f y' xs'))}
- xs)))
-
-(macro:' #export (if tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "Picks which expression to evaluate based on a bit test value." __paragraph
- "(if #1 ''Oh, yeah!'' ''Aw hell naw!'')" __paragraph
- "=> ''Oh, yeah!''"))])
- ({(#Cons test (#Cons then (#Cons else #Nil)))
- (return (list (form$ (list (record$ (list [(bit$ #1) then]
- [(bit$ #0) else]))
- test))))
-
- _
- (fail "Wrong syntax for if")}
- tokens))
-
-(def:''' (get k plist)
- #Nil
- (All [a]
- (-> Text ($' List (& Text a)) ($' Maybe a)))
- ({(#Cons [[k' v] plist'])
- (if (text\= k k')
- (#Some v)
- (get k plist'))
-
- #Nil
- #None}
- plist))
-
-(def:''' (put k v dict)
- #Nil
- (All [a]
- (-> Text a ($' List (& Text a)) ($' List (& Text a))))
- ({#Nil
- (list [k v])
-
- (#Cons [[k' v'] dict'])
- (if (text\= k k')
- (#Cons [[k' v] dict'])
- (#Cons [[k' v'] (put k v dict')]))}
- dict))
-
-(def:''' (text\compose x y)
- #Nil
- (-> Text Text Text)
- ("lux text concat" x y))
-
-(def:''' (name\encode full_name)
- #Nil
- (-> Name Text)
- (let' [[module name] full_name]
- ({"" name
- _ ($_ text\compose module "." name)}
- module)))
-
-(def:''' (get_meta tag def_meta)
- #Nil
- (-> Name Code ($' Maybe Code))
- (let' [[prefix name] tag]
- ({[_ (#Record def_meta)]
- ({(#Cons [key value] def_meta')
- ({[_ (#Tag [prefix' name'])]
- ({[#1 #1]
- (#Some value)
-
- _
- (get_meta tag (record$ def_meta'))}
- [(text\= prefix prefix')
- (text\= name name')])
-
- _
- (get_meta tag (record$ def_meta'))}
- key)
-
- #Nil
- #None}
- def_meta)
-
- _
- #None}
- def_meta)))
-
-(def:''' (resolve_global_identifier full_name state)
- #Nil
- (-> Name ($' Meta Name))
- (let' [[module name] full_name
- {#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected #location location #extensions extensions
- #scope_type_vars scope_type_vars} state]
- ({(#Some {#module_hash _ #module_aliases _ #definitions definitions #imports _ #tags tags #types types #module_annotations _ #module_state _})
- ({(#Some constant)
- ({(#Left real_name)
- (#Right [state real_name])
-
- (#Right [exported? def_type def_meta def_value])
- (#Right [state full_name])}
- constant)
-
- #None
- (#Left ($_ text\compose "Unknown definition: " (name\encode full_name)))}
- (get name definitions))
-
- #None
- (#Left ($_ text\compose "Unknown module: " module " @ " (name\encode full_name)))}
- (get module modules))))
-
-(def:''' (as_code_list expression)
- #Nil
- (-> Code Code)
- (let' [type (form$ (list (tag$ ["lux" "Apply"])
- (identifier$ ["lux" "Code"])
- (identifier$ ["lux" "List"])))]
- (form$ (list (text$ "lux type check") type expression))))
-
-(def:''' (splice replace? untemplate elems)
- #Nil
- (-> Bit (-> Code ($' Meta Code)) ($' List Code) ($' Meta Code))
- ({#1
- ({#Nil
- (return (tag$ ["lux" "Nil"]))
-
- (#Cons lastI inits)
- (do meta_monad
- [lastO ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))]
- (wrap (as_code_list spliced))
-
- _
- (do meta_monad
- [lastO (untemplate lastI)]
- (wrap (as_code_list (form$ (list (tag$ ["lux" "Cons"])
- (tuple$ (list lastO (tag$ ["lux" "Nil"]))))))))}
- lastI)]
- (monad\fold meta_monad
- (function' [leftI rightO]
- ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))]
- (let' [g!in-module (form$ (list (text$ "lux in-module")
- (text$ "lux")
- (identifier$ ["lux" "list\compose"])))]
- (wrap (form$ (list g!in-module (as_code_list spliced) rightO))))
-
- _
- (do meta_monad
- [leftO (untemplate leftI)]
- (wrap (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list leftO rightO))))))}
- leftI))
- lastO
- inits))}
- (list\reverse elems))
- #0
- (do meta_monad
- [=elems (monad\map meta_monad untemplate elems)]
- (wrap (untemplate_list =elems)))}
- replace?))
-
-(def:''' (untemplate_text value)
- #Nil
- (-> Text Code)
- (wrap_meta (form$ (list (tag$ ["lux" "Text"]) (text$ value)))))
-
-(def:''' (untemplate replace? subst token)
- #Nil
- (-> Bit Text Code ($' Meta Code))
- ({[_ [_ (#Bit value)]]
- (return (wrap_meta (form$ (list (tag$ ["lux" "Bit"]) (bit$ value)))))
-
- [_ [_ (#Nat value)]]
- (return (wrap_meta (form$ (list (tag$ ["lux" "Nat"]) (nat$ value)))))
-
- [_ [_ (#Int value)]]
- (return (wrap_meta (form$ (list (tag$ ["lux" "Int"]) (int$ value)))))
-
- [_ [_ (#Rev value)]]
- (return (wrap_meta (form$ (list (tag$ ["lux" "Rev"]) (rev$ value)))))
-
- [_ [_ (#Frac value)]]
- (return (wrap_meta (form$ (list (tag$ ["lux" "Frac"]) (frac$ value)))))
-
- [_ [_ (#Text value)]]
- (return (untemplate_text value))
-
- [#0 [_ (#Tag [module name])]]
- (return (wrap_meta (form$ (list (tag$ ["lux" "Tag"]) (tuple$ (list (text$ module) (text$ name)))))))
-
- [#1 [_ (#Tag [module name])]]
- (let' [module' ({""
- subst
-
- _
- module}
- module)]
- (return (wrap_meta (form$ (list (tag$ ["lux" "Tag"]) (tuple$ (list (text$ module') (text$ name))))))))
-
- [#1 [_ (#Identifier [module name])]]
- (do meta_monad
- [real_name ({""
- (if (text\= "" subst)
- (wrap [module name])
- (resolve_global_identifier [subst name]))
-
- _
- (wrap [module name])}
- module)
- #let [[module name] real_name]]
- (return (wrap_meta (form$ (list (tag$ ["lux" "Identifier"]) (tuple$ (list (text$ module) (text$ name))))))))
-
- [#0 [_ (#Identifier [module name])]]
- (return (wrap_meta (form$ (list (tag$ ["lux" "Identifier"]) (tuple$ (list (text$ module) (text$ name)))))))
-
- [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~"])] (#Cons [unquoted #Nil])]))]]
- (return (form$ (list (text$ "lux type check")
- (identifier$ ["lux" "Code"])
- unquoted)))
-
- [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~!"])] (#Cons [dependent #Nil])]))]]
- (do meta_monad
- [independent (untemplate replace? subst dependent)]
- (wrap (wrap_meta (form$ (list (tag$ ["lux" "Form"])
- (untemplate_list (list (untemplate_text "lux in-module")
- (untemplate_text subst)
- independent)))))))
-
- [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~'"])] (#Cons [keep_quoted #Nil])]))]]
- (untemplate #0 subst keep_quoted)
-
- [_ [meta (#Form elems)]]
- (do meta_monad
- [output (splice replace? (untemplate replace? subst) elems)
- #let [[_ output'] (wrap_meta (form$ (list (tag$ ["lux" "Form"]) output)))]]
- (wrap [meta output']))
-
- [_ [meta (#Tuple elems)]]
- (do meta_monad
- [output (splice replace? (untemplate replace? subst) elems)
- #let [[_ output'] (wrap_meta (form$ (list (tag$ ["lux" "Tuple"]) output)))]]
- (wrap [meta output']))
-
- [_ [_ (#Record fields)]]
- (do meta_monad
- [=fields (monad\map meta_monad
- ("lux type check" (-> (& Code Code) ($' Meta Code))
- (function' [kv]
- (let' [[k v] kv]
- (do meta_monad
- [=k (untemplate replace? subst k)
- =v (untemplate replace? subst v)]
- (wrap (tuple$ (list =k =v)))))))
- fields)]
- (wrap (wrap_meta (form$ (list (tag$ ["lux" "Record"]) (untemplate_list =fields))))))}
- [replace? token]))
-
-(macro:' #export (primitive tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Macro to treat define new primitive types." __paragraph
- "(primitive ''java.lang.Object'')" __paragraph
- "(primitive ''java.util.List'' [(primitive ''java.lang.Long'')])"))])
- ({(#Cons [_ (#Text class_name)] #Nil)
- (return (list (form$ (list (tag$ ["lux" "Primitive"]) (text$ class_name) (tag$ ["lux" "Nil"])))))
-
- (#Cons [_ (#Text class_name)] (#Cons [_ (#Tuple params)] #Nil))
- (return (list (form$ (list (tag$ ["lux" "Primitive"]) (text$ class_name) (untemplate_list params)))))
-
- _
- (fail "Wrong syntax for primitive")}
- tokens))
-
-(def:'' (current_module_name state)
- #Nil
- ($' Meta Text)
- ({{#info info #source source #current_module current_module #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected #location location #extensions extensions
- #scope_type_vars scope_type_vars}
- ({(#Some module_name)
- (#Right [state module_name])
-
- _
- (#Left "Cannot get the module name without a module!")}
- current_module)}
- state))
-
-(macro:' #export (` tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Hygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms." __paragraph
- "## 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." __paragraph
- "(` (def: (~ name) (function ((~' _) (~+ args)) (~ body))))"))])
- ({(#Cons template #Nil)
- (do meta_monad
- [current_module current_module_name
- =template (untemplate #1 current_module template)]
- (wrap (list (form$ (list (text$ "lux type check")
- (identifier$ ["lux" "Code"])
- =template)))))
-
- _
- (fail "Wrong syntax for `")}
- tokens))
-
-(macro:' #export (`' tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Unhygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms." __paragraph
- "(`' (def: (~ name) (function (_ (~+ args)) (~ body))))"))])
- ({(#Cons template #Nil)
- (do meta_monad
- [=template (untemplate #1 "" template)]
- (wrap (list (form$ (list (text$ "lux type check") (identifier$ ["lux" "Code"]) =template)))))
-
- _
- (fail "Wrong syntax for `")}
- tokens))
-
-(macro:' #export (' tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Quotation as a macro." __paragraph
- "(' YOLO)"))])
- ({(#Cons template #Nil)
- (do meta_monad
- [=template (untemplate #0 "" template)]
- (wrap (list (form$ (list (text$ "lux type check") (identifier$ ["lux" "Code"]) =template)))))
-
- _
- (fail "Wrong syntax for '")}
- tokens))
-
-(macro:' #export (|> tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Piping macro." __paragraph
- "(|> elems (list\map int\encode) (interpose '' '') (fold text\compose ''''))" __paragraph
- "## =>" __paragraph
- "(fold text\compose '''' (interpose '' '' (list\map int\encode elems)))"))])
- ({(#Cons [init apps])
- (return (list (list\fold ("lux type check" (-> Code Code Code)
- (function' [app acc]
- ({[_ (#Tuple parts)]
- (tuple$ (list\compose parts (list acc)))
-
- [_ (#Form parts)]
- (form$ (list\compose parts (list acc)))
-
- _
- (` ((~ app) (~ acc)))}
- app)))
- init
- apps)))
-
- _
- (fail "Wrong syntax for |>")}
- tokens))
-
-(macro:' #export (<| tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Reverse piping macro." __paragraph
- "(<| (fold text\compose '''') (interpose '' '') (list\map int\encode) elems)" __paragraph
- "## =>" __paragraph
- "(fold text\compose '''' (interpose '' '' (list\map int\encode elems)))"))])
- ({(#Cons [init apps])
- (return (list (list\fold ("lux type check" (-> Code Code Code)
- (function' [app acc]
- ({[_ (#Tuple parts)]
- (tuple$ (list\compose parts (list acc)))
-
- [_ (#Form parts)]
- (form$ (list\compose parts (list acc)))
-
- _
- (` ((~ app) (~ acc)))}
- app)))
- init
- apps)))
-
- _
- (fail "Wrong syntax for <|")}
- (list\reverse tokens)))
-
-(def:''' (compose f g)
- (list [(tag$ ["lux" "doc"])
- (text$ "Function composition.")])
- (All [a b c]
- (-> (-> b c) (-> a b) (-> a c)))
- (function' [x] (f (g x))))
-
-(def:''' (get_name x)
- #Nil
- (-> Code ($' Maybe Name))
- ({[_ (#Identifier sname)]
- (#Some sname)
-
- _
- #None}
- x))
-
-(def:''' (get_tag x)
- #Nil
- (-> Code ($' Maybe Name))
- ({[_ (#Tag sname)]
- (#Some sname)
-
- _
- #None}
- x))
-
-(def:''' (get_short x)
- #Nil
- (-> Code ($' Maybe Text))
- ({[_ (#Identifier "" sname)]
- (#Some sname)
-
- _
- #None}
- x))
-
-(def:''' (tuple->list tuple)
- #Nil
- (-> Code ($' Maybe ($' List Code)))
- ({[_ (#Tuple members)]
- (#Some members)
-
- _
- #None}
- tuple))
-
-(def:''' (apply_template env template)
- #Nil
- (-> RepEnv Code Code)
- ({[_ (#Identifier "" sname)]
- ({(#Some subst)
- subst
-
- _
- template}
- (get_rep sname env))
-
- [meta (#Tuple elems)]
- [meta (#Tuple (list\map (apply_template env) elems))]
-
- [meta (#Form elems)]
- [meta (#Form (list\map (apply_template env) elems))]
-
- [meta (#Record members)]
- [meta (#Record (list\map ("lux type check" (-> (& Code Code) (& Code Code))
- (function' [kv]
- (let' [[slot value] kv]
- [(apply_template env slot) (apply_template env value)])))
- members))]
-
- _
- template}
- template))
-
-(def:''' (every? p xs)
- #Nil
- (All [a]
- (-> (-> a Bit) ($' List a) Bit))
- (list\fold (function' [_2 _1] (if _1 (p _2) #0)) #1 xs))
-
-(def:''' (high_bits value)
- (list)
- (-> ($' I64 Any) I64)
- ("lux i64 right-shift" 32 value))
-
-(def:''' low_mask
- (list)
- I64
- (|> 1 ("lux i64 left-shift" 32) ("lux i64 -" 1)))
-
-(def:''' (low_bits value)
- (list)
- (-> ($' I64 Any) I64)
- ("lux i64 and" low_mask value))
-
-(def:''' (n/< reference sample)
- (list)
- (-> Nat Nat Bit)
- (let' [referenceH (high_bits reference)
- sampleH (high_bits sample)]
- (if ("lux i64 <" referenceH sampleH)
- #1
- (if ("lux i64 =" referenceH sampleH)
- ("lux i64 <"
- (low_bits reference)
- (low_bits sample))
- #0))))
-
-(def:''' (n/<= reference sample)
- (list)
- (-> Nat Nat Bit)
- (if (n/< reference sample)
- #1
- ("lux i64 =" reference sample)))
-
-(def:''' (list\join xs)
- #Nil
- (All [a]
- (-> ($' List ($' List a)) ($' List a)))
- (list\fold list\compose #Nil (list\reverse xs)))
-
-(macro:' #export (template tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary." __paragraph
- "(template [<name> <diff>]" ..\n
- " " "[(def: #export <name> (-> Int Int) (+ <diff>))]" __paragraph
- " " "[inc +1]" ..\n
- " " "[dec -1]"))])
- ({(#Cons [[_ (#Tuple bindings)] (#Cons [[_ (#Tuple templates)] data])])
- ({[(#Some bindings') (#Some data')]
- (let' [apply ("lux type check" (-> RepEnv ($' List Code))
- (function' [env] (list\map (apply_template env) templates)))
- num_bindings (list\size bindings')]
- (if (every? (function' [size] ("lux i64 =" num_bindings size))
- (list\map list\size data'))
- (|> data'
- (list\map (compose apply (make_env bindings')))
- list\join
- return)
- (fail "Irregular arguments tuples for template.")))
-
- _
- (fail "Wrong syntax for template")}
- [(monad\map maybe_monad get_short bindings)
- (monad\map maybe_monad tuple->list data)])
-
- _
- (fail "Wrong syntax for template")}
- tokens))
-
-(def:''' (n// param subject)
- (list)
- (-> Nat Nat Nat)
- (if ("lux i64 <" +0 ("lux type as" Int param))
- (if (n/< param subject)
- 0
- 1)
- (let' [quotient (|> subject
- ("lux i64 right-shift" 1)
- ("lux i64 /" ("lux type as" Int param))
- ("lux i64 left-shift" 1))
- flat ("lux i64 *"
- ("lux type as" Int param)
- ("lux type as" Int quotient))
- remainder ("lux i64 -" flat subject)]
- (if (n/< param remainder)
- quotient
- ("lux i64 +" 1 quotient)))))
-
-(def:''' (n/% param subject)
- (list)
- (-> Nat Nat Nat)
- (let' [flat ("lux i64 *"
- ("lux type as" Int param)
- ("lux type as" Int (n// param subject)))]
- ("lux i64 -" flat subject)))
-
-(def:''' (n/min left right)
- (list)
- (-> Nat Nat Nat)
- (if (n/< right left)
- left
- right))
-
-(def:''' (bit\encode x)
- #Nil
- (-> Bit Text)
- (if x "#1" "#0"))
-
-(def:''' (digit::format digit)
- #Nil
- (-> Nat Text)
- ({0 "0"
- 1 "1" 2 "2" 3 "3"
- 4 "4" 5 "5" 6 "6"
- 7 "7" 8 "8" 9 "9"
- _ ("lux io error" "@digit::format Undefined behavior.")}
- digit))
-
-(def:''' (nat\encode value)
- #Nil
- (-> Nat Text)
- ({0
- "0"
-
- _
- (let' [loop ("lux type check" (-> Nat Text Text)
- (function' recur [input output]
- (if ("lux i64 =" 0 input)
- output
- (recur (n// 10 input)
- (text\compose (|> input (n/% 10) digit::format)
- output)))))]
- (loop value ""))}
- value))
-
-(def:''' (int\abs value)
- #Nil
- (-> Int Int)
- (if ("lux i64 <" +0 value)
- ("lux i64 *" -1 value)
- value))
-
-(def:''' (int\encode value)
- #Nil
- (-> Int Text)
- (if ("lux i64 =" +0 value)
- "+0"
- (let' [sign (if ("lux i64 <" value +0)
- "+"
- "-")]
- (("lux type check" (-> Int Text Text)
- (function' recur [input output]
- (if ("lux i64 =" +0 input)
- (text\compose sign output)
- (recur ("lux i64 /" +10 input)
- (text\compose (|> input ("lux i64 %" +10) ("lux type as" Nat) digit::format)
- output)))))
- (|> value ("lux i64 /" +10) int\abs)
- (|> value ("lux i64 %" +10) int\abs ("lux type as" Nat) digit::format)))))
-
-(def:''' (frac\encode x)
- #Nil
- (-> Frac Text)
- ("lux f64 encode" x))
-
-(def:''' (multiple? div n)
- #Nil
- (-> Nat Nat Bit)
- (|> n (n/% div) ("lux i64 =" 0)))
-
-(def:''' #export (not x)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Bit negation." __paragraph
- "(not #1) => #0" __paragraph
- "(not #0) => #1"))])
- (-> Bit Bit)
- (if x #0 #1))
-
-(def:''' (macro_type? type)
- (list)
- (-> Type Bit)
- ({(#Named ["lux" "Macro"] (#Primitive "#Macro" #Nil))
- #1
-
- _
- #0}
- type))
-
-(def:''' (find_macro' modules current_module module name)
- #Nil
- (-> ($' List (& Text Module))
- Text Text Text
- ($' Maybe Macro))
- (do maybe_monad
- [$module (get module modules)
- gdef (let' [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags #types types #module_annotations _ #module_state _} ("lux type check" Module $module)]
- (get name bindings))]
- ({(#Left [r_module r_name])
- (find_macro' modules current_module r_module r_name)
-
- (#Right [exported? def_type def_meta def_value])
- (if (macro_type? def_type)
- (if exported?
- (#Some ("lux type as" Macro def_value))
- (if (text\= module current_module)
- (#Some ("lux type as" Macro def_value))
- #None))
- #None)}
- ("lux type check" Global gdef))))
-
-(def:''' (normalize name)
- #Nil
- (-> Name ($' Meta Name))
- ({["" name]
- (do meta_monad
- [module_name current_module_name]
- (wrap [module_name name]))
-
- _
- (return name)}
- name))
-
-(def:''' (find_macro full_name)
- #Nil
- (-> Name ($' Meta ($' Maybe Macro)))
- (do meta_monad
- [current_module current_module_name]
- (let' [[module name] full_name]
- (function' [state]
- ({{#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected
- #location location #extensions extensions
- #scope_type_vars scope_type_vars}
- (#Right state (find_macro' modules current_module module name))}
- state)))))
-
-(def:''' (macro? name)
- #Nil
- (-> Name ($' Meta Bit))
- (do meta_monad
- [name (normalize name)
- output (find_macro name)]
- (wrap ({(#Some _) #1
- #None #0}
- output))))
-
-(def:''' (interpose sep xs)
- #Nil
- (All [a]
- (-> a ($' List a) ($' List a)))
- ({#Nil
- xs
-
- (#Cons [x #Nil])
- xs
-
- (#Cons [x xs'])
- (list& x sep (interpose sep xs'))}
- xs))
-
-(def:''' (macro_expand_once token)
- #Nil
- (-> Code ($' Meta ($' List Code)))
- ({[_ (#Form (#Cons [_ (#Identifier macro_name)] args))]
- (do meta_monad
- [macro_name' (normalize macro_name)
- ?macro (find_macro macro_name')]
- ({(#Some macro)
- (("lux type as" Macro' macro) args)
-
- #None
- (return (list token))}
- ?macro))
-
- _
- (return (list token))}
- token))
-
-(def:''' (macro_expand token)
- #Nil
- (-> Code ($' Meta ($' List Code)))
- ({[_ (#Form (#Cons [_ (#Identifier macro_name)] args))]
- (do meta_monad
- [macro_name' (normalize macro_name)
- ?macro (find_macro macro_name')]
- ({(#Some macro)
- (do meta_monad
- [expansion (("lux type as" Macro' macro) args)
- expansion' (monad\map meta_monad macro_expand expansion)]
- (wrap (list\join expansion')))
-
- #None
- (return (list token))}
- ?macro))
-
- _
- (return (list token))}
- token))
-
-(def:''' (macro_expand_all syntax)
- #Nil
- (-> Code ($' Meta ($' List Code)))
- ({[_ (#Form (#Cons [_ (#Identifier macro_name)] args))]
- (do meta_monad
- [macro_name' (normalize macro_name)
- ?macro (find_macro macro_name')]
- ({(#Some macro)
- (do meta_monad
- [expansion (("lux type as" Macro' macro) args)
- expansion' (monad\map meta_monad macro_expand_all expansion)]
- (wrap (list\join expansion')))
-
- #None
- (do meta_monad
- [args' (monad\map meta_monad macro_expand_all args)]
- (wrap (list (form$ (#Cons (identifier$ macro_name) (list\join args'))))))}
- ?macro))
-
- [_ (#Form members)]
- (do meta_monad
- [members' (monad\map meta_monad macro_expand_all members)]
- (wrap (list (form$ (list\join members')))))
-
- [_ (#Tuple members)]
- (do meta_monad
- [members' (monad\map meta_monad macro_expand_all members)]
- (wrap (list (tuple$ (list\join members')))))
-
- [_ (#Record pairs)]
- (do meta_monad
- [pairs' (monad\map meta_monad
- (function' [kv]
- (let' [[key val] kv]
- (do meta_monad
- [val' (macro_expand_all val)]
- ({(#Cons val'' #Nil)
- (return [key val''])
-
- _
- (fail "The value-part of a KV-pair in a record must macro-expand to a single Code.")}
- val'))))
- pairs)]
- (wrap (list (record$ pairs'))))
-
- _
- (return (list syntax))}
- syntax))
-
-(def:''' (walk_type type)
- #Nil
- (-> Code Code)
- ({[_ (#Form (#Cons [_ (#Tag tag)] parts))]
- (form$ (#Cons [(tag$ tag) (list\map walk_type parts)]))
-
- [_ (#Tuple members)]
- (` (& (~+ (list\map walk_type members))))
-
- [_ (#Form (#Cons [_ (#Text "lux in-module")]
- (#Cons [_ (#Text module)]
- (#Cons type'
- #Nil))))]
- (` ("lux in-module" (~ (text$ module)) (~ (walk_type type'))))
-
- [_ (#Form (#Cons [_ (#Identifier ["" ":~"])] (#Cons expression #Nil)))]
- expression
-
- [_ (#Form (#Cons type_fn args))]
- (list\fold ("lux type check" (-> Code Code Code)
- (function' [arg type_fn] (` (#.Apply (~ arg) (~ type_fn)))))
- (walk_type type_fn)
- (list\map walk_type args))
-
- _
- type}
- type))
-
-(macro:' #export (type tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Takes a type expression and returns it's representation as data-structure." __paragraph
- "(type (All [a] (Maybe (List a))))"))])
- ({(#Cons type #Nil)
- (do meta_monad
- [type+ (macro_expand_all type)]
- ({(#Cons type' #Nil)
- (wrap (list (walk_type type')))
-
- _
- (fail "The expansion of the type-syntax had to yield a single element.")}
- type+))
-
- _
- (fail "Wrong syntax for type")}
- tokens))
-
-(macro:' #export (: tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## The type-annotation macro." __paragraph
- "(: (List Int) (list +1 +2 +3))"))])
- ({(#Cons type (#Cons value #Nil))
- (return (list (` ("lux type check" (type (~ type)) (~ value)))))
-
- _
- (fail "Wrong syntax for :")}
- tokens))
-
-(macro:' #export (:as tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## The type-coercion macro." __paragraph
- "(:as Dinosaur (list +1 +2 +3))"))])
- ({(#Cons type (#Cons value #Nil))
- (return (list (` ("lux type as" (type (~ type)) (~ value)))))
-
- _
- (fail "Wrong syntax for :as")}
- tokens))
-
-(def:''' (empty? xs)
- #Nil
- (All [a] (-> ($' List a) Bit))
- ({#Nil #1
- _ #0}
- xs))
-
-(template [<name> <type> <value>]
- [(def:''' (<name> xy)
- #Nil
- (All [a b] (-> (& a b) <type>))
- (let' [[x y] xy] <value>))]
-
- [first a x]
- [second b y])
-
-(def:''' (unfold_type_def type_codes)
- #Nil
- (-> ($' List Code) ($' Meta (& Code ($' Maybe ($' List Text)))))
- ({(#Cons [_ (#Record pairs)] #Nil)
- (do meta_monad
- [members (monad\map meta_monad
- (: (-> [Code Code] (Meta [Text Code]))
- (function' [pair]
- ({[[_ (#Tag "" member_name)] member_type]
- (return [member_name member_type])
-
- _
- (fail "Wrong syntax for variant case.")}
- pair)))
- pairs)]
- (return [(` (& (~+ (list\map second members))))
- (#Some (list\map first members))]))
-
- (#Cons type #Nil)
- ({[_ (#Tag "" member_name)]
- (return [(` .Any) (#Some (list member_name))])
-
- [_ (#Form (#Cons [_ (#Tag "" member_name)] member_types))]
- (return [(` (& (~+ member_types))) (#Some (list member_name))])
-
- _
- (return [type #None])}
- type)
-
- (#Cons case cases)
- (do meta_monad
- [members (monad\map meta_monad
- (: (-> Code (Meta [Text Code]))
- (function' [case]
- ({[_ (#Tag "" member_name)]
- (return [member_name (` .Any)])
-
- [_ (#Form (#Cons [_ (#Tag "" member_name)] (#Cons member_type #Nil)))]
- (return [member_name member_type])
-
- [_ (#Form (#Cons [_ (#Tag "" member_name)] member_types))]
- (return [member_name (` (& (~+ member_types)))])
-
- _
- (fail "Wrong syntax for variant case.")}
- case)))
- (list& case cases))]
- (return [(` (| (~+ (list\map second members))))
- (#Some (list\map first members))]))
-
- _
- (fail "Improper type-definition syntax")}
- type_codes))
-
-(def:''' (gensym prefix state)
- #Nil
- (-> Text ($' Meta Code))
- ({{#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected
- #location location #extensions extensions
- #scope_type_vars scope_type_vars}
- (#Right {#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed ("lux i64 +" 1 seed) #expected expected
- #location location #extensions extensions
- #scope_type_vars scope_type_vars}
- (local_identifier$ ($_ text\compose "__gensym__" prefix (nat\encode seed))))}
- state))
-
-(macro:' #export (Rec tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Parameter-less recursive types." __paragraph
- "## A name has to be given to the whole type, to use it within its body." __paragraph
- "(Rec Self [Int (List Self)])"))])
- ({(#Cons [_ (#Identifier "" name)] (#Cons body #Nil))
- (let' [body' (replace_syntax (list [name (` (#.Apply (~ (make_parameter 1)) (~ (make_parameter 0))))])
- (update_parameters body))]
- (return (list (` (#.Apply .Nothing (#.UnivQ #.Nil (~ body')))))))
-
- _
- (fail "Wrong syntax for Rec")}
- tokens))
-
-(macro:' #export (exec tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Sequential execution of expressions (great for side-effects)." __paragraph
- "(exec" ..\n
- " " "(log! ''#1'')" ..\n
- " " "(log! ''#2'')" ..\n
- " " "(log! ''#3'')" ..\n
- "''YOLO'')"))])
- ({(#Cons value actions)
- (let' [dummy (local_identifier$ "")]
- (return (list (list\fold ("lux type check" (-> Code Code Code)
- (function' [pre post] (` ({(~ dummy) (~ post)}
- (~ pre)))))
- value
- actions))))
-
- _
- (fail "Wrong syntax for exec")}
- (list\reverse tokens)))
-
-(macro:' (def:' tokens)
- (let' [[export? tokens'] ({(#Cons [_ (#Tag ["" "export"])] tokens')
- [#1 tokens']
-
- _
- [#0 tokens]}
- tokens)
- parts (: (Maybe [Code (List Code) (Maybe Code) Code])
- ({(#Cons [_ (#Form (#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 [_ (#Form (#Cons name args))] (#Cons body #Nil))
- (#Some name args #None body)
-
- (#Cons name (#Cons body #Nil))
- (#Some name #Nil #None body)
-
- _
- #None}
- tokens'))]
- ({(#Some name args ?type body)
- (let' [body' ({#Nil
- body
-
- _
- (` (function' (~ name) [(~+ args)] (~ body)))}
- args)
- body'' ({(#Some type)
- (` (: (~ type) (~ body')))
-
- #None
- body'}
- ?type)]
- (return (list (` ("lux def" (~ name)
- (~ body'')
- [(~ location_code)
- (#.Record #.Nil)]
- (~ (bit$ export?)))))))
-
- #None
- (fail "Wrong syntax for def'")}
- parts)))
-
-(def:' (rejoin_pair pair)
- (-> [Code Code] (List Code))
- (let' [[left right] pair]
- (list left right)))
-
-(def:' (text\encode original)
- (-> Text Text)
- ($_ text\compose ..double_quote original ..double_quote))
-
-(def:' (code\encode code)
- (-> Code Text)
- ({[_ (#Bit value)]
- (bit\encode value)
-
- [_ (#Nat value)]
- (nat\encode value)
-
- [_ (#Int value)]
- (int\encode value)
-
- [_ (#Rev value)]
- ("lux io error" "@code\encode Undefined behavior.")
-
- [_ (#Frac value)]
- (frac\encode value)
-
- [_ (#Text value)]
- (text\encode value)
-
- [_ (#Identifier [prefix name])]
- (if (text\= "" prefix)
- name
- ($_ text\compose prefix "." name))
-
- [_ (#Tag [prefix name])]
- (if (text\= "" prefix)
- ($_ text\compose "#" name)
- ($_ text\compose "#" prefix "." name))
-
- [_ (#Form xs)]
- ($_ text\compose "(" (|> xs
- (list\map code\encode)
- (interpose " ")
- list\reverse
- (list\fold text\compose "")) ")")
-
- [_ (#Tuple xs)]
- ($_ text\compose "[" (|> xs
- (list\map code\encode)
- (interpose " ")
- list\reverse
- (list\fold text\compose "")) "]")
-
- [_ (#Record kvs)]
- ($_ text\compose "{" (|> kvs
- (list\map (function' [kv] ({[k v] ($_ text\compose (code\encode k) " " (code\encode v))}
- kv)))
- (interpose " ")
- list\reverse
- (list\fold text\compose "")) "}")}
- code))
-
-(def:' (expander branches)
- (-> (List Code) (Meta (List Code)))
- ({(#Cons [_ (#Form (#Cons [_ (#Identifier macro_name)] macro_args))]
- (#Cons body
- branches'))
- (do meta_monad
- [??? (macro? macro_name)]
- (if ???
- (do meta_monad
- [init_expansion (macro_expand_once (form$ (list& (identifier$ macro_name) (form$ macro_args) body branches')))]
- (expander init_expansion))
- (do meta_monad
- [sub_expansion (expander branches')]
- (wrap (list& (form$ (list& (identifier$ macro_name) macro_args))
- body
- sub_expansion)))))
-
- (#Cons pattern (#Cons body branches'))
- (do meta_monad
- [sub_expansion (expander branches')]
- (wrap (list& pattern body sub_expansion)))
-
- #Nil
- (do meta_monad [] (wrap (list)))
-
- _
- (fail ($_ text\compose "'lux.case' expects an even number of tokens: " (|> branches
- (list\map code\encode)
- (interpose " ")
- list\reverse
- (list\fold text\compose ""))))}
- branches))
-
-(macro:' #export (case tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## The pattern-matching macro." ..\n
- "## Allows the usage of macros within the patterns to provide custom syntax." ..\n
- "(case (: (List Int) (list +1 +2 +3))" ..\n
- " " "(#Cons x (#Cons y (#Cons z #Nil)))" ..\n
- " " "(#Some ($_ * x y z))" __paragraph
- " " "_" ..\n
- " " "#None)"))])
- ({(#Cons value branches)
- (do meta_monad
- [expansion (expander branches)]
- (wrap (list (` ((~ (record$ (as_pairs expansion))) (~ value))))))
-
- _
- (fail "Wrong syntax for case")}
- tokens))
-
-(macro:' #export (^ tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Macro-expanding patterns." ..\n
- "## It's a special macro meant to be used with 'case'." ..\n
- "(case (: (List Int) (list +1 +2 +3))" ..\n
- " (^ (list x y z))" ..\n
- " (#Some ($_ * x y z))"
- __paragraph
- " _" ..\n
- " #None)"))])
- (case tokens
- (#Cons [_ (#Form (#Cons pattern #Nil))] (#Cons body branches))
- (do meta_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 [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Or-patterns." ..\n
- "## It's a special macro meant to be used with 'case'." ..\n
- "(type: Weekday #Monday #Tuesday #Wednesday #Thursday #Friday #Saturday #Sunday)"
- __paragraph
- "(def: (weekend? day)" ..\n
- " (-> Weekday Bit)" ..\n
- " (case day" ..\n
- " (^or #Saturday #Sunday)" ..\n
- " #1"
- __paragraph
- " _" ..\n
- " #0))"))])
- (case tokens
- (^ (list& [_ (#Form patterns)] body branches))
- (case patterns
- #Nil
- (fail "^or cannot have 0 patterns")
-
- _
- (let' [pairs (|> patterns
- (list\map (function' [pattern] (list pattern body)))
- (list\join))]
- (return (list\compose pairs branches))))
- _
- (fail "Wrong syntax for ^or")))
-
-(def:' (identifier? code)
- (-> Code Bit)
- (case code
- [_ (#Identifier _)]
- #1
-
- _
- #0))
-
-(macro:' #export (let tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Creates local bindings." ..\n
- "## Can (optionally) use pattern-matching macros when binding." ..\n
- "(let [x (foo bar)" ..\n
- " y (baz quux)]" ..\n
- " (op x y))"))])
- (case tokens
- (^ (list [_ (#Tuple bindings)] body))
- (if (multiple? 2 (list\size bindings))
- (|> bindings as_pairs list\reverse
- (list\fold (: (-> [Code Code] Code Code)
- (function' [lr body']
- (let' [[l r] lr]
- (if (identifier? l)
- (` ({(~ l) (~ body')} (~ r)))
- (` (case (~ r) (~ l) (~ body')))))))
- body)
- list
- return)
- (fail "let requires an even number of parts"))
-
- _
- (fail "Wrong syntax for let")))
-
-(macro:' #export (function tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Syntax for creating functions." ..\n
- "## Allows for giving the function itself a name, for the sake of recursion." ..\n
- "(: (All [a b] (-> a b a))" ..\n
- " (function (_ x y) x))"
- __paragraph
- "(: (All [a b] (-> a b a))" ..\n
- " (function (const x y) x))"))])
- (case (: (Maybe [Text Code (List Code) Code])
- (case tokens
- (^ (list [_ (#Form (list& [_ (#Identifier ["" name])] head tail))] body))
- (#Some name head tail body)
-
- _
- #None))
- (#Some g!name head tail body)
- (let [g!blank (local_identifier$ "")
- nest (: (-> Code (-> Code Code Code))
- (function' [g!name]
- (function' [arg body']
- (if (identifier? arg)
- (` ([(~ g!name) (~ arg)] (~ body')))
- (` ([(~ g!name) (~ g!blank)]
- (.case (~ g!blank) (~ arg) (~ body'))))))))]
- (return (list (nest (..local_identifier$ g!name) head
- (list\fold (nest g!blank) body (list\reverse tail))))))
-
- #None
- (fail "Wrong syntax for function")))
-
-(def:' (process_def_meta_value code)
- (-> Code Code)
- (case code
- [_ (#Bit value)]
- (meta_code ["lux" "Bit"] (bit$ value))
-
- [_ (#Nat value)]
- (meta_code ["lux" "Nat"] (nat$ value))
-
- [_ (#Int value)]
- (meta_code ["lux" "Int"] (int$ value))
-
- [_ (#Rev value)]
- (meta_code ["lux" "Rev"] (rev$ value))
-
- [_ (#Frac value)]
- (meta_code ["lux" "Frac"] (frac$ value))
-
- [_ (#Text value)]
- (meta_code ["lux" "Text"] (text$ value))
-
- [_ (#Tag [prefix name])]
- (meta_code ["lux" "Tag"] (` [(~ (text$ prefix)) (~ (text$ name))]))
-
- (^or [_ (#Form _)] [_ (#Identifier _)])
- code
-
- [_ (#Tuple xs)]
- (|> xs
- (list\map process_def_meta_value)
- untemplate_list
- (meta_code ["lux" "Tuple"]))
-
- [_ (#Record kvs)]
- (|> kvs
- (list\map (: (-> [Code Code] Code)
- (function (_ [k v])
- (` [(~ (process_def_meta_value k))
- (~ (process_def_meta_value v))]))))
- untemplate_list
- (meta_code ["lux" "Record"]))
- ))
-
-(def:' (process_def_meta kvs)
- (-> (List [Code Code]) Code)
- (untemplate_list (list\map (: (-> [Code Code] Code)
- (function (_ [k v])
- (` [(~ (process_def_meta_value k))
- (~ (process_def_meta_value v))])))
- kvs)))
-
-(def:' (with_func_args args meta)
- (-> (List Code) Code Code)
- (case args
- #Nil
- meta
-
- _
- (` (#.Cons [[(~ location_code) (#.Tag ["lux" "func-args"])]
- [(~ location_code) (#.Tuple (.list (~+ (list\map (function (_ arg)
- (` [(~ location_code) (#.Text (~ (text$ (code\encode arg))))]))
- args))))]]
- (~ meta)))))
-
-(def:' (with_type_args args)
- (-> (List Code) Code)
- (` {#.type-args [(~+ (list\map (function (_ arg) (text$ (code\encode arg)))
- args))]}))
-
-(def:' (export^ tokens)
- (-> (List Code) [Bit (List Code)])
- (case tokens
- (#Cons [_ (#Tag [_ "export"])] tokens')
- [#1 tokens']
-
- _
- [#0 tokens]))
-
-(def:' (export ?)
- (-> Bit (List Code))
- (if ?
- (list (' #export))
- (list)))
-
-(macro:' #export (def: tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Defines global constants/functions." ..\n
- "(def: (rejoin_pair pair)" ..\n
- " (-> [Code Code] (List Code))" ..\n
- " (let [[left right] pair]" ..\n
- " (list left right)))"
- __paragraph
- "(def: branching_exponent" ..\n
- " Int" ..\n
- " +5)"))])
- (let [[exported? tokens'] (export^ tokens)
- parts (: (Maybe [Code (List Code) (Maybe Code) Code (List [Code Code])])
- (case tokens'
- (^ (list [_ (#Form (#Cons name args))] [_ (#Record meta_kvs)] type body))
- (#Some [name args (#Some type) body meta_kvs])
-
- (^ (list name [_ (#Record meta_kvs)] type body))
- (#Some [name #Nil (#Some type) body meta_kvs])
-
- (^ (list [_ (#Form (#Cons name args))] [_ (#Record meta_kvs)] body))
- (#Some [name args #None body meta_kvs])
-
- (^ (list name [_ (#Record meta_kvs)] body))
- (#Some [name #Nil #None body meta_kvs])
-
- (^ (list [_ (#Form (#Cons name args))] type body))
- (#Some [name args (#Some type) body #Nil])
-
- (^ (list name type body))
- (#Some [name #Nil (#Some type) body #Nil])
-
- (^ (list [_ (#Form (#Cons name args))] body))
- (#Some [name args #None body #Nil])
-
- (^ (list name body))
- (#Some [name #Nil #None body #Nil])
-
- _
- #None))]
- (case parts
- (#Some name args ?type body meta)
- (let [body (case args
- #Nil
- body
-
- _
- (` (function ((~ name) (~+ args)) (~ body))))
- body (case ?type
- (#Some type)
- (` (: (~ type) (~ body)))
-
- #None
- body)
- =meta (process_def_meta meta)]
- (return (list (` ("lux def" (~ name)
- (~ body)
- [(~ location_code)
- (#.Record (~ (with_func_args args =meta)))]
- (~ (bit$ exported?)))))))
-
- #None
- (fail "Wrong syntax for def:"))))
-
-(def: (meta_code_add addition meta)
- (-> [Code Code] Code Code)
- (case [addition meta]
- [[name value] [location (#Record pairs)]]
- [location (#Record (#Cons [name value] pairs))]
-
- _
- meta))
-
-(def: (meta_code_merge addition base)
- (-> Code Code Code)
- (case addition
- [location (#Record pairs)]
- (list\fold meta_code_add base pairs)
-
- _
- base))
-
-(macro:' #export (macro: tokens)
- (list [(tag$ ["lux" "doc"])
- (text$ ($_ "lux text concat"
- "## Macro-definition macro." ..\n
- "(macro: #export (name_of tokens)" ..\n
- " (case tokens" ..\n
- " (^template [<tag>]" ..\n
- " [(^ (list [_ (<tag> [prefix name])]))" ..\n
- " (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))])" ..\n
- " ([#Identifier] [#Tag])"
- __paragraph
- " _" ..\n
- " (fail ''Wrong syntax for name_of'')))"))])
- (let [[exported? tokens] (export^ tokens)
- name+args+meta+body?? (: (Maybe [Name (List Code) (List [Code Code]) Code])
- (case tokens
- (^ (list [_ (#Form (list& [_ (#Identifier name)] args))] body))
- (#Some [name args (list) body])
-
- (^ (list [_ (#Identifier name)] body))
- (#Some [name #Nil (list) body])
-
- (^ (list [_ (#Form (list& [_ (#Identifier name)] args))] [_ (#Record meta_rec_parts)] body))
- (#Some [name args meta_rec_parts body])
-
- (^ (list [_ (#Identifier name)] [_ (#Record meta_rec_parts)] body))
- (#Some [name #Nil meta_rec_parts body])
-
- _
- #None))]
- (case name+args+meta+body??
- (#Some [name args meta body])
- (let [name (identifier$ name)
- body (case args
- #Nil
- body
-
- _
- (` ("lux macro"
- (function ((~ name) (~+ args)) (~ body)))))
- =meta (process_def_meta meta)]
- (return (list (` ("lux def" (~ name)
- (~ body)
- [(~ location_code)
- (#Record (~ =meta))]
- (~ (bit$ exported?)))))))
-
- #None
- (fail "Wrong syntax for macro:"))))
-
-(macro: #export (interface: tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Definition of signatures ala ML." ..\n
- "(interface: #export (Ord a)" ..\n
- " (: (Equivalence a)" ..\n
- " eq)" ..\n
- " (: (-> a a Bit)" ..\n
- " <)" ..\n
- " (: (-> a a Bit)" ..\n
- " <=)" ..\n
- " (: (-> a a Bit)" ..\n
- " >)" ..\n
- " (: (-> a a Bit)" ..\n
- " >=))"))}
- (let [[exported? tokens'] (export^ tokens)
- ?parts (: (Maybe [Name (List Code) Code (List Code)])
- (case tokens'
- (^ (list& [_ (#Form (list& [_ (#Identifier name)] args))] [meta_rec_location (#Record meta_rec_parts)] sigs))
- (#Some name args [meta_rec_location (#Record meta_rec_parts)] sigs)
-
- (^ (list& [_ (#Identifier name)] [meta_rec_location (#Record meta_rec_parts)] sigs))
- (#Some name #Nil [meta_rec_location (#Record meta_rec_parts)] sigs)
-
- (^ (list& [_ (#Form (list& [_ (#Identifier name)] args))] sigs))
- (#Some name args (` {}) sigs)
-
- (^ (list& [_ (#Identifier name)] sigs))
- (#Some name #Nil (` {}) sigs)
-
- _
- #None))]
- (case ?parts
- (#Some name args meta sigs)
- (do meta_monad
- [name+ (normalize name)
- sigs' (monad\map meta_monad macro_expand sigs)
- members (: (Meta (List [Text Code]))
- (monad\map meta_monad
- (: (-> Code (Meta [Text Code]))
- (function (_ token)
- (case token
- (^ [_ (#Form (list [_ (#Text "lux type check")] type [_ (#Identifier ["" name])]))])
- (wrap [name type])
-
- _
- (fail "Signatures require typed members!"))))
- (list\join sigs')))
- #let [[_module _name] name+
- def_name (identifier$ name)
- sig_type (record$ (list\map (: (-> [Text Code] [Code Code])
- (function (_ [m_name m_type])
- [(local_tag$ m_name) m_type]))
- members))
- sig_meta (meta_code_merge (` {#.sig? #1})
- meta)
- usage (case args
- #Nil
- def_name
-
- _
- (` ((~ def_name) (~+ args))))]]
- (return (list (` (..type: (~+ (export exported?)) (~ usage) (~ sig_meta) (~ sig_type))))))
-
- #None
- (fail "Wrong syntax for interface:"))))
-
-(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))))
-
-(template [<name> <form> <message> <doc_msg>]
- [(macro: #export (<name> tokens)
- {#.doc <doc_msg>}
- (case (list\reverse tokens)
- (^ (list& last init))
- (return (list (list\fold (: (-> Code Code Code)
- (function (_ pre post) (` <form>)))
- last
- init)))
-
- _
- (fail <message>)))]
-
- [and (if (~ pre) (~ post) #0) "'and' requires >=1 clauses." "Short-circuiting 'and': (and #1 #0 #1) ## => #0"]
- [or (if (~ pre) #1 (~ post)) "'or' requires >=1 clauses." "Short-circuiting 'or': (or #1 #0 #1) ## => #1"])
-
-(def: (index_of part text)
- (-> Text Text (Maybe Nat))
- ("lux text index" 0 part text))
-
-(def: #export (error! message)
- {#.doc (text$ ($_ "lux text concat"
- "## Causes an error, with the given error message." ..\n
- "(error! ''OH NO!'')"))}
- (-> Text Nothing)
- ("lux io error" message))
-
-(macro: (default tokens state)
- {#.doc (text$ ($_ "lux text concat"
- "## Allows you to provide a default value that will be used" ..\n
- "## if a (Maybe x) value turns out to be #.None."
- __paragraph
- "(default +20 (#.Some +10)) ## => +10"
- __paragraph
- "(default +20 #.None) ## => +20"))}
- (case tokens
- (^ (list else maybe))
- (let [g!temp (: Code [dummy_location (#Identifier ["" ""])])
- code (` (case (~ maybe)
- (#.Some (~ g!temp))
- (~ g!temp)
-
- #.None
- (~ else)))]
- (#Right [state (list code)]))
-
- _
- (#Left "Wrong syntax for default")))
-
-(def: (text\split_all_with splitter input)
- (-> Text Text (List Text))
- (case (..index_of splitter input)
- #None
- (list input)
-
- (#Some idx)
- (list& ("lux text clip" 0 idx input)
- (text\split_all_with splitter
- (let [after_offset ("lux i64 +" 1 idx)
- after_length ("lux i64 -"
- after_offset
- ("lux text size" input))]
- ("lux text clip" after_offset after_length input))))))
-
-(def: (nth idx xs)
- (All [a]
- (-> Nat (List a) (Maybe a)))
- (case xs
- #Nil
- #None
-
- (#Cons x xs')
- (if ("lux i64 =" 0 idx)
- (#Some x)
- (nth ("lux i64 -" 1 idx) xs')
- )))
-
-(def: (beta_reduce env type)
- (-> (List Type) Type Type)
- (case type
- (#Sum left right)
- (#Sum (beta_reduce env left) (beta_reduce env right))
-
- (#Product left right)
- (#Product (beta_reduce env left) (beta_reduce env right))
-
- (#Apply arg func)
- (#Apply (beta_reduce env arg) (beta_reduce env func))
-
- (#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)
-
- (#Function ?input ?output)
- (#Function (beta_reduce env ?input) (beta_reduce env ?output))
-
- (#Parameter idx)
- (case (nth idx env)
- (#Some parameter)
- parameter
-
- _
- type)
-
- (#Named 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))
-
- (#Apply A F)
- (do maybe_monad
- [type_fn* (apply_type F A)]
- (apply_type type_fn* param))
-
- (#Named name type)
- (apply_type type param)
-
- _
- #None))
-
-(template [<name> <tag>]
- [(def: (<name> type)
- (-> Type (List Type))
- (case type
- (<tag> left right)
- (list& left (<name> right))
-
- _
- (list type)))]
-
- [flatten_variant #Sum]
- [flatten_tuple #Product]
- [flatten_lambda #Function]
- )
-
-(def: (flatten_app type)
- (-> Type [Type (List Type)])
- (case type
- (#Apply head func')
- (let [[func tail] (flatten_app func')]
- [func (#Cons head tail)])
-
- _
- [type (list)]))
-
-(def: (resolve_struct_type type)
- (-> Type (Maybe (List Type)))
- (case type
- (#Product _)
- (#Some (flatten_tuple type))
-
- (#Apply arg func)
- (do maybe_monad
- [output (apply_type func arg)]
- (resolve_struct_type output))
-
- (#UnivQ _ body)
- (resolve_struct_type body)
-
- (#ExQ _ body)
- (resolve_struct_type body)
-
- (#Named name type)
- (resolve_struct_type type)
-
- (#Sum _)
- #None
-
- _
- (#Some (list type))))
-
-(def: (find_module name)
- (-> Text (Meta Module))
- (function (_ state)
- (let [{#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected #location location #extensions extensions
- #scope_type_vars scope_type_vars} state]
- (case (get name modules)
- (#Some module)
- (#Right state module)
-
- _
- (#Left ($_ text\compose "Unknown module: " name))))))
-
-(def: get_current_module
- (Meta Module)
- (do meta_monad
- [module_name current_module_name]
- (find_module module_name)))
-
-(def: (resolve_tag [module name])
- (-> Name (Meta [Nat (List Name) Bit Type]))
- (do meta_monad
- [=module (find_module module)
- #let [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags_table #types types #module_annotations _ #module_state _} =module]]
- (case (get name tags_table)
- (#Some output)
- (return output)
-
- _
- (fail (text\compose "Unknown tag: " (name\encode [module name]))))))
-
-(def: (resolve_type_tags type)
- (-> Type (Meta (Maybe [(List Name) (List Type)])))
- (case type
- (#Apply arg func)
- (resolve_type_tags func)
-
- (#UnivQ env body)
- (resolve_type_tags body)
-
- (#ExQ env body)
- (resolve_type_tags body)
-
- (#Named [module name] unnamed)
- (do meta_monad
- [=module (find_module module)
- #let [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags #types types #module_annotations _ #module_state _} =module]]
- (case (get name types)
- (#Some [tags exported? (#Named _ _type)])
- (case (resolve_struct_type _type)
- (#Some members)
- (return (#Some [tags members]))
-
- _
- (return #None))
-
- _
- (resolve_type_tags unnamed)))
-
- _
- (return #None)))
-
-(def: get_expected_type
- (Meta Type)
- (function (_ state)
- (let [{#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected #location location #extensions extensions
- #scope_type_vars scope_type_vars} state]
- (case expected
- (#Some type)
- (#Right state type)
-
- #None
- (#Left "Not expecting any type.")))))
-
-(macro: #export (implementation tokens)
- {#.doc "Not meant to be used directly. Prefer 'implementation:'."}
- (do meta_monad
- [tokens' (monad\map meta_monad macro_expand tokens)
- struct_type get_expected_type
- tags+type (resolve_type_tags struct_type)
- tags (: (Meta (List Name))
- (case tags+type
- (#Some [tags _])
- (return tags)
-
- _
- (fail "No tags available for type.")))
- #let [tag_mappings (: (List [Text Code])
- (list\map (function (_ tag) [(second tag) (tag$ tag)])
- tags))]
- members (monad\map meta_monad
- (: (-> Code (Meta [Code Code]))
- (function (_ token)
- (case token
- (^ [_ (#Form (list [_ (#Text "lux def")] [_ (#Identifier "" tag_name)] value meta [_ (#Bit #0)]))])
- (case (get tag_name tag_mappings)
- (#Some tag)
- (wrap [tag value])
-
- _
- (fail (text\compose "Unknown implementation member: " tag_name)))
-
- _
- (fail "Invalid implementation member."))))
- (list\join tokens'))]
- (wrap (list (record$ members)))))
-
-(def: (text\join_with separator parts)
- (-> Text (List Text) Text)
- (case parts
- #Nil
- ""
-
- (#Cons head tail)
- (list\fold (function (_ right left)
- ($_ text\compose left separator right))
- head
- tail)))
-
-(macro: #export (implementation: tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Definition of structures ala ML." ..\n
- "(implementation: #export order (Order Int)" ..\n
- " (def: &equivalence equivalence)" ..\n
- " (def: (< test subject)" ..\n
- " (< test subject))" ..\n
- " (def: (<= test subject)" ..\n
- " (or (< test subject)" ..\n
- " (= test subject)))" ..\n
- " (def: (> test subject)" ..\n
- " (> test subject))" ..\n
- " (def: (>= test subject)" ..\n
- " (or (> test subject)" ..\n
- " (= test subject))))"))}
- (let [[exported? tokens'] (export^ tokens)
- ?parts (: (Maybe [Code (List Code) Code Code (List Code)])
- (case tokens'
- (^ (list& [_ (#Form (list& name args))] [meta_rec_location (#Record meta_rec_parts)] type definitions))
- (#Some name args type [meta_rec_location (#Record meta_rec_parts)] definitions)
-
- (^ (list& name [meta_rec_location (#Record meta_rec_parts)] type definitions))
- (#Some name #Nil type [meta_rec_location (#Record meta_rec_parts)] definitions)
-
- (^ (list& [_ (#Form (list& name args))] type definitions))
- (#Some name args type (` {}) definitions)
-
- (^ (list& name type definitions))
- (#Some name #Nil type (` {}) definitions)
-
- _
- #None))]
- (case ?parts
- (#Some [name args type meta definitions])
- (let [usage (case args
- #Nil
- name
-
- _
- (` ((~ name) (~+ args))))]
- (return (list (` (..def: (~+ (export exported?)) (~ usage)
- (~ (meta_code_merge (` {#.implementation? #1})
- meta))
- (~ type)
- (implementation (~+ definitions)))))))
-
- #None
- (fail "Wrong syntax for implementation:"))))
-
-(def: (function\identity x) (All [a] (-> a a)) x)
-
-(macro: #export (type: tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## The type-definition macro." ..\n
- "(type: (List a) #Nil (#Cons a (List a)))"))}
- (let [[exported? tokens'] (export^ tokens)
- [rec? tokens'] (case tokens'
- (#Cons [_ (#Tag [_ "rec"])] tokens')
- [#1 tokens']
-
- _
- [#0 tokens'])
- parts (: (Maybe [Text (List Code) (List [Code Code]) (List Code)])
- (case tokens'
- (^ (list [_ (#Identifier "" name)] [meta_location (#Record meta_parts)] [type_location (#Record type_parts)]))
- (#Some [name #Nil meta_parts (list [type_location (#Record type_parts)])])
-
- (^ (list& [_ (#Identifier "" name)] [meta_location (#Record meta_parts)] type_code1 type_codes))
- (#Some [name #Nil meta_parts (#Cons type_code1 type_codes)])
-
- (^ (list& [_ (#Identifier "" name)] type_codes))
- (#Some [name #Nil (list) type_codes])
-
- (^ (list [_ (#Form (#Cons [_ (#Identifier "" name)] args))] [meta_location (#Record meta_parts)] [type_location (#Record type_parts)]))
- (#Some [name args meta_parts (list [type_location (#Record type_parts)])])
-
- (^ (list& [_ (#Form (#Cons [_ (#Identifier "" name)] args))] [meta_location (#Record meta_parts)] type_code1 type_codes))
- (#Some [name args meta_parts (#Cons type_code1 type_codes)])
-
- (^ (list& [_ (#Form (#Cons [_ (#Identifier "" name)] args))] type_codes))
- (#Some [name args (list) type_codes])
-
- _
- #None))]
- (case parts
- (#Some name args meta type_codes)
- (do meta_monad
- [type+tags?? (unfold_type_def type_codes)
- module_name current_module_name]
- (let [type_name (local_identifier$ name)
- [type tags??] type+tags??
- type' (: (Maybe Code)
- (if rec?
- (if (empty? args)
- (let [g!param (local_identifier$ "")
- prime_name (local_identifier$ name)
- type+ (replace_syntax (list [name (` ((~ prime_name) .Nothing))]) type)]
- (#Some (` ((All (~ prime_name) [(~ g!param)] (~ type+))
- .Nothing))))
- #None)
- (case args
- #Nil
- (#Some type)
-
- _
- (#Some (` (.All (~ type_name) [(~+ args)] (~ type)))))))
- total_meta (let [meta (process_def_meta meta)
- meta (if rec?
- (` (#.Cons (~ (flag_meta "type-rec?")) (~ meta)))
- meta)]
- (` [(~ location_code)
- (#.Record (~ meta))]))]
- (case type'
- (#Some type'')
- (let [typeC (` (#.Named [(~ (text$ module_name))
- (~ (text$ name))]
- (.type (~ type''))))]
- (return (list (case tags??
- (#Some tags)
- (` ("lux def type tagged" (~ type_name)
- (~ typeC)
- (~ total_meta)
- [(~+ (list\map text$ tags))]
- (~ (bit$ exported?))))
-
- _
- (` ("lux def" (~ type_name)
- ("lux type check type"
- (~ typeC))
- (~ total_meta)
- (~ (bit$ exported?))))))))
-
- #None
- (fail "Wrong syntax for type:"))))
-
- #None
- (fail "Wrong syntax for type:"))
- ))
-
-(template [<name> <to>]
- [(def: #export (<name> value)
- (-> (I64 Any) <to>)
- (:as <to> value))]
-
- [i64 I64]
- [nat Nat]
- [int Int]
- [rev Rev]
- )
-
-(type: Referrals
- #All
- (#Only (List Text))
- (#Exclude (List Text))
- #Ignore
- #Nothing)
-
-(type: Openings
- [Text (List Text)])
-
-(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 Code) (Meta (List Text)))
- (monad\map meta_monad
- (: (-> Code (Meta Text))
- (function (_ def)
- (case def
- [_ (#Identifier ["" name])]
- (return name)
-
- _
- (fail "#only/#+ and #exclude/#- require identifiers."))))
- defs))
-
-(def: (parse_referrals tokens)
- (-> (List Code) (Meta [Referrals (List Code)]))
- (case tokens
- (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "+"])] defs))] tokens'))
- (^ (list& [_ (#Form (list& [_ (#Tag ["" "only"])] defs))] tokens')))
- (do meta_monad
- [defs' (extract_defs defs)]
- (wrap [(#Only defs') tokens']))
-
- (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "-"])] defs))] tokens'))
- (^ (list& [_ (#Form (list& [_ (#Tag ["" "exclude"])] defs))] tokens')))
- (do meta_monad
- [defs' (extract_defs defs)]
- (wrap [(#Exclude defs') tokens']))
-
- (^or (^ (list& [_ (#Tag ["" "*"])] tokens'))
- (^ (list& [_ (#Tag ["" "all"])] tokens')))
- (return [#All tokens'])
-
- (^or (^ (list& [_ (#Tag ["" "_"])] tokens'))
- (^ (list& [_ (#Tag ["" "nothing"])] tokens')))
- (return [#Ignore tokens'])
-
- _
- (return [#Nothing tokens])))
-
-(def: (parse_openings parts)
- (-> (List Code) (Meta [(List Openings) (List Code)]))
- (case parts
- #.Nil
- (return [#.Nil #.Nil])
-
- (^ (list& [_ (#Form (list& [_ (#Text prefix)] structs))] parts'))
- (do meta_monad
- [structs' (monad\map meta_monad
- (function (_ struct)
- (case struct
- [_ (#Identifier ["" struct_name])]
- (return struct_name)
-
- _
- (fail "Expected all implementations of opening form to be identifiers.")))
- structs)
- next+remainder (parse_openings parts')]
- (let [[next remainder] next+remainder]
- (return [(#.Cons [prefix structs'] next)
- remainder])))
-
- _
- (return [#.Nil parts])))
-
-(def: (text\split! at x)
- (-> Nat Text [Text Text])
- [("lux text clip" 0 at x)
- ("lux text clip" at (|> x "lux text size" ("lux i64 -" at)) x)])
-
-(def: (text\split_with token sample)
- (-> Text Text (Maybe [Text Text]))
- (do ..maybe_monad
- [index (..index_of token sample)
- #let [[pre post'] (text\split! index sample)
- [_ post] (text\split! ("lux text size" token) post')]]
- (wrap [pre post])))
-
-(def: (replace_all pattern replacement template)
- (-> Text Text Text Text)
- ((: (-> Text Text Text)
- (function (recur left right)
- (case (..text\split_with pattern right)
- (#.Some [pre post])
- (recur ($_ "lux text concat" left pre replacement) post)
-
- #.None
- ("lux text concat" left right))))
- "" template))
-
-(def: contextual_reference "#")
-(def: self_reference ".")
-
-(def: (de_alias context self aliased)
- (-> Text Text Text Text)
- (|> aliased
- (replace_all ..self_reference self)
- (replace_all ..contextual_reference context)))
-
-(def: #export module_separator
- "/")
-
-(def: parallel_hierarchy_sigil
- "\")
-
-(def: (normalize_parallel_path' hierarchy root)
- (-> Text Text Text)
- (case [(text\split_with ..module_separator hierarchy)
- (text\split_with ..parallel_hierarchy_sigil root)]
- [(#.Some [_ hierarchy'])
- (#.Some ["" root'])]
- (normalize_parallel_path' hierarchy' root')
-
- _
- (case root
- "" hierarchy
- _ ($_ text\compose root ..module_separator hierarchy))))
-
-(def: (normalize_parallel_path hierarchy root)
- (-> Text Text (Maybe Text))
- (case (text\split_with ..parallel_hierarchy_sigil root)
- (#.Some ["" root'])
- (#.Some (normalize_parallel_path' hierarchy root'))
-
- _
- #.None))
-
-(def: (count_relatives relatives input)
- (-> Nat Text Nat)
- (case ("lux text index" relatives ..module_separator input)
- #None
- relatives
-
- (#Some found)
- (if ("lux i64 =" relatives found)
- (count_relatives ("lux i64 +" 1 relatives) input)
- relatives)))
-
-(def: (list\take amount list)
- (All [a] (-> Nat (List a) (List a)))
- (case [amount list]
- (^or [0 _] [_ #Nil])
- #Nil
-
- [_ (#Cons head tail)]
- (#Cons head (list\take ("lux i64 -" 1 amount) tail))))
-
-(def: (list\drop amount list)
- (All [a] (-> Nat (List a) (List a)))
- (case [amount list]
- (^or [0 _] [_ #Nil])
- list
-
- [_ (#Cons _ tail)]
- (list\drop ("lux i64 -" 1 amount) tail)))
-
-(def: (clean_module nested? relative_root module)
- (-> Bit Text Text (Meta Text))
- (case (count_relatives 0 module)
- 0
- (return (if nested?
- ($_ "lux text concat" relative_root ..module_separator module)
- module))
-
- relatives
- (let [parts (text\split_all_with ..module_separator relative_root)
- jumps ("lux i64 -" 1 relatives)]
- (if (n/< (list\size parts) jumps)
- (let [prefix (|> parts
- list\reverse
- (list\drop jumps)
- list\reverse
- (interpose ..module_separator)
- (text\join_with ""))
- clean ("lux text clip" relatives (|> module "lux text size" ("lux i64 -" relatives)) module)
- output (case ("lux text size" clean)
- 0 prefix
- _ ($_ text\compose prefix ..module_separator clean))]
- (return output))
- (fail ($_ "lux text concat"
- "Cannot climb the module hierarchy..." ..\n
- "Importing module: " module ..\n
- " Relative Root: " relative_root ..\n))))))
-
-(def: (alter_domain alteration domain import)
- (-> Nat Text Importation Importation)
- (let [[import_name import_alias import_refer] import
- original (text\split_all_with ..module_separator import_name)
- truncated (list\drop (.nat alteration) original)
- parallel (case domain
- ""
- truncated
-
- _
- (list& domain truncated))]
- {#import_name (text\join_with ..module_separator parallel)
- #import_alias import_alias
- #import_refer import_refer}))
-
-(def: (parse_imports nested? relative_root context_alias imports)
- (-> Bit Text Text (List Code) (Meta (List Importation)))
- (do meta_monad
- [imports' (monad\map meta_monad
- (: (-> Code (Meta (List Importation)))
- (function (_ token)
- (case token
- ## Simple
- [_ (#Identifier ["" m_name])]
- (do meta_monad
- [m_name (clean_module nested? relative_root m_name)]
- (wrap (list {#import_name m_name
- #import_alias #None
- #import_refer {#refer_defs #All
- #refer_open (list)}})))
-
- ## Nested
- (^ [_ (#Tuple (list& [_ (#Identifier ["" m_name])] extra))])
- (do meta_monad
- [import_name (case (normalize_parallel_path relative_root m_name)
- (#.Some parallel_path)
- (wrap parallel_path)
-
- #.None
- (clean_module nested? relative_root m_name))
- referral+extra (parse_referrals extra)
- #let [[referral extra] referral+extra]
- openings+extra (parse_openings extra)
- #let [[openings extra] openings+extra]
- sub_imports (parse_imports #1 import_name context_alias extra)]
- (wrap (case [referral openings]
- [#Nothing #Nil]
- sub_imports
-
- _
- (list& {#import_name import_name
- #import_alias #None
- #import_refer {#refer_defs referral
- #refer_open openings}}
- sub_imports))))
-
- (^ [_ (#Tuple (list& [_ (#Text alias)] [_ (#Identifier ["" m_name])] extra))])
- (do meta_monad
- [import_name (case (normalize_parallel_path relative_root m_name)
- (#.Some parallel_path)
- (wrap parallel_path)
-
- #.None
- (clean_module nested? relative_root m_name))
- referral+extra (parse_referrals extra)
- #let [[referral extra] referral+extra]
- openings+extra (parse_openings extra)
- #let [[openings extra] openings+extra
- de_aliased (de_alias context_alias m_name alias)]
- sub_imports (parse_imports #1 import_name de_aliased extra)]
- (wrap (case [referral openings]
- [#Ignore #Nil]
- sub_imports
-
- _
- (list& {#import_name import_name
- #import_alias (#Some de_aliased)
- #import_refer {#refer_defs referral
- #refer_open openings}}
- sub_imports))))
-
- ## Unrecognized syntax.
- _
- (do meta_monad
- [current_module current_module_name]
- (fail ($_ text\compose
- "Wrong syntax for import @ " current_module
- ..\n (code\encode token)))))))
- imports)]
- (wrap (list\join imports'))))
-
-(def: (exported_definitions module state)
- (-> Text (Meta (List Text)))
- (let [[current_module modules] (case state
- {#info info #source source #current_module current_module #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected #location location #extensions extensions
- #scope_type_vars scope_type_vars}
- [current_module modules])]
- (case (get module modules)
- (#Some =module)
- (let [to_alias (list\map (: (-> [Text Global]
- (List Text))
- (function (_ [name definition])
- (case definition
- (#Left _)
- (list)
-
- (#Right [exported? def_type def_meta def_value])
- (if exported?
- (list name)
- (list)))))
- (let [{#module_hash _ #module_aliases _ #definitions definitions #imports _ #tags tags #types types #module_annotations _ #module_state _} =module]
- definitions))]
- (#Right state (list\join to_alias)))
-
- #None
- (#Left ($_ text\compose
- "Unknown module: " (text\encode module) ..\n
- "Current module: " (case current_module
- (#Some current_module)
- (text\encode current_module)
-
- #None
- "???") ..\n
- "Known modules: " (|> modules
- (list\map (function (_ [name module])
- (text$ name)))
- tuple$
- code\encode))))
- ))
-
-(def: (filter p xs)
- (All [a] (-> (-> a Bit) (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 Bit)
- (let [output (list\fold (function (_ case prev)
- (or prev
- (text\= case name)))
- #0
- 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 Lux (Maybe Type))
- (case state
- {#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected #location location #extensions extensions
- #scope_type_vars scope_type_vars}
- (find (: (-> Scope (Maybe Type))
- (function (_ env)
- (case env
- {#name _
- #inner _
- #locals {#counter _ #mappings locals}
- #captured {#counter _ #mappings closure}}
- (try_both (find (: (-> [Text [Type Any]] (Maybe Type))
- (function (_ [bname [type _]])
- (if (text\= name bname)
- (#Some type)
- #None))))
- (: (List [Text [Type Any]]) locals)
- (: (List [Text [Type Any]]) closure)))))
- scopes)))
-
-(def: (find_def_type name state)
- (-> Name Lux (Maybe Type))
- (let [[v_prefix v_name] name
- {#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected #location location #extensions extensions
- #scope_type_vars scope_type_vars} state]
- (case (get v_prefix modules)
- #None
- #None
-
- (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #tags tags #types types #module_annotations _ #module_state _})
- (case (get v_name definitions)
- #None
- #None
-
- (#Some definition)
- (case definition
- (#Left de_aliased)
- (find_def_type de_aliased state)
-
- (#Right [exported? def_type def_meta def_value])
- (#Some def_type))))))
-
-(def: (find_def_value name state)
- (-> Name (Meta [Type Any]))
- (let [[v_prefix v_name] name
- {#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected #location location #extensions extensions
- #scope_type_vars scope_type_vars} state]
- (case (get v_prefix modules)
- #None
- (#Left (text\compose "Unknown definition: " (name\encode name)))
-
- (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #tags tags #types types #module_annotations _ #module_state _})
- (case (get v_name definitions)
- #None
- (#Left (text\compose "Unknown definition: " (name\encode name)))
-
- (#Some definition)
- (case definition
- (#Left de_aliased)
- (find_def_value de_aliased state)
-
- (#Right [exported? def_type def_meta def_value])
- (#Right [state [def_type def_value]]))))))
-
-(def: (find_type_var idx bindings)
- (-> Nat (List [Nat (Maybe Type)]) (Maybe Type))
- (case bindings
- #Nil
- #Nil
-
- (#Cons [var bound] bindings')
- (if ("lux i64 =" idx var)
- bound
- (find_type_var idx bindings'))))
-
-(def: (find_type full_name)
- (-> Name (Meta Type))
- (do meta_monad
- [#let [[module name] full_name]
- current_module current_module_name]
- (function (_ compiler)
- (let [temp (if (text\= "" module)
- (case (find_in_env name compiler)
- (#Some struct_type)
- (#Right [compiler struct_type])
-
- _
- (case (find_def_type [current_module name] compiler)
- (#Some struct_type)
- (#Right [compiler struct_type])
-
- _
- (#Left ($_ text\compose "Unknown var: " (name\encode full_name)))))
- (case (find_def_type full_name compiler)
- (#Some struct_type)
- (#Right [compiler struct_type])
-
- _
- (#Left ($_ text\compose "Unknown var: " (name\encode full_name)))))]
- (case temp
- (#Right [compiler (#Var type_id)])
- (let [{#info _ #source _ #current_module _ #modules _
- #scopes _ #type_context type_context #host _
- #seed _ #expected _ #location _ #extensions extensions
- #scope_type_vars _} compiler
- {#ex_counter _ #var_counter _ #var_bindings var_bindings} type_context]
- (case (find_type_var type_id var_bindings)
- #None
- temp
-
- (#Some actualT)
- (#Right [compiler actualT])))
-
- _
- temp))
- )))
-
-(def: (zip/2 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] (zip/2 xs' ys'))
-
- _
- (list))
-
- _
- (list)))
-
-(def: (type\encode type)
- (-> Type Text)
- (case type
- (#Primitive name params)
- (case params
- #Nil
- name
-
- _
- ($_ text\compose "(" name " " (|> params (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) ")"))
-
- (#Sum _)
- ($_ text\compose "(| " (|> (flatten_variant type) (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) ")")
-
- (#Product _)
- ($_ text\compose "[" (|> (flatten_tuple type) (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) "]")
-
- (#Function _)
- ($_ text\compose "(-> " (|> (flatten_lambda type) (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose "")) ")")
-
- (#Parameter id)
- (nat\encode id)
-
- (#Var id)
- ($_ text\compose "⌈v:" (nat\encode id) "⌋")
-
- (#Ex id)
- ($_ text\compose "⟨e:" (nat\encode id) "⟩")
-
- (#UnivQ env body)
- ($_ text\compose "(All " (type\encode body) ")")
-
- (#ExQ env body)
- ($_ text\compose "(Ex " (type\encode body) ")")
-
- (#Apply _)
- (let [[func args] (flatten_app type)]
- ($_ text\compose
- "(" (type\encode func) " "
- (|> args (list\map type\encode) (interpose " ") list\reverse (list\fold text\compose ""))
- ")"))
-
- (#Named name _)
- (name\encode name)
- ))
-
-(macro: #export (^open tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Same as the 'open' macro, but meant to be used as a pattern-matching macro for generating local bindings." ..\n
- "## Takes an 'alias' text for the generated local bindings." ..\n
- "(def: #export (range (^open ''.'') from to)" ..\n
- " (All [a] (-> (Enum a) a a (List a)))" ..\n
- " (range' <= succ from to))"))}
- (case tokens
- (^ (list& [_ (#Form (list [_ (#Text alias)]))] body branches))
- (do meta_monad
- [g!temp (gensym "temp")]
- (wrap (list& g!temp (` (..^open (~ g!temp) (~ (text$ alias)) (~ body))) branches)))
-
- (^ (list [_ (#Identifier name)] [_ (#Text alias)] body))
- (do meta_monad
- [init_type (find_type name)
- struct_evidence (resolve_type_tags init_type)]
- (case struct_evidence
- #None
- (fail (text\compose "Can only 'open' structs: " (type\encode init_type)))
-
- (#Some tags&members)
- (do meta_monad
- [full_body ((: (-> Name [(List Name) (List Type)] Code (Meta Code))
- (function (recur source [tags members] target)
- (let [locals (list\map (function (_ [t_module t_name])
- ["" (de_alias "" t_name alias)])
- tags)
- pattern (tuple$ (list\map identifier$ locals))]
- (do meta_monad
- [enhanced_target (monad\fold meta_monad
- (function (_ [m_local m_type] enhanced_target)
- (do meta_monad
- [m_implementation (resolve_type_tags m_type)]
- (case m_implementation
- (#Some m_tags&members)
- (recur m_local
- m_tags&members
- enhanced_target)
-
- #None
- (wrap enhanced_target))))
- target
- (zip/2 locals members))]
- (wrap (` ({(~ pattern) (~ enhanced_target)} (~ (identifier$ source)))))))))
- name tags&members body)]
- (wrap (list full_body)))))
-
- _
- (fail "Wrong syntax for ^open")))
-
-(macro: #export (cond tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Branching structures with multiple test conditions." ..\n
- "(cond (even? num) ''even''" ..\n
- " (odd? num) ''odd''"
- __paragraph
- " ## else_branch" ..\n
- " ''???'')"))}
- (if ("lux i64 =" 0 (n/% 2 (list\size tokens)))
- (fail "cond requires an uneven number of arguments.")
- (case (list\reverse tokens)
- (^ (list& else branches'))
- (return (list (list\fold (: (-> [Code Code] Code Code)
- (function (_ branch else)
- (let [[right left] branch]
- (` (if (~ left) (~ right) (~ else))))))
- else
- (as_pairs branches'))))
-
- _
- (fail "Wrong syntax for cond"))))
-
-(def: (enumeration' idx xs)
- (All [a] (-> Nat (List a) (List [Nat a])))
- (case xs
- (#Cons x xs')
- (#Cons [idx x] (enumeration' ("lux i64 +" 1 idx) xs'))
-
- #Nil
- #Nil))
-
-(def: (enumeration xs)
- (All [a] (-> (List a) (List [Nat a])))
- (enumeration' 0 xs))
-
-(macro: #export (get@ tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Accesses the value of a record at a given tag." ..\n
- "(get@ #field my_record)"
- __paragraph
- "## Can also work with multiple levels of nesting:" ..\n
- "(get@ [#foo #bar #baz] my_record)"
- __paragraph
- "## And, if only the slot/path is given, generates an accessor function:" ..\n
- "(let [getter (get@ [#foo #bar #baz])]" ..\n
- " (getter my_record))"))}
- (case tokens
- (^ (list [_ (#Tag slot')] record))
- (do meta_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$ (list\map (: (-> [Name [Nat Type]] [Code Code])
- (function (_ [[r_prefix r_name] [r_idx r_type]])
- [(tag$ [r_prefix r_name])
- (if ("lux i64 =" idx r_idx)
- g!output
- g!_)]))
- (zip/2 tags (enumeration members))))]
- (return (list (` ({(~ pattern) (~ g!output)} (~ record))))))
-
- _
- (fail "get@ can only use records.")))
-
- (^ (list [_ (#Tuple slots)] record))
- (return (list (list\fold (: (-> Code Code Code)
- (function (_ slot inner)
- (` (..get@ (~ slot) (~ inner)))))
- record
- slots)))
-
- (^ (list selector))
- (do meta_monad
- [g!_ (gensym "_")
- g!record (gensym "record")]
- (wrap (list (` (function ((~ g!_) (~ g!record)) (..get@ (~ selector) (~ g!record)))))))
-
- _
- (fail "Wrong syntax for get@")))
-
-(def: (open_field alias tags my_tag_index [module short] source type)
- (-> Text (List Name) Nat Name Code Type (Meta (List Code)))
- (do meta_monad
- [output (resolve_type_tags type)
- g!_ (gensym "g!_")
- #let [g!output (local_identifier$ short)
- pattern (|> tags
- enumeration
- (list\map (function (_ [tag_idx tag])
- (if ("lux i64 =" my_tag_index tag_idx)
- g!output
- g!_)))
- tuple$)
- source+ (` ({(~ pattern) (~ g!output)} (~ source)))]]
- (case output
- (#Some [tags' members'])
- (do meta_monad
- [decls' (monad\map meta_monad
- (: (-> [Nat Name Type] (Meta (List Code)))
- (function (_ [sub_tag_index sname stype])
- (open_field alias tags' sub_tag_index sname source+ stype)))
- (enumeration (zip/2 tags' members')))]
- (return (list\join decls')))
-
- _
- (return (list (` ("lux def" (~ (local_identifier$ (de_alias "" short alias)))
- (~ source+)
- [(~ location_code) (#.Record #Nil)]
- #0)))))))
-
-(macro: #export (open: tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Opens a implementation and generates a definition for each of its members (including nested members)."
- __paragraph
- "## For example:" ..\n
- "(open: ''i:.'' number)"
- __paragraph
- "## Will generate:" ..\n
- "(def: i:+ (\ number +))" ..\n
- "(def: i:- (\ number -))" ..\n
- "(def: i:* (\ number *))" ..\n
- "..."))}
- (case tokens
- (^ (list [_ (#Text alias)] struct))
- (case struct
- [_ (#Identifier struct_name)]
- (do meta_monad
- [struct_type (find_type struct_name)
- output (resolve_type_tags struct_type)
- #let [source (identifier$ struct_name)]]
- (case output
- (#Some [tags members])
- (do meta_monad
- [decls' (monad\map meta_monad (: (-> [Nat Name Type] (Meta (List Code)))
- (function (_ [tag_index sname stype])
- (open_field alias tags tag_index sname source stype)))
- (enumeration (zip/2 tags members)))]
- (return (list\join decls')))
-
- _
- (fail (text\compose "Can only 'open:' structs: " (type\encode struct_type)))))
-
- _
- (do meta_monad
- [g!struct (gensym "struct")]
- (return (list (` ("lux def" (~ g!struct) (~ struct)
- [(~ location_code) (#.Record #Nil)]
- #0))
- (` (..open: (~ (text$ alias)) (~ g!struct)))))))
-
- _
- (fail "Wrong syntax for open:")))
-
-(macro: #export (|>> tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..\n
- "(|>> (list\map int\encode) (interpose '' '') (fold text\compose ''''))" ..\n
- "## =>" ..\n
- "(function (_ <arg>) (fold text\compose '''' (interpose '' '' (list\map int\encode <arg>))))"))}
- (do meta_monad
- [g!_ (gensym "_")
- g!arg (gensym "arg")]
- (return (list (` (function ((~ g!_) (~ g!arg)) (|> (~ g!arg) (~+ tokens))))))))
-
-(macro: #export (<<| tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it." ..\n
- "(<<| (fold text\compose '''') (interpose '' '') (list\map int\encode))" ..\n
- "## =>" ..\n
- "(function (_ <arg>) (fold text\compose '''' (interpose '' '' (list\map int\encode <arg>))))"))}
- (do meta_monad
- [g!_ (gensym "_")
- g!arg (gensym "arg")]
- (return (list (` (function ((~ g!_) (~ g!arg)) (<| (~+ tokens) (~ g!arg))))))))
-
-(def: (imported_by? import_name module_name)
- (-> Text Text (Meta Bit))
- (do meta_monad
- [module (find_module module_name)
- #let [{#module_hash _ #module_aliases _ #definitions _ #imports imports #tags _ #types _ #module_annotations _ #module_state _} module]]
- (wrap (is_member? imports import_name))))
-
-(def: (read_refer module_name options)
- (-> Text (List Code) (Meta Refer))
- (do meta_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]
- (case options
- #Nil
- (wrap {#refer_defs referral
- #refer_open openings})
-
- _
- (fail ($_ text\compose "Wrong syntax for refer @ " current_module
- ..\n (|> options
- (list\map code\encode)
- (interpose " ")
- (list\fold text\compose "")))))))
-
-(def: (write_refer module_name [r_defs r_opens])
- (-> Text Refer (Meta (List Code)))
- (do meta_monad
- [current_module current_module_name
- #let [test_referrals (: (-> Text (List Text) (List Text) (Meta (List Any)))
- (function (_ module_name all_defs referred_defs)
- (monad\map meta_monad
- (: (-> Text (Meta Any))
- (function (_ _def)
- (if (is_member? all_defs _def)
- (return [])
- (fail ($_ text\compose _def " is not defined in module " module_name " @ " current_module)))))
- referred_defs)))]
- defs' (case r_defs
- #All
- (exported_definitions module_name)
-
- (#Only +defs)
- (do meta_monad
- [*defs (exported_definitions module_name)
- _ (test_referrals module_name *defs +defs)]
- (wrap +defs))
-
- (#Exclude _defs)
- (do meta_monad
- [*defs (exported_definitions module_name)
- _ (test_referrals module_name *defs _defs)]
- (wrap (filter (|>> (is_member? _defs) not) *defs)))
-
- #Ignore
- (wrap (list))
-
- #Nothing
- (wrap (list)))
- #let [defs (list\map (: (-> Text Code)
- (function (_ def)
- (` ("lux def alias" (~ (local_identifier$ def)) (~ (identifier$ [module_name def]))))))
- defs')
- openings (|> r_opens
- (list\map (: (-> Openings (List Code))
- (function (_ [alias structs])
- (list\map (function (_ name)
- (` (open: (~ (text$ alias)) (~ (identifier$ [module_name name])))))
- structs))))
- list\join)]]
- (wrap (list\compose defs openings))
- ))
-
-(macro: #export (refer tokens)
- (case tokens
- (^ (list& [_ (#Text module_name)] options))
- (do meta_monad
- [=refer (read_refer module_name options)]
- (write_refer module_name =refer))
-
- _
- (fail "Wrong syntax for refer")))
-
-(def: (refer_to_code module_name module_alias' [r_defs r_opens])
- (-> Text (Maybe Text) Refer Code)
- (let [module_alias (..default module_name module_alias')
- localizations (: (List Code)
- (case r_defs
- #All
- (list (' #*))
-
- (#Only defs)
- (list (form$ (list& (' #+) (list\map local_identifier$ defs))))
-
- (#Exclude defs)
- (list (form$ (list& (' #-) (list\map local_identifier$ defs))))
-
- #Ignore
- (list)
-
- #Nothing
- (list)))
- openings (list\map (function (_ [alias structs])
- (form$ (list& (text$ (..replace_all ..contextual_reference module_alias alias))
- (list\map local_identifier$ structs))))
- r_opens)]
- (` (..refer (~ (text$ module_name))
- (~+ localizations)
- (~+ openings)))))
-
-(macro: #export (module: tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Module_definition macro."
- __paragraph
- "## Can take optional annotations and allows the specification of modules to import."
- __paragraph
- "## Example" ..\n
- "(.module: {#.doc ''Some documentation...''}" ..\n
- " [lux #*" ..\n
- " [control" ..\n
- " [''M'' monad #*]]" ..\n
- " [data" ..\n
- " maybe" ..\n
- " [''.'' name (''#/.'' codec)]]" ..\n
- " [macro" ..\n
- " code]]" ..\n
- " [//" ..\n
- " [type (''.'' equivalence)]])"))}
- (do meta_monad
- [#let [[_meta _imports] (: [(List [Code Code]) (List Code)]
- (case tokens
- (^ (list& [_ (#Record _meta)] _imports))
- [_meta _imports]
-
- _
- [(list) tokens]))]
- current_module current_module_name
- imports (parse_imports #0 current_module "" _imports)
- #let [=imports (|> imports
- (list\map (: (-> Importation Code)
- (function (_ [m_name m_alias =refer])
- (` [(~ (text$ m_name)) (~ (text$ (default "" m_alias)))]))))
- tuple$)
- =refers (list\map (: (-> Importation Code)
- (function (_ [m_name m_alias =refer])
- (refer_to_code m_name m_alias =refer)))
- imports)
- =module (` ("lux def module" [(~ location_code)
- (#.Record (~ (process_def_meta _meta)))]
- (~ =imports)))]]
- (wrap (#Cons =module =refers))))
-
-(macro: #export (\ tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Allows accessing the value of a implementation's member." ..\n
- "(\ codec encode)"
- __paragraph
- "## Also allows using that value as a function." ..\n
- "(\ codec encode +123)"))}
- (case tokens
- (^ (list struct [_ (#Identifier member)]))
- (return (list (` (let [(^open (~ (text$ ..self_reference))) (~ struct)] (~ (identifier$ member))))))
-
- (^ (list& struct member args))
- (return (list (` ((..\ (~ struct) (~ member)) (~+ args)))))
-
- _
- (fail "Wrong syntax for \")))
-
-(macro: #export (set@ tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Sets the value of a record at a given tag." ..\n
- "(set@ #name ''Lux'' lang)"
- __paragraph
- "## Can also work with multiple levels of nesting:" ..\n
- "(set@ [#foo #bar #baz] value my_record)"
- __paragraph
- "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..\n
- "(let [setter (set@ [#foo #bar #baz] value)] (setter my_record))" ..\n
- "(let [setter (set@ [#foo #bar #baz])] (setter value my_record))"))}
- (case tokens
- (^ (list [_ (#Tag slot')] value record))
- (do meta_monad
- [slot (normalize slot')
- output (resolve_tag slot)
- #let [[idx tags exported? type] output]]
- (case (resolve_struct_type type)
- (#Some members)
- (do meta_monad
- [pattern' (monad\map meta_monad
- (: (-> [Name [Nat Type]] (Meta [Name Nat Code]))
- (function (_ [r_slot_name [r_idx r_type]])
- (do meta_monad
- [g!slot (gensym "")]
- (return [r_slot_name r_idx g!slot]))))
- (zip/2 tags (enumeration members)))]
- (let [pattern (record$ (list\map (: (-> [Name Nat Code] [Code Code])
- (function (_ [r_slot_name r_idx r_var])
- [(tag$ r_slot_name)
- r_var]))
- pattern'))
- output (record$ (list\map (: (-> [Name Nat Code] [Code Code])
- (function (_ [r_slot_name r_idx r_var])
- [(tag$ r_slot_name)
- (if ("lux i64 =" idx r_idx)
- value
- r_var)]))
- pattern'))]
- (return (list (` ({(~ pattern) (~ output)} (~ record)))))))
-
- _
- (fail "set@ can only use records.")))
-
- (^ (list [_ (#Tuple slots)] value record))
- (case slots
- #Nil
- (fail "Wrong syntax for set@")
-
- _
- (do meta_monad
- [bindings (monad\map meta_monad
- (: (-> Code (Meta Code))
- (function (_ _) (gensym "temp")))
- slots)
- #let [pairs (zip/2 slots bindings)
- update_expr (list\fold (: (-> [Code Code] Code Code)
- (function (_ [s b] v)
- (` (..set@ (~ s) (~ v) (~ b)))))
- value
- (list\reverse pairs))
- [_ accesses'] (list\fold (: (-> [Code Code] [Code (List (List Code))] [Code (List (List Code))])
- (function (_ [new_slot new_binding] [old_record accesses'])
- [(` (get@ (~ new_slot) (~ new_binding)))
- (#Cons (list new_binding old_record) accesses')]))
- [record (: (List (List Code)) #Nil)]
- pairs)
- accesses (list\join (list\reverse accesses'))]]
- (wrap (list (` (let [(~+ accesses)]
- (~ update_expr)))))))
-
- (^ (list selector value))
- (do meta_monad
- [g!_ (gensym "_")
- g!record (gensym "record")]
- (wrap (list (` (function ((~ g!_) (~ g!record))
- (..set@ (~ selector) (~ value) (~ g!record)))))))
-
- (^ (list selector))
- (do meta_monad
- [g!_ (gensym "_")
- g!value (gensym "value")
- g!record (gensym "record")]
- (wrap (list (` (function ((~ g!_) (~ g!value) (~ g!record))
- (..set@ (~ selector) (~ g!value) (~ g!record)))))))
-
- _
- (fail "Wrong syntax for set@")))
-
-(macro: #export (update@ tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Modifies the value of a record at a given tag, based on some function." ..\n
- "(update@ #age inc person)"
- __paragraph
- "## Can also work with multiple levels of nesting:" ..\n
- "(update@ [#foo #bar #baz] func my_record)"
- __paragraph
- "## And, if only the slot/path and (optionally) the value are given, generates a mutator function:" ..\n
- "(let [updater (update@ [#foo #bar #baz] func)] (updater my_record))" ..\n
- "(let [updater (update@ [#foo #bar #baz])] (updater func my_record))"))}
- (case tokens
- (^ (list [_ (#Tag slot')] fun record))
- (do meta_monad
- [slot (normalize slot')
- output (resolve_tag slot)
- #let [[idx tags exported? type] output]]
- (case (resolve_struct_type type)
- (#Some members)
- (do meta_monad
- [pattern' (monad\map meta_monad
- (: (-> [Name [Nat Type]] (Meta [Name Nat Code]))
- (function (_ [r_slot_name [r_idx r_type]])
- (do meta_monad
- [g!slot (gensym "")]
- (return [r_slot_name r_idx g!slot]))))
- (zip/2 tags (enumeration members)))]
- (let [pattern (record$ (list\map (: (-> [Name Nat Code] [Code Code])
- (function (_ [r_slot_name r_idx r_var])
- [(tag$ r_slot_name)
- r_var]))
- pattern'))
- output (record$ (list\map (: (-> [Name Nat Code] [Code Code])
- (function (_ [r_slot_name r_idx r_var])
- [(tag$ r_slot_name)
- (if ("lux i64 =" idx r_idx)
- (` ((~ fun) (~ r_var)))
- r_var)]))
- pattern'))]
- (return (list (` ({(~ pattern) (~ output)} (~ record)))))))
-
- _
- (fail "update@ can only use records.")))
-
- (^ (list [_ (#Tuple slots)] fun record))
- (case slots
- #Nil
- (fail "Wrong syntax for update@")
-
- _
- (do meta_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 meta_monad
- [g!_ (gensym "_")
- g!record (gensym "record")]
- (wrap (list (` (function ((~ g!_) (~ g!record))
- (..update@ (~ selector) (~ fun) (~ g!record)))))))
-
- (^ (list selector))
- (do meta_monad
- [g!_ (gensym "_")
- g!fun (gensym "fun")
- g!record (gensym "record")]
- (wrap (list (` (function ((~ g!_) (~ g!fun) (~ g!record))
- (..update@ (~ selector) (~ g!fun) (~ g!record)))))))
-
- _
- (fail "Wrong syntax for update@")))
-
-(macro: #export (^template tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## It's similar to template, but meant to be used during pattern-matching." ..\n
- "(def: (beta_reduce env type)" ..\n
- " (-> (List Type) Type Type)" ..\n
- " (case type" ..\n
- " (#.Primitive name params)" ..\n
- " (#.Primitive name (list\map (beta_reduce env) params))"
- __paragraph
- " (^template [<tag>]" ..\n
- " [(<tag> left right)" ..\n
- " (<tag> (beta_reduce env left) (beta_reduce env right))])" ..\n
- " ([#.Sum] [#.Product])"
- __paragraph
- " (^template [<tag>]" ..\n
- " [(<tag> left right)" ..\n
- " (<tag> (beta_reduce env left) (beta_reduce env right))])" ..\n
- " ([#.Function] [#.Apply])"
- __paragraph
- " (^template [<tag>]" ..\n
- " [(<tag> old_env def)" ..\n
- " (case old_env" ..\n
- " #.Nil" ..\n
- " (<tag> env def)"
- __paragraph
- " _" ..\n
- " type)])" ..\n
- " ([#.UnivQ] [#.ExQ])"
- __paragraph
- " (#.Parameter idx)" ..\n
- " (default type (list.nth idx env))"
- __paragraph
- " _" ..\n
- " type" ..\n
- " ))"))}
- (case tokens
- (^ (list& [_ (#Form (list [_ (#Tuple bindings)]
- [_ (#Tuple templates)]))]
- [_ (#Form data)]
- branches))
- (case (: (Maybe (List Code))
- (do maybe_monad
- [bindings' (monad\map maybe_monad get_short bindings)
- data' (monad\map maybe_monad tuple->list data)]
- (let [num_bindings (list\size bindings')]
- (if (every? (|>> ("lux i64 =" num_bindings))
- (list\map list\size data'))
- (let [apply (: (-> RepEnv (List Code))
- (function (_ env) (list\map (apply_template env) templates)))]
- (|> data'
- (list\map (compose apply (make_env bindings')))
- list\join
- wrap))
- #None))))
- (#Some output)
- (return (list\compose output branches))
-
- #None
- (fail "Wrong syntax for ^template"))
-
- _
- (fail "Wrong syntax for ^template")))
-
-(def: (find_baseline_column code)
- (-> Code Nat)
- (case code
- (^template [<tag>]
- [[[_ _ column] (<tag> _)]
- column])
- ([#Bit]
- [#Nat]
- [#Int]
- [#Rev]
- [#Frac]
- [#Text]
- [#Identifier]
- [#Tag])
-
- (^template [<tag>]
- [[[_ _ column] (<tag> parts)]
- (list\fold n/min column (list\map find_baseline_column parts))])
- ([#Form]
- [#Tuple])
-
- [[_ _ column] (#Record pairs)]
- (list\fold n/min column
- (list\compose (list\map (|>> first find_baseline_column) pairs)
- (list\map (|>> second find_baseline_column) pairs)))
- ))
-
-(type: Doc_Fragment
- (#Doc_Comment Text)
- (#Doc_Example Code))
-
-(def: (identify_doc_fragment code)
- (-> Code Doc_Fragment)
- (case code
- [_ (#Text comment)]
- (#Doc_Comment comment)
-
- _
- (#Doc_Example code)))
-
-(template [<name> <extension> <doc>]
- [(def: #export <name>
- {#.doc <doc>}
- (All [s] (-> (I64 s) (I64 s)))
- (|>> (<extension> 1)))]
-
- [inc "lux i64 +" "Increment function."]
- [dec "lux i64 -" "Decrement function."]
- )
-
-(def: tag\encode
- (-> Name Text)
- (|>> name\encode (text\compose "#")))
-
-(def: (repeat n x)
- (All [a] (-> Int a (List a)))
- (if ("lux i64 <" n +0)
- (#Cons x (repeat ("lux i64 +" -1 n) x))
- #Nil))
-
-(def: (location_padding baseline [_ old_line old_column] [_ new_line new_column])
- (-> Nat Location Location Text)
- (if ("lux i64 =" old_line new_line)
- (text\join_with "" (repeat (.int ("lux i64 -" old_column new_column)) " "))
- (let [extra_lines (text\join_with "" (repeat (.int ("lux i64 -" old_line new_line)) ..\n))
- space_padding (text\join_with "" (repeat (.int ("lux i64 -" baseline new_column)) " "))]
- (text\compose extra_lines space_padding))))
-
-(def: (text\size x)
- (-> Text Nat)
- ("lux text size" x))
-
-(def: (update_location [file line column] code_text)
- (-> Location Text Location)
- [file line ("lux i64 +" column (text\size code_text))])
-
-(def: (delim_update_location [file line column])
- (-> Location Location)
- [file line (inc column)])
-
-(def: rejoin_all_pairs
- (-> (List [Code Code]) (List Code))
- (|>> (list\map rejoin_pair) list\join))
-
-(def: (doc_example->Text prev_location baseline example)
- (-> Location Nat Code [Location Text])
- (case example
- (^template [<tag> <encode>]
- [[new_location (<tag> value)]
- (let [as_text (<encode> value)]
- [(update_location new_location as_text)
- (text\compose (location_padding baseline prev_location new_location)
- as_text)])])
- ([#Bit bit\encode]
- [#Nat nat\encode]
- [#Int int\encode]
- [#Frac frac\encode]
- [#Text text\encode]
- [#Identifier name\encode]
- [#Tag tag\encode])
-
- (^template [<tag> <open> <close> <prep>]
- [[group_location (<tag> parts)]
- (let [[group_location' parts_text] (list\fold (function (_ part [last_location text_accum])
- (let [[part_location part_text] (doc_example->Text last_location baseline part)]
- [part_location (text\compose text_accum part_text)]))
- [(delim_update_location group_location) ""]
- (<prep> parts))]
- [(delim_update_location group_location')
- ($_ text\compose (location_padding baseline prev_location group_location)
- <open>
- parts_text
- <close>)])])
- ([#Form "(" ")" ..function\identity]
- [#Tuple "[" "]" ..function\identity]
- [#Record "{" "}" rejoin_all_pairs])
-
- [new_location (#Rev value)]
- ("lux io error" "@doc_example->Text Undefined behavior.")
- ))
-
-(def: (with_baseline baseline [file line column])
- (-> Nat Location Location)
- [file line baseline])
-
-(def: (doc_fragment->Text fragment)
- (-> Doc_Fragment Text)
- (case fragment
- (#Doc_Comment comment)
- (|> comment
- (text\split_all_with ..\n)
- (list\map (function (_ line) ($_ text\compose "## " line ..\n)))
- (text\join_with ""))
-
- (#Doc_Example example)
- (let [baseline (find_baseline_column example)
- [location _] example
- [_ text] (doc_example->Text (with_baseline baseline location) baseline example)]
- (text\compose text __paragraph))))
-
-(macro: #export (doc tokens)
- {#.doc (text$ ($_ "lux text concat"
- "## Creates code documentation, embedding text as comments and properly formatting the forms it's being given."
- __paragraph
- "## For Example:" ..\n
- "(doc ''Allows arbitrary looping, using the 'recur' form to re-start the loop.''" ..\n
- " ''Can be used in monadic code to create monadic loops.''" ..\n
- " (loop [count +0" ..\n
- " x init]" ..\n
- " (if (< +10 count)" ..\n
- " (recur (inc count) (f x))" ..\n
- " x)))"))}
- (return (list (` [(~ location_code)
- (#.Text (~ (|> tokens
- (list\map (|>> identify_doc_fragment doc_fragment->Text))
- (text\join_with "")
- 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_to_code type)
- (-> Type Code)
- (case type
- (#Primitive name params)
- (` (#.Primitive (~ (text$ name)) (~ (untemplate_list (list\map type_to_code params)))))
-
- (^template [<tag>]
- [(<tag> left right)
- (` (<tag> (~ (type_to_code left)) (~ (type_to_code right))))])
- ([#.Sum] [#.Product]
- [#.Function]
- [#.Apply])
-
- (^template [<tag>]
- [(<tag> id)
- (` (<tag> (~ (nat$ id))))])
- ([#.Parameter] [#.Var] [#.Ex])
-
- (^template [<tag>]
- [(<tag> env type)
- (let [env' (untemplate_list (list\map type_to_code env))]
- (` (<tag> (~ env') (~ (type_to_code type)))))])
- ([#.UnivQ] [#.ExQ])
-
- (#Named [module name] anonymous)
- ## TODO: Generate the explicit type definition instead of using
- ## the "identifier$" shortcut below.
- ## (` (#.Named [(~ (text$ module)) (~ (text$ name))]
- ## (~ (type_to_code anonymous))))
- (identifier$ [module name])))
-
-(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))
-
- "Loops can also be given custom names."
- (loop my_loop
- [count +0
- x init]
- (if (< +10 count)
- (my_loop (inc count) (f x))
- x)))}
- (let [?params (case tokens
- (^ (list name [_ (#Tuple bindings)] body))
- (#.Some [name bindings body])
-
- (^ (list [_ (#Tuple bindings)] body))
- (#.Some [(local_identifier$ "recur") bindings body])
-
- _
- #.None)]
- (case ?params
- (#.Some [name bindings body])
- (let [pairs (as_pairs bindings)
- vars (list\map first pairs)
- inits (list\map second pairs)]
- (if (every? identifier? inits)
- (do meta_monad
- [inits' (: (Meta (List Name))
- (case (monad\map maybe_monad get_name inits)
- (#Some inits') (return inits')
- #None (fail "Wrong syntax for loop")))
- init_types (monad\map meta_monad find_type inits')
- expected get_expected_type]
- (return (list (` (("lux type check"
- (-> (~+ (list\map type_to_code init_types))
- (~ (type_to_code expected)))
- (function ((~ name) (~+ vars))
- (~ body)))
- (~+ inits))))))
- (do meta_monad
- [aliases (monad\map meta_monad
- (: (-> Code (Meta Code))
- (function (_ _) (gensym "")))
- inits)]
- (return (list (` (let [(~+ (interleave aliases inits))]
- (.loop (~ name)
- [(~+ (interleave vars aliases))]
- (~ body)))))))))
-
- #.None
- (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& [_ (#Form (list [_ (#Tuple (list& hslot' tslots'))]))] body branches))
- (do meta_monad
- [slots (: (Meta [Name (List Name)])
- (case (: (Maybe [Name (List Name)])
- (do maybe_monad
- [hslot (get_tag hslot')
- tslots (monad\map maybe_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 (monad\map meta_monad normalize tslots)
- output (resolve_tag hslot)
- g!_ (gensym "_")
- #let [[idx tags exported? type] output
- slot_pairings (list\map (: (-> Name [Text Code])
- (function (_ [module name])
- [name (local_identifier$ name)]))
- (list& hslot tslots))
- pattern (record$ (list\map (: (-> Name [Code Code])
- (function (_ [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 Code) Code (Maybe (List Code)))
- (case target
- (^or [_ (#Bit _)] [_ (#Nat _)] [_ (#Int _)] [_ (#Rev _)] [_ (#Frac _)] [_ (#Text _)] [_ (#Tag _)])
- (#Some (list target))
-
- [_ (#Identifier [prefix name])]
- (if (and (text\= "" prefix)
- (text\= label name))
- (#Some tokens)
- (#Some (list target)))
-
- (^template [<tag>]
- [[location (<tag> elems)]
- (do maybe_monad
- [placements (monad\map maybe_monad (place_tokens label tokens) elems)]
- (wrap (list [location (<tag> (list\join placements))])))])
- ([#Tuple]
- [#Form])
-
- [location (#Record pairs)]
- (do maybe_monad
- [=pairs (monad\map maybe_monad
- (: (-> [Code Code] (Maybe [Code Code]))
- (function (_ [slot value])
- (do maybe_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 [location (#Record =pairs)])))
- ))
-
-(macro: #export (with_expansions tokens)
- {#.doc (doc "Controlled macro-expansion."
- "Bind an arbitraty number of Code nodes resulting from macro-expansion to local bindings."
- "Wherever a binding appears, the bound Code nodes will be spliced in there."
- (test: "Code operations & implementations"
- (with_expansions
- [<tests> (template [<expr> <text>]
- [(compare <text> (\ Code/encode encode <expr>))]
-
- [(bit #1) "#1"]
- [(int +123) "+123"]
- [(frac +123.0) "+123.0"]
- [(text "123") "'123'"]
- [(tag ["yolo" "lol"]) "#yolo.lol"]
- [(identifier ["yolo" "lol"]) "yolo.lol"]
- [(form (list (bit #1))) "(#1)"]
- [(tuple (list (bit #1))) "[#1]"]
- [(record (list [(bit #1) (int +123)])) "{#1 +123}"]
- )]
- (test_all <tests>))))}
- (case tokens
- (^ (list& [_ (#Tuple bindings)] bodies))
- (case bindings
- (^ (list& [_ (#Identifier ["" var_name])] macro_expr bindings'))
- (do meta_monad
- [expansion (macro_expand_once macro_expr)]
- (case (place_tokens var_name expansion (` (.with_expansions
- [(~+ bindings')]
- (~+ bodies))))
- (#Some output)
- (wrap output)
-
- _
- (fail "[with_expansions] Improper macro expansion.")))
-
- #Nil
- (return bodies)
-
- _
- (fail "Wrong syntax for with_expansions"))
-
- _
- (fail "Wrong syntax for with_expansions")))
-
-(def: (flatten_alias type)
- (-> Type Type)
- (case type
- (^template [<name>]
- [(#Named ["lux" <name>] _)
- type])
- (["Bit"]
- ["Nat"]
- ["Int"]
- ["Rev"]
- ["Frac"]
- ["Text"])
-
- (#Named _ type')
- (flatten_alias type')
-
- _
- type))
-
-(def: (anti_quote_def name)
- (-> Name (Meta Code))
- (do meta_monad
- [type+value (find_def_value name)
- #let [[type value] type+value]]
- (case (flatten_alias type)
- (^template [<name> <type> <wrapper>]
- [(#Named ["lux" <name>] _)
- (wrap (<wrapper> (:as <type> value)))])
- (["Bit" Bit bit$]
- ["Nat" Nat nat$]
- ["Int" Int int$]
- ["Rev" Rev rev$]
- ["Frac" Frac frac$]
- ["Text" Text text$])
-
- _
- (fail (text\compose "Cannot anti-quote type: " (name\encode name))))))
-
-(def: (anti_quote token)
- (-> Code (Meta Code))
- (case token
- [_ (#Identifier [def_prefix def_name])]
- (if (text\= "" def_prefix)
- (do meta_monad
- [current_module current_module_name]
- (anti_quote_def [current_module def_name]))
- (anti_quote_def [def_prefix def_name]))
-
- (^template [<tag>]
- [[meta (<tag> parts)]
- (do meta_monad
- [=parts (monad\map meta_monad anti_quote parts)]
- (wrap [meta (<tag> =parts)]))])
- ([#Form]
- [#Tuple])
-
- [meta (#Record pairs)]
- (do meta_monad
- [=pairs (monad\map meta_monad
- (: (-> [Code Code] (Meta [Code Code]))
- (function (_ [slot value])
- (do meta_monad
- [=value (anti_quote value)]
- (wrap [slot =value]))))
- pairs)]
- (wrap [meta (#Record =pairs)]))
-
- _
- (\ meta_monad return token)
- ## TODO: Figure out why this doesn't work:
- ## (\ meta_monad wrap token)
- ))
-
-(macro: #export (static tokens)
- (case tokens
- (^ (list pattern))
- (do meta_monad
- [pattern' (anti_quote pattern)]
- (wrap (list pattern')))
-
- _
- (fail "Wrong syntax for 'static'.")))
-
-(type: Multi_Level_Case
- [Code (List [Code Code])])
-
-(def: (case_level^ level)
- (-> Code (Meta [Code Code]))
- (case level
- (^ [_ (#Tuple (list expr binding))])
- (return [expr binding])
-
- _
- (return [level (` #1)])
- ))
-
-(def: (multi_level_case^ levels)
- (-> (List Code) (Meta Multi_Level_Case))
- (case levels
- #Nil
- (fail "Multi-level patterns cannot be empty.")
-
- (#Cons init extras)
- (do meta_monad
- [extras' (monad\map meta_monad case_level^ extras)]
- (wrap [init extras']))))
-
-(def: (multi_level_case$ g!_ [[init_pattern levels] body])
- (-> Code [Multi_Level_Case Code] (List Code))
- (let [inner_pattern_body (list\fold (function (_ [calculation pattern] success)
- (let [bind? (case pattern
- [_ (#.Identifier _)]
- #1
-
- _
- #0)]
- (` (case (~ calculation)
- (~ pattern)
- (~ success)
-
- (~+ (if bind?
- (list)
- (list g!_ (` #.None))))))))
- (` (#.Some (~ body)))
- (: (List [Code Code]) (list\reverse levels)))]
- (list init_pattern inner_pattern_body)))
-
-(macro: #export (^multi 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)
- (^multi (#.Some [chunk uri']) [(text\= static chunk) #1])
- (match_uri endpoint? parts' uri')
-
- _
- (#.Left (format "Static part " (%t static) " does not match URI: " uri)))
-
- "Short-cuts can be taken when using bit tests."
- "The example above can be rewritten as..."
- (case (split (size static) uri)
- (^multi (#.Some [chunk uri']) (text\= static chunk))
- (match_uri endpoint? parts' uri')
-
- _
- (#.Left (format "Static part " (%t static) " does not match URI: " uri))))}
- (case tokens
- (^ (list& [_meta (#Form levels)] body next_branches))
- (do meta_monad
- [mlc (multi_level_case^ levels)
- #let [initial_bind? (case mlc
- [[_ (#.Identifier _)] _]
- #1
-
- _
- #0)]
- expected get_expected_type
- g!temp (gensym "temp")]
- (let [output (list g!temp
- (` ({(#Some (~ g!temp))
- (~ g!temp)
-
- #None
- (case (~ g!temp)
- (~+ next_branches))}
- ("lux type check" (#.Apply (~ (type_to_code expected)) Maybe)
- (case (~ g!temp)
- (~+ (multi_level_case$ g!temp [mlc body]))
-
- (~+ (if initial_bind?
- (list)
- (list g!temp (` #.None)))))))))]
- (wrap output)))
-
- _
- (fail "Wrong syntax for ^multi")))
-
-## TODO: Allow asking the compiler for the name of the definition
-## currently being defined. That name can then be fed into
-## 'wrong_syntax_error' for easier maintenance of the error_messages.
-(def: wrong_syntax_error
- (-> Name Text)
- (|>> name\encode
- (text\compose "Wrong syntax for ")))
-
-(macro: #export (name_of tokens)
- {#.doc (doc "Given an identifier or a tag, gives back a 2 tuple with the prefix and name parts, both as Text."
- (name_of #.doc)
- "=>"
- ["lux" "doc"])}
- (case tokens
- (^template [<tag>]
- [(^ (list [_ (<tag> [prefix name])]))
- (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))])
- ([#Identifier] [#Tag])
-
- _
- (fail (..wrong_syntax_error ["lux" "name_of"]))))
-
-(def: (get_scope_type_vars state)
- (Meta (List Nat))
- (case state
- {#info info #source source #current_module _ #modules modules
- #scopes scopes #type_context types #host host
- #seed seed #expected expected #location location #extensions extensions
- #scope_type_vars scope_type_vars}
- (#Right state scope_type_vars)
- ))
-
-(def: (list_at idx xs)
- (All [a] (-> Nat (List a) (Maybe a)))
- (case xs
- #Nil
- #None
-
- (#Cons x xs')
- (if ("lux i64 =" 0 idx)
- (#Some x)
- (list_at (dec idx) xs'))))
-
-(macro: #export ($ tokens)
- {#.doc (doc "Allows you to refer to the type-variables in a polymorphic function's type, by their index."
- "In the example below, 0 corresponds to the 'a' variable."
- (def: #export (from_list list)
- (All [a] (-> (List a) (Row a)))
- (list\fold add
- (: (Row ($ 0))
- empty)
- list)))}
- (case tokens
- (^ (list [_ (#Nat idx)]))
- (do meta_monad
- [stvs get_scope_type_vars]
- (case (list_at idx (list\reverse stvs))
- (#Some var_id)
- (wrap (list (` (#Ex (~ (nat$ var_id))))))
-
- #None
- (fail (text\compose "Indexed-type does not exist: " (nat\encode idx)))))
-
- _
- (fail (..wrong_syntax_error (name_of ..$)))))
-
-(def: #export (is? reference sample)
- {#.doc (doc "Tests whether the 2 values are identical (not just 'equal')."
- "This one should succeed:"
- (let [value +5]
- (is? value value))
-
- "This one should fail:"
- (is? +5 (+ +2 +3)))}
- (All [a] (-> a a Bit))
- ("lux is" reference sample))
-
-(macro: #export (^@ tokens)
- {#.doc (doc "Allows you to simultaneously bind and de-structure a value."
- (def: (hash (^@ set [Hash<a> _]))
- (list\fold (function (_ elem acc) (+ (\ Hash<a> hash elem) acc))
- 0
- (to_list set))))}
- (case tokens
- (^ (list& [_meta (#Form (list [_ (#Identifier ["" name])] pattern))] body branches))
- (let [g!whole (local_identifier$ name)]
- (return (list& g!whole
- (` (case (~ g!whole) (~ pattern) (~ body)))
- branches)))
-
- _
- (fail (..wrong_syntax_error (name_of ..^@)))))
-
-(macro: #export (^|> tokens)
- {#.doc (doc "Pipes the value being pattern-matched against prior to binding it to a variable."
- (case input
- (^|> value [inc (% 10) (max 1)])
- (foo value)))}
- (case tokens
- (^ (list& [_meta (#Form (list [_ (#Identifier ["" name])] [_ (#Tuple steps)]))] body branches))
- (let [g!name (local_identifier$ name)]
- (return (list& g!name
- (` (let [(~ g!name) (|> (~ g!name) (~+ steps))]
- (~ body)))
- branches)))
-
- _
- (fail (..wrong_syntax_error (name_of ..^|>)))))
-
-(macro: #export (:assume tokens)
- {#.doc (doc "Coerces the given expression to the type of whatever is expected."
- (: Dinosaur (:assume (list +1 +2 +3))))}
- (case tokens
- (^ (list expr))
- (do meta_monad
- [type get_expected_type]
- (wrap (list (` ("lux type as" (~ (type_to_code type)) (~ expr))))))
-
- _
- (fail (..wrong_syntax_error (name_of ..:assume)))))
-
-(def: location
- {#.doc "The location of the current expression being analyzed."}
- (Meta Location)
- (function (_ compiler)
- (#Right [compiler (get@ #location compiler)])))
-
-(macro: #export (undefined tokens)
- {#.doc (doc "Meant to be used as a stand-in for functions with undefined implementations."
- "Undefined expressions will type-check against everything, so they make good dummy implementations."
- "However, if an undefined expression is ever evaluated, it will raise a runtime error."
- (def: (square x)
- (-> Int Int)
- (undefined)))}
- (case tokens
- #Nil
- (do meta_monad
- [location ..location
- #let [[module line column] location
- location ($_ "lux text concat" (text\encode module) "," (nat\encode line) "," (nat\encode column))
- message ($_ "lux text concat" "Undefined behavior @ " location)]]
- (wrap (list (` (..error! (~ (text$ message)))))))
-
- _
- (fail (..wrong_syntax_error (name_of ..undefined)))))
-
-(macro: #export (:of tokens)
- {#.doc (doc "Generates the type corresponding to a given expression."
- "Example #1:"
- (let [my_num +123]
- (:of my_num))
- "=="
- Int
- "-------------------"
- "Example #2:"
- (:of +123)
- "=="
- Int)}
- (case tokens
- (^ (list [_ (#Identifier var_name)]))
- (do meta_monad
- [var_type (find_type var_name)]
- (wrap (list (type_to_code var_type))))
-
- (^ (list expression))
- (do meta_monad
- [g!temp (gensym "g!temp")]
- (wrap (list (` (let [(~ g!temp) (~ expression)]
- (..:of (~ g!temp)))))))
-
- _
- (fail (..wrong_syntax_error (name_of ..:of)))))
-
-(def: (parse_complex_declaration tokens)
- (-> (List Code) (Meta [[Text (List Text)] (List Code)]))
- (case tokens
- (^ (list& [_ (#Form (list& [_ (#Identifier ["" name])] args'))] tokens'))
- (do meta_monad
- [args (monad\map meta_monad
- (function (_ arg')
- (case arg'
- [_ (#Identifier ["" arg_name])]
- (wrap arg_name)
-
- _
- (fail "Could not parse an argument.")))
- args')]
- (wrap [[name args] tokens']))
-
- _
- (fail "Could not parse a complex declaration.")
- ))
-
-(def: (parse_any tokens)
- (-> (List Code) (Meta [Code (List Code)]))
- (case tokens
- (^ (list& token tokens'))
- (return [token tokens'])
-
- _
- (fail "Could not parse anything.")
- ))
-
-(def: (parse_many tokens)
- (-> (List Code) (Meta [(List Code) (List Code)]))
- (case tokens
- (^ (list& head tail))
- (return [tokens (list)])
-
- _
- (fail "Could not parse anything.")
- ))
-
-(def: (parse_end tokens)
- (-> (List Code) (Meta Any))
- (case tokens
- (^ (list))
- (return [])
-
- _
- (fail "Expected input Codes to be empty.")
- ))
-
-(def: (parse_anns tokens)
- (-> (List Code) (Meta [Code (List Code)]))
- (case tokens
- (^ (list& [_ (#Record _anns)] tokens'))
- (return [(record$ _anns) tokens'])
-
- _
- (return [(' {}) tokens])
- ))
-
-(macro: #export (template: tokens)
- {#.doc (doc "Define macros in the style of template and ^template."
- "For simple macros that do not need any fancy features."
- (template: (square x)
- (* x x)))}
- (do meta_monad
- [#let [[export? tokens] (export^ tokens)]
- name+args|tokens (parse_complex_declaration tokens)
- #let [[[name args] tokens] name+args|tokens]
- anns|tokens (parse_anns tokens)
- #let [[anns tokens] anns|tokens]
- input_templates|tokens (parse_many tokens)
- #let [[input_templates tokens] input_templates|tokens]
- _ (parse_end tokens)
- g!tokens (gensym "tokens")
- g!compiler (gensym "compiler")
- g!_ (gensym "_")
- #let [rep_env (list\map (function (_ arg)
- [arg (` ((~' ~) (~ (local_identifier$ arg))))])
- args)]
- this_module current_module_name]
- (wrap (list (` (macro: (~+ (export export?))
- ((~ (local_identifier$ name)) (~ g!tokens) (~ g!compiler))
- (~ anns)
- (case (~ g!tokens)
- (^ (list (~+ (list\map local_identifier$ args))))
- (#.Right [(~ g!compiler)
- (list (~+ (list\map (function (_ template)
- (` (`' (~ (replace_syntax rep_env template)))))
- input_templates)))])
-
- (~ g!_)
- (#.Left (~ (text$ (..wrong_syntax_error [this_module name]))))
- )))))
- ))
-
-(macro: #export (as_is tokens compiler)
- (#Right [compiler tokens]))
-
-(macro: #export (char tokens compiler)
- (case tokens
- (^multi (^ (list [_ (#Text input)]))
- (|> input "lux text size" ("lux i64 =" 1)))
- (|> input ("lux text char" 0)
- nat$ list
- [compiler] #Right)
-
- _
- (#Left (..wrong_syntax_error (name_of ..char)))))
-
-(def: target
- (Meta Text)
- (function (_ compiler)
- (#Right [compiler (get@ [#info #target] compiler)])))
-
-(def: (resolve_target choice)
- (-> Code (Meta Text))
- (case choice
- [_ (#Text platform)]
- (..return platform)
-
- [_ (#Identifier identifier)]
- (do meta_monad
- [identifier (..resolve_global_identifier identifier)
- type+value (..find_def_value identifier)
- #let [[type value] type+value]]
- (case (..flatten_alias type)
- (^or (#Primitive "#Text" #Nil)
- (#Named ["lux" "Text"] (#Primitive "#Text" #Nil)))
- (wrap (:as ..Text value))
-
- _
- (fail ($_ text\compose
- "Invalid target platform (must be a value of type Text): " (name\encode identifier)
- " : " (..code\encode (..type_to_code type))))))
-
- _
- (fail ($_ text\compose
- "Invalid target platform syntax: " (..code\encode choice)
- ..\n "Must be either a text literal or an identifier."))))
-
-(def: (target_pick target options default)
- (-> Text (List [Code Code]) (Maybe Code) (Meta (List Code)))
- (case options
- #Nil
- (case default
- #.None
- (fail ($_ text\compose "No code for target platform: " target))
-
- (#.Some default)
- (return (list default)))
-
- (#Cons [key pick] options')
- (do meta_monad
- [platform (..resolve_target key)]
- (if (text\= target platform)
- (return (list pick))
- (target_pick target options' default)))))
-
-(macro: #export (for tokens)
- (do meta_monad
- [target ..target]
- (case tokens
- (^ (list [_ (#Record options)]))
- (target_pick target options #.None)
-
- (^ (list [_ (#Record options)] default))
- (target_pick target options (#.Some default))
-
- _
- (fail (..wrong_syntax_error (name_of ..for))))))
-
-(template [<name> <type> <output>]
- [(def: (<name> xy)
- (All [a b] (-> [a b] <type>))
- (let [[x y] xy]
- <output>))]
-
- [left a x]
- [right b y])
-
-(def: (label_code code)
- (-> Code (Meta [(List [Code Code]) Code]))
- (case code
- (^ [ann (#Form (list [_ (#Identifier ["" "~~"])] expansion))])
- (do meta_monad
- [g!expansion (gensym "g!expansion")]
- (wrap [(list [g!expansion expansion]) g!expansion]))
-
- (^template [<tag>]
- [[ann (<tag> parts)]
- (do meta_monad
- [=parts (monad\map meta_monad label_code parts)]
- (wrap [(list\fold list\compose (list) (list\map left =parts))
- [ann (<tag> (list\map right =parts))]]))])
- ([#Form] [#Tuple])
-
- [ann (#Record kvs)]
- (do meta_monad
- [=kvs (monad\map meta_monad
- (function (_ [key val])
- (do meta_monad
- [=key (label_code key)
- =val (label_code val)
- #let [[key_labels key_labelled] =key
- [val_labels val_labelled] =val]]
- (wrap [(list\compose key_labels val_labels) [key_labelled val_labelled]])))
- kvs)]
- (wrap [(list\fold list\compose (list) (list\map left =kvs))
- [ann (#Record (list\map right =kvs))]]))
-
- _
- (return [(list) code])))
-
-(macro: #export (`` tokens)
- (case tokens
- (^ (list raw))
- (do meta_monad
- [=raw (label_code raw)
- #let [[labels labelled] =raw]]
- (wrap (list (` (with_expansions [(~+ (|> labels
- (list\map (function (_ [label expansion]) (list label expansion)))
- list\join))]
- (~ labelled))))))
-
- _
- (fail (..wrong_syntax_error (name_of ..``)))
- ))
-
-(def: (name$ [module name])
- (-> Name Code)
- (` [(~ (text$ module)) (~ (text$ name))]))
-
-(def: (untemplate_list& last inits)
- (-> Code (List Code) Code)
- (case inits
- #Nil
- last
-
- (#Cons [init inits'])
- (` (#.Cons (~ init) (~ (untemplate_list& last inits'))))))
-
-(def: (untemplate_record g!meta untemplate_pattern fields)
- (-> Code (-> Code (Meta Code))
- (-> (List [Code Code]) (Meta Code)))
- (do meta_monad
- [=fields (monad\map meta_monad
- (function (_ [key value])
- (do meta_monad
- [=key (untemplate_pattern key)
- =value (untemplate_pattern value)]
- (wrap (` [(~ =key) (~ =value)]))))
- fields)]
- (wrap (` [(~ g!meta) (#.Record (~ (untemplate_list =fields)))]))))
-
-(template [<tag> <name>]
- [(def: (<name> g!meta untemplate_pattern elems)
- (-> Code (-> Code (Meta Code))
- (-> (List Code) (Meta Code)))
- (case (list\reverse elems)
- (#Cons [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))]
- inits)
- (do meta_monad
- [=inits (monad\map meta_monad untemplate_pattern (list\reverse inits))]
- (wrap (` [(~ g!meta) (<tag> (~ (untemplate_list& spliced =inits)))])))
-
- _
- (do meta_monad
- [=elems (monad\map meta_monad untemplate_pattern elems)]
- (wrap (` [(~ g!meta) (<tag> (~ (untemplate_list =elems)))])))))]
-
- [#.Tuple untemplate_tuple]
- [#.Form untemplate_form]
- )
-
-(def: (untemplate_pattern pattern)
- (-> Code (Meta Code))
- (do meta_monad
- [g!meta (gensym "g!meta")]
- (case pattern
- (^template [<tag> <gen>]
- [[_ (<tag> value)]
- (wrap (` [(~ g!meta) (<tag> (~ (<gen> value)))]))])
- ([#.Bit bit$]
- [#.Nat nat$]
- [#.Int int$]
- [#.Rev rev$]
- [#.Frac frac$]
- [#.Text text$]
- [#.Tag name$]
- [#.Identifier name$])
-
- [_ (#Form (#Cons [[_ (#Identifier ["" "~"])] (#Cons [unquoted #Nil])]))]
- (return unquoted)
-
- [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))]
- (fail "Cannot use (~+) inside of ^code unless it is the last element in a form or a tuple.")
-
- (^template [<tag> <untemplate>]
- [[_ (<tag> elems)]
- (<untemplate> g!meta untemplate_pattern elems)])
- ([#.Tuple ..untemplate_tuple]
- [#.Form ..untemplate_form])
-
- [_ (#Record fields)]
- (..untemplate_record g!meta untemplate_pattern fields)
- )))
-
-(macro: #export (^code tokens)
- (case tokens
- (^ (list& [_meta (#Form (list template))] body branches))
- (do meta_monad
- [pattern (untemplate_pattern template)]
- (wrap (list& pattern body branches)))
-
- (^ (list template))
- (do meta_monad
- [pattern (untemplate_pattern template)]
- (wrap (list pattern)))
-
- _
- (fail (..wrong_syntax_error (name_of ..^code)))))
-
-(template [<zero> <one>]
- [(def: #export <zero> #0)
- (def: #export <one> #1)]
-
- [false true]
- [no yes]
- [off on]
- )
-
-(macro: #export (:let tokens)
- (case tokens
- (^ (list [_ (#Tuple bindings)] bodyT))
- (if (multiple? 2 (list\size bindings))
- (return (list (` (..with_expansions [(~+ (|> bindings
- ..as_pairs
- (list\map (function (_ [localT valueT])
- (list localT (` (..as_is (~ valueT))))))
- (list\fold list\compose (list))))]
- (~ bodyT)))))
- (..fail ":let requires an even number of parts"))
-
- _
- (..fail (..wrong_syntax_error (name_of ..:let)))))
-
-(macro: #export (try tokens)
- {#.doc (doc (case (try (risky_computation input))
- (#.Right success)
- (do_something success)
-
- (#.Left error)
- (recover_from_failure error)))}
- (case tokens
- (^ (list expression))
- (do meta_monad
- [g!_ (gensym "g!_")]
- (wrap (list (` ("lux try"
- (.function ((~ g!_) (~ g!_))
- (~ expression)))))))
-
- _
- (..fail (..wrong_syntax_error (name_of ..try)))))
diff --git a/stdlib/source/lux/abstract/algebra.lux b/stdlib/source/lux/abstract/algebra.lux
deleted file mode 100644
index 14d29bf16..000000000
--- a/stdlib/source/lux/abstract/algebra.lux
+++ /dev/null
@@ -1,16 +0,0 @@
-(.module:
- [lux #*
- [control
- [functor (#+ Fix)]]])
-
-(type: #export (Algebra f a)
- (-> (f a) a))
-
-(type: #export (CoAlgebra f a)
- (-> a (f a)))
-
-(type: #export (RAlgebra f a)
- (-> (f (& (Fix f) a)) a))
-
-(type: #export (RCoAlgebra f a)
- (-> a (f (| (Fix f) a))))
diff --git a/stdlib/source/lux/abstract/apply.lux b/stdlib/source/lux/abstract/apply.lux
deleted file mode 100644
index 6f0e61ba8..000000000
--- a/stdlib/source/lux/abstract/apply.lux
+++ /dev/null
@@ -1,36 +0,0 @@
-(.module:
- [lux #*]
- [//
- [monad (#+ Monad)]
- ["." functor (#+ Functor)]])
-
-(interface: #export (Apply f)
- {#.doc "Applicative functors."}
- (: (Functor f)
- &functor)
- (: (All [a b]
- (-> (f (-> a b)) (f a) (f b)))
- apply))
-
-(implementation: #export (compose f-monad f-apply g-apply)
- {#.doc "Applicative functor composition."}
- (All [F G]
- (-> (Monad F) (Apply F) (Apply G)
- ## TODO: Replace (All [a] (F (G a))) with (functor.Then F G)
- (Apply (All [a] (F (G a))))))
-
- (def: &functor (functor.compose (get@ #&functor f-apply) (get@ #&functor g-apply)))
-
- (def: (apply fgf fgx)
- ## TODO: Switch from this version to the one below (in comments) ASAP.
- (let [fgf' (\ f-apply apply
- (\ f-monad wrap (\ g-apply apply))
- fgf)]
- (\ f-apply apply fgf' fgx))
- ## (let [applyF (\ f-apply apply)
- ## applyG (\ g-apply apply)]
- ## ($_ applyF
- ## (\ f-monad wrap applyG)
- ## fgf
- ## fgx))
- ))
diff --git a/stdlib/source/lux/abstract/codec.lux b/stdlib/source/lux/abstract/codec.lux
deleted file mode 100644
index 454b64cb5..000000000
--- a/stdlib/source/lux/abstract/codec.lux
+++ /dev/null
@@ -1,28 +0,0 @@
-(.module:
- [lux #*
- [control
- ["." try (#+ Try)]]]
- [//
- [monad (#+ do)]
- ["." functor]])
-
-(interface: #export (Codec m a)
- {#.doc "A way to move back-and-forth between a type and an alternative representation for it."}
- (: (-> a m)
- encode)
- (: (-> m (Try a))
- decode))
-
-(implementation: #export (compose cb-codec ba-codec)
- {#.doc "Codec composition."}
- (All [a b c]
- (-> (Codec c b) (Codec b a)
- (Codec c a)))
- (def: encode
- (|>> (\ ba-codec encode)
- (\ cb-codec encode)))
-
- (def: (decode cy)
- (do try.monad
- [by (\ cb-codec decode cy)]
- (\ ba-codec decode by))))
diff --git a/stdlib/source/lux/abstract/comonad.lux b/stdlib/source/lux/abstract/comonad.lux
deleted file mode 100644
index 63565bd3a..000000000
--- a/stdlib/source/lux/abstract/comonad.lux
+++ /dev/null
@@ -1,78 +0,0 @@
-(.module:
- [lux #*
- [data
- [collection
- ["." list ("#\." fold)]]]
- [math
- [number
- ["n" nat]]]
- [meta
- ["." location]]]
- [//
- [functor (#+ Functor)]])
-
-(interface: #export (CoMonad w)
- {#.doc (doc "CoMonads are the opposite/complement to monads."
- "CoMonadic structures are often infinite in size and built upon lazily-evaluated functions.")}
- (: (Functor w)
- &functor)
- (: (All [a]
- (-> (w a) a))
- unwrap)
- (: (All [a]
- (-> (w a) (w (w a))))
- split))
-
-(macro: #export (be tokens state)
- {#.doc (doc "A co-monadic parallel to the 'do' macro."
- (let [square (function (_ n) (* n n))]
- (be comonad
- [inputs (iterate inc +2)]
- (square (head inputs)))))}
- (case (: (Maybe [(Maybe Text) Code (List Code) Code])
- (case tokens
- (^ (list [_ (#.Record (list [[_ (#.Identifier ["" name])] comonad]))] [_ (#.Tuple bindings)] body))
- (#.Some [(#.Some name) comonad bindings body])
-
- (^ (list comonad [_ (#.Tuple bindings)] body))
- (#.Some [#.None comonad bindings body])
-
- _
- #.None))
- (#.Some [?name comonad bindings body])
- (if (|> bindings list.size (n.% 2) (n.= 0))
- (let [[module short] (name_of ..be)
- gensym (: (-> Text Code)
- (|>> ($_ "lux text concat" module " " short " ") [""] #.Identifier [location.dummy]))
- g!_ (gensym "_")
- g!map (gensym "map")
- g!split (gensym "split")
- body' (list\fold (: (-> [Code Code] Code Code)
- (function (_ binding body')
- (let [[var value] binding]
- (case var
- [_ (#.Tag ["" "let"])]
- (` (let (~ value) (~ body')))
-
- _
- (` (|> (~ value) (~ g!split) ((~ g!map) (function ((~ g!_) (~ var)) (~ body')))))
- ))))
- body
- (list.reverse (list.as_pairs bindings)))]
- (#.Right [state (list (case ?name
- (#.Some name)
- (let [name [location.dummy (#.Identifier ["" name])]]
- (` ({(~ name)
- ({[(~ g!map) (~' unwrap) (~ g!split)]
- (~ body')}
- (~ name))}
- (~ comonad))))
-
- #.None
- (` ({[(~ g!map) (~' unwrap) (~ g!split)]
- (~ body')}
- (~ comonad)))))]))
- (#.Left "'be' bindings must have an even number of parts."))
-
- #.None
- (#.Left "Wrong syntax for 'be'")))
diff --git a/stdlib/source/lux/abstract/comonad/cofree.lux b/stdlib/source/lux/abstract/comonad/cofree.lux
deleted file mode 100644
index 64413f1ce..000000000
--- a/stdlib/source/lux/abstract/comonad/cofree.lux
+++ /dev/null
@@ -1,27 +0,0 @@
-(.module:
- [lux #*]
- [// (#+ CoMonad)
- [//
- [functor (#+ Functor)]]])
-
-(type: #export (CoFree F a)
- {#.doc "The CoFree CoMonad."}
- [a (F (CoFree F a))])
-
-(implementation: #export (functor dsl)
- (All [F] (-> (Functor F) (Functor (CoFree F))))
-
- (def: (map f [head tail])
- [(f head) (\ dsl map (map f) tail)]))
-
-(implementation: #export (comonad dsl)
- (All [F] (-> (Functor F) (CoMonad (CoFree F))))
-
- (def: &functor (..functor dsl))
-
- (def: (unwrap [head tail])
- head)
-
- (def: (split [head tail])
- [[head tail]
- (\ dsl map split tail)]))
diff --git a/stdlib/source/lux/abstract/enum.lux b/stdlib/source/lux/abstract/enum.lux
deleted file mode 100644
index d98848f78..000000000
--- a/stdlib/source/lux/abstract/enum.lux
+++ /dev/null
@@ -1,25 +0,0 @@
-(.module:
- [lux #*]
- [//
- ["." order (#+ Order)]])
-
-(interface: #export (Enum e)
- {#.doc "Enumerable types, with a notion of moving forward and backwards through a type's instances."}
- (: (Order e) &order)
- (: (-> e e) succ)
- (: (-> e e) pred))
-
-(def: #export (range enum from to)
- {#.doc "An inclusive [from, to] range of values."}
- (All [a] (-> (Enum a) a a (List a)))
- (let [(^open "/\.") enum]
- (loop [end to
- output #.Nil]
- (cond (/\< end from)
- (recur (/\pred end) (#.Cons end output))
-
- (/\< from end)
- (recur (/\succ end) (#.Cons end output))
-
- ## (/\= end from)
- (#.Cons end output)))))
diff --git a/stdlib/source/lux/abstract/equivalence.lux b/stdlib/source/lux/abstract/equivalence.lux
deleted file mode 100644
index 58d644c9b..000000000
--- a/stdlib/source/lux/abstract/equivalence.lux
+++ /dev/null
@@ -1,24 +0,0 @@
-(.module:
- [lux #*]
- [//
- [functor
- ["." contravariant]]])
-
-(interface: #export (Equivalence a)
- {#.doc "Equivalence for a type's instances."}
- (: (-> a a Bit)
- =))
-
-(def: #export (rec sub)
- (All [a] (-> (-> (Equivalence a) (Equivalence a)) (Equivalence a)))
- (implementation
- (def: (= left right)
- (sub = left right))))
-
-(implementation: #export functor
- (contravariant.Functor Equivalence)
-
- (def: (map f equivalence)
- (implementation
- (def: (= reference sample)
- (\ equivalence = (f reference) (f sample))))))
diff --git a/stdlib/source/lux/abstract/fold.lux b/stdlib/source/lux/abstract/fold.lux
deleted file mode 100644
index 3f957bb55..000000000
--- a/stdlib/source/lux/abstract/fold.lux
+++ /dev/null
@@ -1,16 +0,0 @@
-(.module:
- [lux #*]
- [//
- [monoid (#+ Monoid)]])
-
-(interface: #export (Fold F)
- {#.doc "Iterate over a structure's values to build a summary value."}
- (: (All [a b]
- (-> (-> b a a) a (F b) a))
- fold))
-
-(def: #export (with-monoid monoid fold value)
- (All [F a]
- (-> (Monoid a) (Fold F) (F a) a))
- (let [(^open "/\.") monoid]
- (fold /\compose /\identity value)))
diff --git a/stdlib/source/lux/abstract/functor.lux b/stdlib/source/lux/abstract/functor.lux
deleted file mode 100644
index d3012b686..000000000
--- a/stdlib/source/lux/abstract/functor.lux
+++ /dev/null
@@ -1,44 +0,0 @@
-(.module: lux)
-
-(interface: #export (Functor f)
- (: (All [a b]
- (-> (-> a b)
- (-> (f a) (f b))))
- map))
-
-(type: #export (Fix f)
- (f (Fix f)))
-
-(type: #export (Or f g)
- (All [a] (| (f a) (g a))))
-
-(def: #export (sum (^open "f\.") (^open "g\."))
- (All [F G] (-> (Functor F) (Functor G) (Functor (..Or F G))))
- (implementation
- (def: (map f fa|ga)
- (case fa|ga
- (#.Left fa)
- (#.Left (f\map f fa))
-
- (#.Right ga)
- (#.Right (g\map f ga))))))
-
-(type: #export (And f g)
- (All [a] (& (f a) (g a))))
-
-(def: #export (product (^open "f\.") (^open "g\."))
- (All [F G] (-> (Functor F) (Functor G) (Functor (..And F G))))
- (implementation
- (def: (map f [fa ga])
- [(f\map f fa)
- (g\map f ga)])))
-
-(type: #export (Then f g)
- (All [a] (f (g a))))
-
-(def: #export (compose (^open "f\.") (^open "g\."))
- {#.doc "Functor composition."}
- (All [F G] (-> (Functor F) (Functor G) (Functor (..Then F G))))
- (implementation
- (def: (map f fga)
- (f\map (g\map f) fga))))
diff --git a/stdlib/source/lux/abstract/functor/contravariant.lux b/stdlib/source/lux/abstract/functor/contravariant.lux
deleted file mode 100644
index d91813e1f..000000000
--- a/stdlib/source/lux/abstract/functor/contravariant.lux
+++ /dev/null
@@ -1,8 +0,0 @@
-(.module:
- [lux #*])
-
-(interface: #export (Functor f)
- (: (All [a b]
- (-> (-> b a)
- (-> (f a) (f b))))
- map))
diff --git a/stdlib/source/lux/abstract/hash.lux b/stdlib/source/lux/abstract/hash.lux
deleted file mode 100644
index 14857ef18..000000000
--- a/stdlib/source/lux/abstract/hash.lux
+++ /dev/null
@@ -1,26 +0,0 @@
-(.module:
- [lux #*]
- [//
- ["." equivalence (#+ Equivalence)]
- [functor
- ["." contravariant]]])
-
-(interface: #export (Hash a)
- {#.doc (doc "A way to produce hash-codes for a type's instances."
- "A necessity when working with some data-structures, such as dictionaries or sets.")}
- (: (Equivalence a)
- &equivalence)
- (: (-> a Nat)
- hash))
-
-(implementation: #export functor
- (contravariant.Functor Hash)
-
- (def: (map f super)
- (implementation
- (def: &equivalence
- (\ equivalence.functor map f
- (\ super &equivalence)))
-
- (def: hash
- (|>> f (\ super hash))))))
diff --git a/stdlib/source/lux/abstract/interval.lux b/stdlib/source/lux/abstract/interval.lux
deleted file mode 100644
index e43529890..000000000
--- a/stdlib/source/lux/abstract/interval.lux
+++ /dev/null
@@ -1,193 +0,0 @@
-## https://en.wikipedia.org/wiki/Interval_(mathematics)
-(.module:
- [lux #*]
- [//
- [equivalence (#+ Equivalence)]
- ["." order]
- [enum (#+ Enum)]])
-
-(interface: #export (Interval a)
- {#.doc "A representation of top and bottom boundaries for an ordered type."}
- (: (Enum a)
- &enum)
-
- (: a
- bottom)
-
- (: a
- top))
-
-(def: #export (between enum bottom top)
- (All [a] (-> (Enum a) a a (Interval a)))
- (implementation
- (def: &enum enum)
- (def: bottom bottom)
- (def: top top)))
-
-(def: #export (singleton enum elem)
- (All [a] (-> (Enum a) a (Interval a)))
- (implementation
- (def: &enum enum)
- (def: bottom elem)
- (def: top elem)))
-
-(template [<name> <comp>]
- [(def: #export (<name> interval)
- (All [a] (-> (Interval a) Bit))
- (let [(^open ",\.") interval]
- (<comp> ,\bottom ,\top)))]
-
- [inner? (order.> ,\&order)]
- [outer? ,\<]
- [singleton? ,\=]
- )
-
-(def: #export (within? interval elem)
- (All [a] (-> (Interval a) a Bit))
- (let [(^open ",\.") interval]
- (cond (inner? interval)
- (and (order.>= ,\&order ,\bottom elem)
- (order.<= ,\&order ,\top elem))
-
- (outer? interval)
- (or (order.>= ,\&order ,\bottom elem)
- (order.<= ,\&order ,\top elem))
-
- ## singleton
- (and (,\= ,\bottom elem)
- (,\= ,\top elem)))))
-
-(template [<name> <limit>]
- [(def: #export (<name> elem interval)
- (All [a] (-> a (Interval a) Bit))
- (let [(^open ".") interval]
- (= <limit> elem)))]
-
- [starts_with? bottom]
- [ends_with? top]
- )
-
-(def: #export (borders? interval elem)
- (All [a] (-> (Interval a) a Bit))
- (or (starts_with? elem interval)
- (ends_with? elem interval)))
-
-(def: #export (union left right)
- (All [a] (-> (Interval a) (Interval a) (Interval a)))
- (implementation
- (def: &enum (get@ #&enum right))
- (def: bottom (order.min (\ right &order) (\ left bottom) (\ right bottom)))
- (def: top (order.max (\ right &order) (\ left top) (\ right top)))))
-
-(def: #export (intersection left right)
- (All [a] (-> (Interval a) (Interval a) (Interval a)))
- (implementation
- (def: &enum (get@ #&enum right))
- (def: bottom (order.max (\ right &order) (\ left bottom) (\ right bottom)))
- (def: top (order.min (\ right &order) (\ left top) (\ right top)))))
-
-(def: #export (complement interval)
- (All [a] (-> (Interval a) (Interval a)))
- (let [(^open ".") interval]
- (implementation
- (def: &enum (get@ #&enum interval))
- (def: bottom (succ top))
- (def: top (pred bottom)))))
-
-(def: #export (precedes? reference sample)
- (All [a] (-> (Interval a) (Interval a) Bit))
- (let [(^open ".") reference
- limit (\ reference bottom)]
- (and (< limit (\ sample bottom))
- (< limit (\ sample top)))))
-
-(def: #export (succeeds? reference sample)
- (All [a] (-> (Interval a) (Interval a) Bit))
- (precedes? sample reference))
-
-(template [<name> <comp>]
- [(def: #export (<name> reference sample)
- (All [a] (-> a (Interval a) Bit))
- (let [(^open ",\.") sample]
- (and (<comp> reference ,\bottom)
- (<comp> reference ,\top))))]
-
- [before? ,\<]
- [after? (order.> ,\&order)]
- )
-
-(def: #export (meets? reference sample)
- (All [a] (-> (Interval a) (Interval a) Bit))
- (let [(^open ",\.") reference
- limit (\ reference bottom)]
- (and (,\= limit (\ sample top))
- (order.<= ,\&order limit (\ sample bottom)))))
-
-(def: #export (touches? reference sample)
- (All [a] (-> (Interval a) (Interval a) Bit))
- (or (meets? reference sample)
- (meets? sample reference)))
-
-(template [<name> <eq_side> <ineq> <ineq_side>]
- [(def: #export (<name> reference sample)
- (All [a] (-> (Interval a) (Interval a) Bit))
- (let [(^open ",\.") reference]
- (and (,\= (\ reference <eq_side>)
- (\ sample <eq_side>))
- (<ineq> ,\&order
- (\ reference <ineq_side>)
- (\ sample <ineq_side>)))))]
-
- [starts? ,\bottom order.<= ,\top]
- [finishes? ,\top order.>= ,\bottom]
- )
-
-(implementation: #export equivalence (All [a] (Equivalence (Interval a)))
- (def: (= reference sample)
- (let [(^open ",\.") reference]
- (and (,\= ,\bottom (\ sample bottom))
- (,\= ,\top (\ sample top))))))
-
-(def: #export (nested? reference sample)
- (All [a] (-> (Interval a) (Interval a) Bit))
- (cond (or (singleton? sample)
- (and (inner? reference) (inner? sample))
- (and (outer? reference) (outer? sample)))
- (let [(^open ",\.") reference]
- (and (order.>= ,\&order (\ reference bottom) (\ sample bottom))
- (order.<= ,\&order (\ reference top) (\ sample top))))
-
- (or (singleton? reference)
- (and (inner? reference) (outer? sample)))
- #0
-
- ## (and (outer? reference) (inner? sample))
- (let [(^open ",\.") reference]
- (or (and (order.>= ,\&order (\ reference bottom) (\ sample bottom))
- (order.> ,\&order (\ reference bottom) (\ sample top)))
- (and (,\< (\ reference top) (\ sample bottom))
- (order.<= ,\&order (\ reference top) (\ sample top)))))
- ))
-
-(def: #export (overlaps? reference sample)
- (All [a] (-> (Interval a) (Interval a) Bit))
- (let [(^open ",\.") reference]
- (and (not (\ ..equivalence = reference sample))
- (cond (singleton? sample)
- #0
-
- (singleton? reference)
- (nested? sample reference)
-
- (or (and (inner? sample) (outer? reference))
- (and (outer? sample) (inner? reference)))
- (or (order.>= ,\&order (\ reference bottom) (\ sample top))
- (order.<= ,\&order (\ reference top) (\ sample bottom)))
-
- ## both inner
- (inner? sample)
- (inner? (intersection reference sample))
-
- ## both outer
- (not (nested? reference sample))
- ))))
diff --git a/stdlib/source/lux/abstract/monad.lux b/stdlib/source/lux/abstract/monad.lux
deleted file mode 100644
index d32bdacbb..000000000
--- a/stdlib/source/lux/abstract/monad.lux
+++ /dev/null
@@ -1,183 +0,0 @@
-(.module:
- [lux #*
- [meta
- ["." location]]]
- [//
- [functor (#+ Functor)]])
-
-(def: (list\fold f init xs)
- (All [a b]
- (-> (-> b a a) a (List b) a))
- (case xs
- #.Nil
- init
-
- (#.Cons x xs')
- (list\fold f (f x init) xs')))
-
-(def: (list\size xs)
- (All [a] (-> (List a) Nat))
- (loop [counter 0
- xs xs]
- (case xs
- #.Nil
- counter
-
- (#.Cons _ xs')
- (recur (inc counter) xs'))))
-
-(def: (reverse xs)
- (All [a]
- (-> (List a) (List a)))
- (list\fold (function (_ 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))
-
-(interface: #export (Monad m)
- (: (Functor m)
- &functor)
- (: (All [a]
- (-> a (m a)))
- wrap)
- (: (All [a]
- (-> (m (m a)) (m a)))
- join))
-
-(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 (: (Maybe [(Maybe Text) Code (List Code) Code])
- (case tokens
- (^ (list [_ (#.Record (list [[_ (#.Identifier ["" name])] monad]))] [_ (#.Tuple bindings)] body))
- (#.Some [(#.Some name) monad bindings body])
-
- (^ (list monad [_ (#.Tuple bindings)] body))
- (#.Some [#.None monad bindings body])
-
- _
- #.None))
- (#.Some [?name monad bindings body])
- (if (|> bindings list\size .int ("lux i64 %" +2) ("lux i64 =" +0))
- (let [[module short] (name_of ..do)
- gensym (: (-> Text Code)
- (|>> ($_ "lux text concat" module " " short " ") [""] #.Identifier [location.dummy]))
- g!_ (gensym "_")
- g!map (gensym "map")
- g!join (gensym "join")
- body' (list\fold (: (-> [Code Code] Code Code)
- (function (_ binding body')
- (let [[var value] binding]
- (case var
- [_ (#.Tag ["" "let"])]
- (` (let (~ value) (~ body')))
-
- _
- (` (|> (~ value) ((~ g!map) (function ((~ g!_) (~ var)) (~ body'))) (~ g!join)))
- ))))
- body
- (reverse (as_pairs bindings)))]
- (#.Right [state (list (case ?name
- (#.Some name)
- (let [name [location.dummy (#.Identifier ["" name])]]
- (` ({(~ name)
- ({[(~ g!map) (~' wrap) (~ g!join)]
- (~ body')}
- (~ name))}
- (~ monad))))
-
- #.None
- (` ({[(~ g!map) (~' wrap) (~ g!join)]
- (~ body')}
- (~ monad)))))]))
- (#.Left "'do' bindings must have an even number of parts."))
-
- #.None
- (#.Left "Wrong syntax for 'do'")))
-
-(def: #export (bind monad f)
- (All [! a b]
- (-> (Monad !) (-> a (! b))
- (-> (! a) (! b))))
- (|>> (\ monad map f)
- (\ monad join)))
-
-(def: #export (seq monad)
- {#.doc "Run all the monadic values in the list and produce a list of the base values."}
- (All [M a]
- (-> (Monad M) (List (M a))
- (M (List a))))
- (let [(^open "!\.") monad]
- (function (recur xs)
- (case xs
- #.Nil
- (!\wrap #.Nil)
-
- (#.Cons x xs')
- (|> x
- (!\map (function (_ _x)
- (!\map (|>> (#.Cons _x)) (recur xs'))))
- !\join)))))
-
-(def: #export (map monad f)
- {#.doc "Apply a monadic function to all values in a list."}
- (All [M a b]
- (-> (Monad M) (-> a (M b)) (List a)
- (M (List b))))
- (let [(^open "!\.") monad]
- (function (recur xs)
- (case xs
- #.Nil
- (!\wrap #.Nil)
-
- (#.Cons x xs')
- (|> (f x)
- (!\map (function (_ _x)
- (!\map (|>> (#.Cons _x)) (recur xs'))))
- !\join)))))
-
-(def: #export (filter monad f)
- {#.doc "Filter the values in a list with a monadic function."}
- (All [! a b]
- (-> (Monad !) (-> a (! Bit)) (List a)
- (! (List a))))
- (let [(^open "!\.") monad]
- (function (recur xs)
- (case xs
- #.Nil
- (!\wrap #.Nil)
-
- (#.Cons head xs')
- (|> (f head)
- (!\map (function (_ verdict)
- (!\map (function (_ tail)
- (if verdict
- (#.Cons head tail)
- tail))
- (recur xs'))))
- !\join)))))
-
-(def: #export (fold monad f init xs)
- {#.doc "Fold a list with a monadic function."}
- (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)]
- (fold monad f init' xs'))))
diff --git a/stdlib/source/lux/abstract/monad/free.lux b/stdlib/source/lux/abstract/monad/free.lux
deleted file mode 100644
index 7a9efbeea..000000000
--- a/stdlib/source/lux/abstract/monad/free.lux
+++ /dev/null
@@ -1,67 +0,0 @@
-(.module:
- [lux #*]
- [///
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- [monad (#+ Monad)]])
-
-(type: #export (Free F a)
- {#.doc "The Free Monad."}
- (#Pure a)
- (#Effect (F (Free F a))))
-
-(implementation: #export (functor dsl)
- (All [F] (-> (Functor F) (Functor (Free F))))
-
- (def: (map f ea)
- (case ea
- (#Pure a)
- (#Pure (f a))
-
- (#Effect value)
- (#Effect (\ dsl map (map f) value)))))
-
-(implementation: #export (apply dsl)
- (All [F] (-> (Functor F) (Apply (Free F))))
-
- (def: &functor (..functor dsl))
-
- (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
- (function (_ f) (apply f ea))
- ff))
- )))
-
-(implementation: #export (monad dsl)
- (All [F] (-> (Functor F) (Monad (Free F))))
-
- (def: &functor (..functor dsl))
-
- (def: (wrap a)
- (#Pure a))
-
- (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))
- )))
diff --git a/stdlib/source/lux/abstract/monad/indexed.lux b/stdlib/source/lux/abstract/monad/indexed.lux
deleted file mode 100644
index 5a5a63b27..000000000
--- a/stdlib/source/lux/abstract/monad/indexed.lux
+++ /dev/null
@@ -1,83 +0,0 @@
-(.module:
- [lux #*
- [control
- [monad]
- ["p" parser
- ["s" code (#+ Parser)]]]
- [data
- [collection
- ["." list ("#\." functor fold)]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]]])
-
-(interface: #export (IxMonad m)
- (: (All [p a]
- (-> a (m p p a)))
- wrap)
-
- (: (All [ii it io vi vo]
- (-> (-> vi (m it io vo))
- (m ii it vi)
- (m ii io vo)))
- bind))
-
-(type: Binding [Code Code])
-
-(def: binding
- (Parser Binding)
- (p.and s.any s.any))
-
-(type: Context
- (#Let (List Binding))
- (#Bind Binding))
-
-(def: context
- (Parser Context)
- (p.or (p.after (s.this! (' #let))
- (s.tuple (p.some binding)))
- binding))
-
-(def: (pair_list [binding value])
- (All [a] (-> [a a] (List a)))
- (list binding value))
-
-(def: named_monad
- (Parser [(Maybe Text) Code])
- (p.either (s.record (p.and (\ p.monad map (|>> #.Some)
- s.local_identifier)
- s.any))
- (\ p.monad map (|>> [#.None])
- s.any)))
-
-(syntax: #export (do {[?name monad] ..named_monad}
- {context (s.tuple (p.some context))}
- expression)
- (macro.with_gensyms [g!_ g!bind]
- (let [body (list\fold (function (_ context next)
- (case context
- (#Let bindings)
- (` (let [(~+ (|> bindings
- (list\map pair_list)
- list.concat))]
- (~ next)))
-
- (#Bind [binding value])
- (` ((~ g!bind)
- (.function ((~ g!_) (~ binding))
- (~ next))
- (~ value)))))
- expression
- (list.reverse context))]
- (wrap (list (case ?name
- (#.Some name)
- (let [name (code.local_identifier name)]
- (` (let [(~ name) (~ monad)
- {#..wrap (~' wrap)
- #..bind (~ g!bind)} (~ name)]
- (~ body))))
-
- #.None
- (` (let [{#..wrap (~' wrap)
- #..bind (~ g!bind)} (~ monad)]
- (~ body)))))))))
diff --git a/stdlib/source/lux/abstract/monoid.lux b/stdlib/source/lux/abstract/monoid.lux
deleted file mode 100644
index 2b5560421..000000000
--- a/stdlib/source/lux/abstract/monoid.lux
+++ /dev/null
@@ -1,20 +0,0 @@
-(.module:
- [lux #*])
-
-(interface: #export (Monoid a)
- {#.doc (doc "A way to compose values."
- "Includes an identity value which does not alter any other value when combined with.")}
- (: a
- identity)
- (: (-> a a a)
- compose))
-
-(def: #export (compose left right)
- (All [l r] (-> (Monoid l) (Monoid r) (Monoid [l r])))
- (implementation
- (def: identity
- [(\ left identity) (\ right identity)])
-
- (def: (compose [lL rL] [lR rR])
- [(\ left compose lL lR)
- (\ right compose rL rR)])))
diff --git a/stdlib/source/lux/abstract/order.lux b/stdlib/source/lux/abstract/order.lux
deleted file mode 100644
index 9d031bca2..000000000
--- a/stdlib/source/lux/abstract/order.lux
+++ /dev/null
@@ -1,57 +0,0 @@
-(.module:
- [lux #*
- [control
- ["." function]]]
- [//
- ["." equivalence (#+ Equivalence)]
- [functor
- ["." contravariant]]])
-
-(interface: #export (Order a)
- {#.doc "A signature for types that possess some sense of ordering among their elements."}
-
- (: (Equivalence a)
- &equivalence)
-
- (: (-> a a Bit)
- <)
- )
-
-(type: #export (Comparison a)
- (-> (Order a) a a Bit))
-
-(def: #export (<= order parameter subject)
- Comparison
- (or (\ order < parameter subject)
- (\ order = parameter subject)))
-
-(def: #export (> order parameter subject)
- Comparison
- (\ order < subject parameter))
-
-(def: #export (>= order parameter subject)
- Comparison
- (or (\ order < subject parameter)
- (\ order = subject parameter)))
-
-(type: #export (Choice a)
- (-> (Order a) a a a))
-
-(def: #export (min order x y)
- Choice
- (if (\ order < y x) x y))
-
-(def: #export (max order x y)
- Choice
- (if (\ order < y x) y x))
-
-(implementation: #export functor
- (contravariant.Functor Order)
-
- (def: (map f order)
- (implementation
- (def: &equivalence
- (\ equivalence.functor map f (\ order &equivalence)))
-
- (def: (< reference sample)
- (\ order < (f reference) (f sample))))))
diff --git a/stdlib/source/lux/abstract/predicate.lux b/stdlib/source/lux/abstract/predicate.lux
deleted file mode 100644
index 841865c10..000000000
--- a/stdlib/source/lux/abstract/predicate.lux
+++ /dev/null
@@ -1,60 +0,0 @@
-(.module:
- [lux #*
- [control
- ["." function]]]
- [//
- [monoid (#+ Monoid)]
- [functor
- ["." contravariant]]])
-
-(type: #export (Predicate a)
- (-> a Bit))
-
-(template [<identity_name> <identity_value> <composition_name> <composition>]
- [(def: #export <identity_name>
- Predicate
- (function.constant <identity_value>))
-
- (def: #export (<composition_name> left right)
- (All [a] (-> (Predicate a) (Predicate a) (Predicate a)))
- (function (_ value)
- (<composition> (left value)
- (right value))))]
-
- [none #0 unite or]
- [all #1 intersect and]
- )
-
-(template [<name> <identity> <composition>]
- [(implementation: #export <name>
- (All [a] (Monoid (Predicate a)))
-
- (def: identity <identity>)
- (def: compose <composition>))]
-
- [union ..none ..unite]
- [intersection ..all ..intersect]
- )
-
-(def: #export (complement predicate)
- (All [a] (-> (Predicate a) (Predicate a)))
- (|>> predicate not))
-
-(def: #export (difference sub base)
- (All [a] (-> (Predicate a) (Predicate a) (Predicate a)))
- (function (_ value)
- (and (base value)
- (not (sub value)))))
-
-(def: #export (rec predicate)
- (All [a]
- (-> (-> (Predicate a) (Predicate a))
- (Predicate a)))
- (function (recur input)
- (predicate recur input)))
-
-(implementation: #export functor
- (contravariant.Functor Predicate)
-
- (def: (map f fb)
- (|>> f fb)))
diff --git a/stdlib/source/lux/control/concatenative.lux b/stdlib/source/lux/control/concatenative.lux
deleted file mode 100644
index 51c2604b6..000000000
--- a/stdlib/source/lux/control/concatenative.lux
+++ /dev/null
@@ -1,330 +0,0 @@
-(.module:
- [lux (#- Alias if loop)
- ["." meta]
- [abstract
- ["." monad]]
- [data
- ["." maybe ("#\." monad)]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." fold functor)]]]
- ["." macro (#+ with_gensyms)
- ["." code]
- [syntax (#+ syntax:)
- ["|.|" export]
- ["|.|" annotations]]]
- [math
- [number
- ["n" nat]
- ["i" int]
- ["r" rev]
- ["f" frac]]]]
- [//
- ["<>" parser ("#\." monad)
- ["<c>" code (#+ Parser)]]])
-
-(type: Alias [Text Code])
-
-(type: Stack
- {#bottom (Maybe Nat)
- #top (List Code)})
-
-(def: aliases^
- (Parser (List Alias))
- (|> (<>.and <c>.local_identifier <c>.any)
- <>.some
- <c>.record
- (<>.default (list))))
-
-(def: bottom^
- (Parser Nat)
- (<c>.form (<>.after (<c>.this! (` #.Parameter)) <c>.nat)))
-
-(def: stack^
- (Parser Stack)
- (<>.either (<>.and (<>.maybe bottom^)
- (<c>.tuple (<>.some <c>.any)))
- (<>.and (|> bottom^ (<>\map (|>> #.Some)))
- (<>\wrap (list)))))
-
-(def: (stack_fold tops bottom)
- (-> (List Code) Code Code)
- (list\fold (function (_ top bottom)
- (` [(~ bottom) (~ top)]))
- bottom
- tops))
-
-(def: (singleton expander)
- (-> (Meta (List Code)) (Meta Code))
- (monad.do meta.monad
- [expansion expander]
- (case expansion
- (#.Cons singleton #.Nil)
- (wrap singleton)
-
- _
- (meta.fail (format "Cannot expand to more than a single AST/Code node:" text.new_line
- (|> expansion (list\map %.code) (text.join_with " ")))))))
-
-(syntax: #export (=> {aliases aliases^}
- {inputs stack^}
- {outputs stack^})
- (let [de_alias (function (_ aliased)
- (list\fold (function (_ [from to] pre)
- (code.replace (code.local_identifier from) to pre))
- aliased
- aliases))]
- (case [(|> inputs (get@ #bottom) (maybe\map (|>> code.nat (~) #.Parameter (`))))
- (|> outputs (get@ #bottom) (maybe\map (|>> code.nat (~) #.Parameter (`))))]
- [(#.Some bottomI) (#.Some bottomO)]
- (monad.do meta.monad
- [inputC (singleton (macro.expand_all (stack_fold (get@ #top inputs) bottomI)))
- outputC (singleton (macro.expand_all (stack_fold (get@ #top outputs) bottomO)))]
- (wrap (list (` (-> (~ (de_alias inputC))
- (~ (de_alias outputC)))))))
-
- [?bottomI ?bottomO]
- (with_gensyms [g!stack]
- (monad.do meta.monad
- [inputC (singleton (macro.expand_all (stack_fold (get@ #top inputs) (maybe.default g!stack ?bottomI))))
- outputC (singleton (macro.expand_all (stack_fold (get@ #top outputs) (maybe.default g!stack ?bottomO))))]
- (wrap (list (` (All [(~ g!stack)]
- (-> (~ (de_alias inputC))
- (~ (de_alias outputC))))))))))))
-
-(def: begin! Any [])
-
-(def: end!
- (All [a] (-> [Any a] a))
- (function (_ [_ top])
- top))
-
-(syntax: #export (||> {commands (<>.some <c>.any)})
- (wrap (list (` (|> (~! ..begin!) (~+ commands) ((~! ..end!)))))))
-
-(syntax: #export (word:
- {export |export|.parser}
- {name <c>.local_identifier}
- {annotations (<>.default |annotations|.empty |annotations|.parser)}
- type
- {commands (<>.some <c>.any)})
- (wrap (list (` (def: (~+ (|export|.format export)) (~ (code.local_identifier name))
- (~ (|annotations|.format annotations))
- (~ type)
- (|>> (~+ commands)))))))
-
-(syntax: #export (apply {arity (|> <c>.nat (<>.filter (n.> 0)))})
- (with_gensyms [g! g!func g!stack g!output]
- (monad.do {! meta.monad}
- [g!inputs (|> (macro.gensym "input") (list.repeat arity) (monad.seq !))]
- (wrap (list (` (: (All [(~+ g!inputs) (~ g!output)]
- (-> (-> (~+ g!inputs) (~ g!output))
- (=> [(~+ g!inputs)] [(~ g!output)])))
- (function ((~ g!) (~ g!func))
- (function ((~ g!) (~ (stack_fold g!inputs g!stack)))
- [(~ g!stack) ((~ g!func) (~+ g!inputs))])))))))))
-
-(def: #export apply/1 (apply 1))
-(def: #export apply/2 (apply 2))
-(def: #export apply/3 (apply 3))
-(def: #export apply/4 (apply 4))
-(def: #export apply/5 (apply 5))
-(def: #export apply/6 (apply 6))
-(def: #export apply/7 (apply 7))
-(def: #export apply/8 (apply 8))
-
-(def: #export (push x)
- (All [a] (-> a (=> [] [a])))
- (function (_ stack)
- [stack x]))
-
-(def: #export drop
- (All [t] (=> [t] []))
- (function (_ [stack top])
- stack))
-
-(def: #export nip
- (All [_ a] (=> [_ a] [a]))
- (function (_ [[stack _] top])
- [stack top]))
-
-(def: #export dup
- (All [a] (=> [a] [a a]))
- (function (_ [stack top])
- [[stack top] top]))
-
-(def: #export swap
- (All [a b] (=> [a b] [b a]))
- (function (_ [[stack l] r])
- [[stack r] l]))
-
-(def: #export rotL
- (All [a b c] (=> [a b c] [b c a]))
- (function (_ [[[stack a] b] c])
- [[[stack b] c] a]))
-
-(def: #export rotR
- (All [a b c] (=> [a b c] [c a b]))
- (function (_ [[[stack a] b] c])
- [[[stack c] a] b]))
-
-(def: #export &&
- (All [a b] (=> [a b] [(& a b)]))
- (function (_ [[stack l] r])
- [stack [l r]]))
-
-(def: #export ||L
- (All [a b] (=> [a] [(| a b)]))
- (function (_ [stack l])
- [stack (0 #0 l)]))
-
-(def: #export ||R
- (All [a b] (=> [b] [(| a b)]))
- (function (_ [stack r])
- [stack (0 #1 r)]))
-
-(template [<input> <output> <word> <func>]
- [(def: #export <word>
- (=> [<input> <input>] [<output>])
- (function (_ [[stack subject] param])
- [stack (<func> param subject)]))]
-
- [Nat Nat n/+ n.+]
- [Nat Nat n/- n.-]
- [Nat Nat n/* n.*]
- [Nat Nat n// n./]
- [Nat Nat n/% n.%]
- [Nat Bit n/= n.=]
- [Nat Bit n/< n.<]
- [Nat Bit n/<= n.<=]
- [Nat Bit n/> n.>]
- [Nat Bit n/>= n.>=]
-
- [Int Int i/+ i.+]
- [Int Int i/- i.-]
- [Int Int i/* i.*]
- [Int Int i// i./]
- [Int Int i/% i.%]
- [Int Bit i/= i.=]
- [Int Bit i/< i.<]
- [Int Bit i/<= i.<=]
- [Int Bit i/> i.>]
- [Int Bit i/>= i.>=]
-
- [Rev Rev r/+ r.+]
- [Rev Rev r/- r.-]
- [Rev Rev r/* r.*]
- [Rev Rev r// r./]
- [Rev Rev r/% r.%]
- [Rev Bit r/= r.=]
- [Rev Bit r/< r.<]
- [Rev Bit r/<= r.<=]
- [Rev Bit r/> r.>]
- [Rev Bit r/>= r.>=]
-
- [Frac Frac f/+ f.+]
- [Frac Frac f/- f.-]
- [Frac Frac f/* f.*]
- [Frac Frac f// f./]
- [Frac Frac f/% f.%]
- [Frac Bit f/= f.=]
- [Frac Bit f/< f.<]
- [Frac Bit f/<= f.<=]
- [Frac Bit f/> f.>]
- [Frac Bit f/>= f.>=]
- )
-
-(def: #export if
- (All [___a ___z]
- (=> {then (=> ___a ___z)
- else (=> ___a ___z)}
- ___a [Bit then else] ___z))
- (function (_ [[[stack test] then] else])
- (.if test
- (then stack)
- (else stack))))
-
-(def: #export call
- (All [___a ___z]
- (=> {quote (=> ___a ___z)}
- ___a [quote] ___z))
- (function (_ [stack quote])
- (quote stack)))
-
-(def: #export loop
- (All [___]
- (=> {test (=> ___ ___ [Bit])}
- ___ [test] ___))
- (function (loop [stack pred])
- (let [[stack' verdict] (pred stack)]
- (.if verdict
- (loop [stack' pred])
- stack'))))
-
-(def: #export dip
- (All [___ a]
- (=> ___ [a (=> ___ ___)]
- ___ [a]))
- (function (_ [[stack a] quote])
- [(quote stack) a]))
-
-(def: #export dip/2
- (All [___ a b]
- (=> ___ [a b (=> ___ ___)]
- ___ [a b]))
- (function (_ [[[stack a] b] quote])
- [[(quote stack) a] b]))
-
-(def: #export do
- (All [___a ___z]
- (=> {body (=> ___a ___z)
- pred (=> ___z ___a [Bit])}
- ___a [pred body]
- ___z [pred body]))
- (function (_ [[stack pred] body])
- [[(body stack) pred] body]))
-
-(def: #export while
- (All [___a ___z]
- (=> {body (=> ___z ___a)
- pred (=> ___a ___z [Bit])}
- ___a [pred body]
- ___z))
- (function (while [[stack pred] body])
- (let [[stack' verdict] (pred stack)]
- (.if verdict
- (while [[(body stack') pred] body])
- stack'))))
-
-(def: #export compose
- (All [___a ___ ___z]
- (=> [(=> ___a ___) (=> ___ ___z)]
- [(=> ___a ___z)]))
- (function (_ [[stack f] g])
- [stack (|>> f g)]))
-
-(def: #export curry
- (All [___a ___z a]
- (=> ___a [a (=> ___a [a] ___z)]
- ___a [(=> ___a ___z)]))
- (function (_ [[stack arg] quote])
- [stack (|>> (push arg) quote)]))
-
-(word: #export when
- (All [___]
- (=> {body (=> ___ ___)}
- ___ [Bit body]
- ___))
- swap
- (push (|>> call))
- (push (|>> drop))
- if)
-
-(word: #export ?
- (All [a]
- (=> [Bit a a] [a]))
- rotL
- (push (|>> drop))
- (push (|>> nip))
- if)
diff --git a/stdlib/source/lux/control/concurrency/actor.lux b/stdlib/source/lux/control/concurrency/actor.lux
deleted file mode 100644
index 9e17193b2..000000000
--- a/stdlib/source/lux/control/concurrency/actor.lux
+++ /dev/null
@@ -1,389 +0,0 @@
-(.module: {#.doc "The actor model of concurrency."}
- [lux #*
- [abstract
- monad]
- [control
- [pipe (#+ case>)]
- ["." function]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." io (#+ IO io)]
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." monoid monad fold)]]]
- ["." macro (#+ with_gensyms)
- ["." code]
- [syntax (#+ syntax:)
- ["|.|" input]
- ["|.|" export]
- ["|.|" annotations]]]
- [math
- [number
- ["n" nat]]]
- ["." meta (#+ monad)
- ["." annotation]]
- [type (#+ :share)
- ["." abstract (#+ abstract: :representation :abstraction)]]]
- [//
- ["." atom (#+ Atom atom)]
- ["." promise (#+ Promise Resolver) ("#\." monad)]
- ["." frp (#+ Channel)]])
-
-(exception: #export poisoned)
-(exception: #export dead)
-
-(with_expansions
- [<Mail> (as_is (-> s (Actor s) (Promise (Try s))))
- <Obituary> (as_is [Text s (List <Mail>)])
- <Mailbox> (as_is (Rec Mailbox
- [(Promise [<Mail> Mailbox])
- (Resolver [<Mail> Mailbox])]))]
-
- (def: (pending [read write])
- (All [a]
- (-> (Rec Mailbox
- [(Promise [a Mailbox])
- (Resolver [a Mailbox])])
- (IO (List a))))
- (do {! io.monad}
- [current (promise.poll read)]
- (case current
- (#.Some [head tail])
- (\ ! map (|>> (#.Cons head))
- (pending tail))
-
- #.None
- (wrap #.Nil))))
-
- (abstract: #export (Actor s)
- {#obituary [(Promise <Obituary>)
- (Resolver <Obituary>)]
- #mailbox (Atom <Mailbox>)}
-
- (type: #export (Mail s)
- <Mail>)
-
- (type: #export (Obituary s)
- <Obituary>)
-
- (type: #export (Behavior o s)
- {#.doc "An actor's behavior when mail is received and when a fatal error occurs."}
- {#on_init (-> o s)
- #on_mail (-> (Mail s) s (Actor s) (Promise (Try s)))})
-
- (def: #export (spawn! behavior init)
- {#.doc "Given a behavior and initial state, spawns an actor and returns it."}
- (All [o s] (-> (Behavior o s) o (IO (Actor s))))
- (io (let [[on_init on_mail] behavior
- self (:share [o s]
- (Behavior o s)
- behavior
-
- (Actor s)
- (:abstraction {#obituary (promise.promise [])
- #mailbox (atom (promise.promise []))}))
- process (loop [state (on_init init)
- [|mailbox| _] (io.run (atom.read (get@ #mailbox (:representation self))))]
- (do {! promise.monad}
- [[head tail] |mailbox|
- ?state' (on_mail head state self)]
- (case ?state'
- (#try.Failure error)
- (let [[_ resolve] (get@ #obituary (:representation self))]
- (exec (io.run
- (do io.monad
- [pending (..pending tail)]
- (resolve [error state (#.Cons head pending)])))
- (wrap [])))
-
- (#try.Success state')
- (recur state' tail))))]
- self)))
-
- (def: #export (alive? actor)
- (All [s] (-> (Actor s) (IO Bit)))
- (let [[obituary _] (get@ #obituary (:representation actor))]
- (|> obituary
- promise.poll
- (\ io.functor map
- (|>> (case> #.None
- yes
-
- _
- no))))))
-
- (def: #export (obituary actor)
- (All [s] (-> (Actor s) (IO (Maybe (Obituary s)))))
- (let [[obituary _] (get@ #obituary (:representation actor))]
- (promise.poll obituary)))
-
- (def: #export await
- (All [s] (-> (Actor s) (Promise (Obituary s))))
- (|>> :representation
- (get@ #obituary)
- product.left))
-
- (def: #export (mail! mail actor)
- {#.doc "Send mail to an actor.."}
- (All [s] (-> (Mail s) (Actor s) (IO (Try Any))))
- (do {! io.monad}
- [alive? (..alive? actor)]
- (if alive?
- (let [entry [mail (promise.promise [])]]
- (do !
- [|mailbox|&resolve (atom.read (get@ #mailbox (:representation actor)))]
- (loop [[|mailbox| resolve] |mailbox|&resolve]
- (do !
- [|mailbox| (promise.poll |mailbox|)]
- (case |mailbox|
- #.None
- (do !
- [resolved? (resolve entry)]
- (if resolved?
- (do !
- [_ (atom.write (product.right entry) (get@ #mailbox (:representation actor)))]
- (wrap (exception.return [])))
- (recur |mailbox|&resolve)))
-
- (#.Some [_ |mailbox|'])
- (recur |mailbox|'))))))
- (wrap (exception.throw ..dead [])))))
-
- (type: #export (Message s o)
- (-> s (Actor s) (Promise (Try [s o]))))
-
- (def: (mail message)
- (All [s o] (-> (Message s o) [(Promise (Try o)) (Mail s)]))
- (let [[promise resolve] (:share [s o]
- (Message s o)
- message
-
- [(Promise (Try o))
- (Resolver (Try o))]
- (promise.promise []))]
- [promise
- (function (_ state self)
- (do {! promise.monad}
- [outcome (message state self)]
- (case outcome
- (#try.Success [state' return])
- (exec (io.run (resolve (#try.Success return)))
- (promise.resolved (#try.Success state')))
-
- (#try.Failure error)
- (exec (io.run (resolve (#try.Failure error)))
- (promise.resolved (#try.Failure error))))))]))
-
- (def: #export (tell! message actor)
- {#.doc "Communicate with an actor through message passing."}
- (All [s o] (-> (Message s o) (Actor s) (Promise (Try o))))
- (let [[promise mail] (..mail message)]
- (do promise.monad
- [outcome (promise.future (..mail! mail actor))]
- (case outcome
- (#try.Success)
- promise
-
- (#try.Failure error)
- (wrap (#try.Failure error))))))
- )
- )
-
-(def: (default_on_mail mail state self)
- (All [s] (-> (Mail s) s (Actor s) (Promise (Try s))))
- (mail state self))
-
-(def: #export default
- (All [s] (Behavior s s))
- {#on_init function.identity
- #on_mail ..default_on_mail})
-
-(def: #export (poison! actor)
- {#.doc (doc "Kills the actor by sending mail that will kill it upon processing,"
- "but allows the actor to handle previous mail.")}
- (All [s] (-> (Actor s) (IO (Try Any))))
- (..mail! (function (_ state self)
- (promise.resolved (exception.throw ..poisoned [])))
- actor))
-
-(def: actor_decl^
- (Parser [Text (List Text)])
- (<>.either (<code>.form (<>.and <code>.local_identifier (<>.some <code>.local_identifier)))
- (<>.and <code>.local_identifier (\ <>.monad wrap (list)))))
-
-(type: On_MailC
- [[Text Text Text] Code])
-
-(type: BehaviorC
- [(Maybe On_MailC) (List Code)])
-
-(def: argument
- (Parser Text)
- <code>.local_identifier)
-
-(def: behavior^
- (Parser BehaviorC)
- (let [on_mail_args ($_ <>.and ..argument ..argument ..argument)]
- ($_ <>.and
- (<>.maybe (<code>.form (<>.and (<code>.form (<>.after (<code>.this! (' on_mail)) on_mail_args))
- <code>.any)))
- (<>.some <code>.any))))
-
-(def: (on_mail g!_ ?on_mail)
- (-> Code (Maybe On_MailC) Code)
- (case ?on_mail
- #.None
- (` (~! ..default_on_mail))
-
- (#.Some [[mailN stateN selfN] bodyC])
- (` (function ((~ g!_)
- (~ (code.local_identifier mailN))
- (~ (code.local_identifier stateN))
- (~ (code.local_identifier selfN)))
- (~ bodyC)))))
-
-(with_expansions [<examples> (as_is (actor: #export (Stack a)
- (List a)
-
- ((on_mail mail state self)
- (do (try.with promise.monad)
- [#let [_ (log! "BEFORE")]
- output (mail state self)
- #let [_ (log! "AFTER")]]
- (wrap output)))
-
- (message: #export (push {value a} state self (List a))
- (let [state' (#.Cons value state)]
- (promise.resolved (#try.Success [state' state'])))))
-
- (actor: #export Counter
- Nat
-
- (message: #export (count! {increment Nat} state self Any)
- (let [state' (n.+ increment state)]
- (promise.resolved (#try.Success [state' state']))))
-
- (message: #export (read! state self Nat)
- (promise.resolved (#try.Success [state state])))))]
- (syntax: #export (actor:
- {export |export|.parser}
- {[name vars] actor_decl^}
- {annotations (<>.default |annotations|.empty |annotations|.parser)}
- state_type
- {[?on_mail messages] behavior^})
- {#.doc (doc "Defines an actor, with its behavior and internal state."
- "Messages for the actor must be defined after the on_mail handler."
- <examples>)}
- (with_gensyms [g!_]
- (do meta.monad
- [g!type (macro.gensym (format name "_abstract_type"))
- #let [g!actor (code.local_identifier name)
- g!vars (list\map code.local_identifier vars)]]
- (wrap (list (` ((~! abstract:) (~+ (|export|.format export)) ((~ g!type) (~+ g!vars))
- (~ state_type)
-
- (def: (~+ (|export|.format export)) (~ g!actor)
- (All [(~+ g!vars)]
- (..Behavior (~ state_type) ((~ g!type) (~+ g!vars))))
- {#..on_init (|>> ((~! abstract.:abstraction) (~ g!type)))
- #..on_mail (~ (..on_mail g!_ ?on_mail))})
-
- (~+ messages))))))))
-
- (syntax: #export (actor {[state_type init] (<code>.record (<>.and <code>.any <code>.any))}
- {[?on_mail messages] behavior^})
- (with_gensyms [g!_]
- (wrap (list (` (: ((~! io.IO) (..Actor (~ state_type)))
- (..spawn! (: (..Behavior (~ state_type) (~ state_type))
- {#..on_init (|>>)
- #..on_mail (~ (..on_mail g!_ ?on_mail))})
- (: (~ state_type)
- (~ init)))))))))
-
- (type: Signature
- {#vars (List Text)
- #name Text
- #inputs (List |input|.Input)
- #state Text
- #self Text
- #output Code})
-
- (def: signature^
- (Parser Signature)
- (<code>.form ($_ <>.and
- (<>.default (list) (<code>.tuple (<>.some <code>.local_identifier)))
- <code>.local_identifier
- (<>.some |input|.parser)
- <code>.local_identifier
- <code>.local_identifier
- <code>.any)))
-
- (def: reference^
- (Parser [Name (List Text)])
- (<>.either (<code>.form (<>.and <code>.identifier (<>.some <code>.local_identifier)))
- (<>.and <code>.identifier (\ <>.monad wrap (list)))))
-
- (syntax: #export (message:
- {export |export|.parser}
- {signature signature^}
- {annotations (<>.default |annotations|.empty |annotations|.parser)}
- body)
- {#.doc (doc "A message can access the actor's state through the state parameter."
- "A message can also access the actor itself through the self parameter."
- "A message's output must be a promise containing a 2-tuple with the updated state and a return value."
- "A message may succeed or fail (in case of failure, the actor dies)."
-
- <examples>)}
- (with_gensyms [g!_ g!return]
- (do meta.monad
- [actor_scope abstract.current
- #let [g!type (code.local_identifier (get@ #abstract.name actor_scope))
- g!message (code.local_identifier (get@ #name signature))
- g!actor_vars (get@ #abstract.type_vars actor_scope)
- g!all_vars (|> signature (get@ #vars) (list\map code.local_identifier) (list\compose g!actor_vars))
- g!inputsC (|> signature (get@ #inputs) (list\map product.left))
- g!inputsT (|> signature (get@ #inputs) (list\map product.right))
- g!state (|> signature (get@ #state) code.local_identifier)
- g!self (|> signature (get@ #self) code.local_identifier)]]
- (wrap (list (` (def: (~+ (|export|.format export)) ((~ g!message) (~+ g!inputsC))
- (~ (|annotations|.format annotations))
- (All [(~+ g!all_vars)]
- (-> (~+ g!inputsT)
- (..Message (~ (get@ #abstract.abstraction actor_scope))
- (~ (get@ #output signature)))))
- (function ((~ g!_) (~ g!state) (~ g!self))
- (let [(~ g!state) (:as (~ (get@ #abstract.representation actor_scope))
- (~ g!state))]
- (|> (~ body)
- (: ((~! promise.Promise) ((~! try.Try) [(~ (get@ #abstract.representation actor_scope))
- (~ (get@ #output signature))])))
- (:as ((~! promise.Promise) ((~! try.Try) [(~ (get@ #abstract.abstraction actor_scope))
- (~ (get@ #output signature))]))))))))
- ))))))
-
-(type: #export Stop
- (IO Any))
-
-(def: continue! true)
-(def: stop! false)
-
-(def: #export (observe action channel actor)
- (All [e s] (-> (-> e Stop (Mail s)) (Channel e) (Actor s) (IO Any)))
- (let [signal (: (Atom Bit)
- (atom.atom ..continue!))
- stop (: Stop
- (atom.write ..stop! signal))]
- (frp.subscribe (function (_ event)
- (do {! io.monad}
- [continue? (atom.read signal)]
- (if continue?
- (do !
- [outcome (..mail! (action event stop) actor)]
- (wrap (try.to_maybe outcome)))
- (wrap #.None))))
- channel)))
diff --git a/stdlib/source/lux/control/concurrency/atom.lux b/stdlib/source/lux/control/concurrency/atom.lux
deleted file mode 100644
index e3b711785..000000000
--- a/stdlib/source/lux/control/concurrency/atom.lux
+++ /dev/null
@@ -1,102 +0,0 @@
-(.module:
- [lux #*
- ["." ffi]
- ["@" target]
- [abstract
- [monad (#+ do)]]
- [control
- ["." function]
- ["." io (#- run) ("#\." functor)]]
- [data
- ["." product]
- [collection
- ["." array]]]
- [type
- abstract]])
-
-(with_expansions [<jvm> (as_is (ffi.import: (java/util/concurrent/atomic/AtomicReference a)
- ["#::."
- (new [a])
- (get [] a)
- (compareAndSet [a a] boolean)]))]
- (for {@.old <jvm>
- @.jvm <jvm>}
- (as_is)))
-
-(with_expansions [<new> (for {@.js "js array new"
- @.python "python array new"
- @.lua "lua array new"
- @.ruby "ruby array new"
- @.php "php array new"
- @.scheme "scheme array new"}
- (as_is))
- <write> (for {@.js "js array write"
- @.python "python array write"
- @.lua "lua array write"
- @.ruby "ruby array write"
- @.php "php array write"
- @.scheme "scheme array write"}
- (as_is))
-
- <read> (for {@.js "js array read"
- @.python "python array read"
- @.lua "lua array read"
- @.ruby "ruby array read"
- @.php "php array read"
- @.scheme "scheme array read"}
- (as_is))]
- (abstract: #export (Atom a)
- (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference a)]
- (for {@.old <jvm>
- @.jvm <jvm>}
- (array.Array a)))
-
- {#.doc "Atomic references that are safe to mutate concurrently."}
-
- (def: #export (atom value)
- (All [a] (-> a (Atom a)))
- (:abstraction (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::new value)]
- (for {@.old <jvm>
- @.jvm <jvm>}
- (<write> 0 value (<new> 1))))))
-
- (def: #export (read atom)
- (All [a] (-> (Atom a) (IO a)))
- (io (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::get (:representation atom))]
- (for {@.old <jvm>
- @.jvm <jvm>}
- (<read> 0 (:representation atom))))))
-
- (def: #export (compare_and_swap current new atom)
- {#.doc (doc "Only mutates an atom if you can present its current value."
- "That guarantees that atom was not updated since you last read from it.")}
- (All [a] (-> a a (Atom a) (IO Bit)))
- (io (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::compareAndSet current new (:representation atom))]
- (for {@.old <jvm>
- @.jvm <jvm>}
- (let [old (<read> 0 (:representation atom))]
- (if (is? old current)
- (exec (<write> 0 new (:representation atom))
- true)
- false))))))
- ))
-
-(def: #export (update f atom)
- {#.doc (doc "Updates an atom by applying a function to its current value."
- "If it fails to update it (because some other process wrote to it first), it will retry until it succeeds."
- "The retries will be done with the new values of the atom, as they show up.")}
- (All [a] (-> (-> a a) (Atom a) (IO [a a])))
- (loop [_ []]
- (do io.monad
- [old (read atom)
- #let [new (f old)]
- swapped? (..compare_and_swap old new atom)]
- (if swapped?
- (wrap [old new])
- (recur [])))))
-
-(def: #export (write value atom)
- (All [a] (-> a (Atom a) (IO a)))
- (|> atom
- (..update (function.constant value))
- (io\map product.left)))
diff --git a/stdlib/source/lux/control/concurrency/frp.lux b/stdlib/source/lux/control/concurrency/frp.lux
deleted file mode 100644
index 452c153f1..000000000
--- a/stdlib/source/lux/control/concurrency/frp.lux
+++ /dev/null
@@ -1,295 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [predicate (#+ Predicate)]
- [equivalence (#+ Equivalence)]
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- ["." monad (#+ Monad do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." io (#+ IO io)]]
- [data
- ["." maybe ("#\." functor)]]
- [type (#+ :share)
- abstract]]
- [//
- ["." atom (#+ Atom)]
- ["." promise (#+ Promise) ("#\." functor)]])
-
-(type: #export (Channel a)
- {#.doc "An asynchronous channel to distribute values."}
- (Promise (Maybe [a (Channel a)])))
-
-(exception: #export channel_is_already_closed)
-
-(interface: #export (Sink a)
- (: (IO (Try Any))
- close)
- (: (-> a (IO (Try Any)))
- feed))
-
-(def: (sink resolve)
- (All [a]
- (-> (promise.Resolver (Maybe [a (Channel a)]))
- (Sink a)))
- (let [sink (atom.atom resolve)]
- (implementation
- (def: close
- (loop [_ []]
- (do {! io.monad}
- [current (atom.read sink)
- stopped? (current #.None)]
- (if stopped?
- ## I closed the sink.
- (wrap (exception.return []))
- ## Someone else interacted with the sink.
- (do !
- [latter (atom.read sink)]
- (if (is? current latter)
- ## Someone else closed the sink.
- (wrap (exception.throw ..channel_is_already_closed []))
- ## Someone else fed the sink while I was closing it.
- (recur [])))))))
-
- (def: (feed value)
- (loop [_ []]
- (do {! io.monad}
- [current (atom.read sink)
- #let [[next resolve_next] (:share [a]
- (promise.Resolver (Maybe [a (Channel a)]))
- current
-
- [(Promise (Maybe [a (Channel a)]))
- (promise.Resolver (Maybe [a (Channel a)]))]
- (promise.promise []))]
- fed? (current (#.Some [value next]))]
- (if fed?
- ## I fed the sink.
- (do !
- [_ (atom.compare_and_swap current resolve_next sink)]
- (wrap (exception.return [])))
- ## Someone else interacted with the sink.
- (do !
- [latter (atom.read sink)]
- (if (is? current latter)
- ## Someone else closed the sink while I was feeding it.
- (wrap (exception.throw ..channel_is_already_closed []))
- ## Someone else fed the sink.
- (recur []))))))))))
-
-(def: #export (channel _)
- (All [a] (-> Any [(Channel a) (Sink a)]))
- (let [[promise resolve] (promise.promise [])]
- [promise (..sink resolve)]))
-
-(implementation: #export functor
- (Functor Channel)
-
- (def: (map f)
- (promise\map
- (maybe\map
- (function (_ [head tail])
- [(f head) (map f tail)])))))
-
-(implementation: #export apply
- (Apply Channel)
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (do promise.monad
- [cons_f ff
- cons_a fa]
- (case [cons_f cons_a]
- [(#.Some [head_f tail_f]) (#.Some [head_a tail_a])]
- (wrap (#.Some [(head_f head_a) (apply tail_f tail_a)]))
-
- _
- (wrap #.None)))))
-
-(def: empty
- Channel
- (promise.resolved #.None))
-
-(implementation: #export monad
- (Monad Channel)
-
- (def: &functor ..functor)
-
- (def: (wrap a)
- (promise.resolved (#.Some [a ..empty])))
-
- (def: (join mma)
- (let [[output sink] (channel [])]
- (exec (: (Promise Any)
- (loop [mma mma]
- (do {! promise.monad}
- [?mma mma]
- (case ?mma
- (#.Some [ma mma'])
- (do !
- [_ (loop [ma ma]
- (do !
- [?ma ma]
- (case ?ma
- (#.Some [a ma'])
- (exec (io.run (\ sink feed a))
- (recur ma'))
-
- #.None
- (wrap []))))]
- (recur mma'))
-
- #.None
- (wrap (: Any (io.run (\ sink close))))))))
- output))))
-
-(type: #export (Subscriber a)
- (-> a (IO (Maybe Any))))
-
-(def: #export (subscribe subscriber channel)
- (All [a] (-> (Subscriber a) (Channel a) (IO Any)))
- (io (exec (: (Promise Any)
- (loop [channel channel]
- (do promise.monad
- [cons channel]
- (case cons
- (#.Some [head tail])
- (case (io.run (subscriber head))
- (#.Some _)
- (recur tail)
-
- #.None
- (wrap []))
-
- #.None
- (wrap [])))))
- [])))
-
-(def: #export (filter pass? channel)
- (All [a] (-> (Predicate a) (Channel a) (Channel a)))
- (do promise.monad
- [cons channel]
- (case cons
- (#.Some [head tail])
- (let [tail' (filter pass? tail)]
- (if (pass? head)
- (wrap (#.Some [head tail']))
- tail'))
-
- #.None
- (wrap #.None))))
-
-(def: #export (from_promise promise)
- (All [a] (-> (Promise a) (Channel a)))
- (promise\map (function (_ value)
- (#.Some [value ..empty]))
- promise))
-
-(def: #export (fold f init channel)
- {#.doc "Asynchronous fold over channels."}
- (All [a b]
- (-> (-> b a (Promise a)) a (Channel b)
- (Promise a)))
- (do {! promise.monad}
- [cons channel]
- (case cons
- #.None
- (wrap init)
-
- (#.Some [head tail])
- (do !
- [init' (f head init)]
- (fold f init' tail)))))
-
-(def: #export (folds f init channel)
- {#.doc "A channel of folds."}
- (All [a b]
- (-> (-> b a (Promise a)) a (Channel b)
- (Channel a)))
- (do {! promise.monad}
- [cons channel]
- (case cons
- #.None
- (wrap (#.Some [init (wrap #.None)]))
-
- (#.Some [head tail])
- (do !
- [init' (f head init)]
- (wrap (#.Some [init (folds f init' tail)]))))))
-
-(def: #export (poll milli_seconds action)
- (All [a]
- (-> Nat (IO a) [(Channel a) (Sink a)]))
- (let [[output sink] (channel [])]
- (exec (io.run (loop [_ []]
- (do io.monad
- [value action
- _ (\ sink feed value)]
- (promise.await recur (promise.wait milli_seconds)))))
- [output sink])))
-
-(def: #export (periodic milli_seconds)
- (-> Nat [(Channel Any) (Sink Any)])
- (..poll milli_seconds (io [])))
-
-(def: #export (iterate f init)
- (All [s o] (-> (-> s (Promise (Maybe [s o]))) s (Channel o)))
- (do promise.monad
- [?next (f init)]
- (case ?next
- (#.Some [state output])
- (wrap (#.Some [output (iterate f state)]))
-
- #.None
- (wrap #.None))))
-
-(def: (distinct' equivalence previous channel)
- (All [a] (-> (Equivalence a) a (Channel a) (Channel a)))
- (do promise.monad
- [cons channel]
- (case cons
- (#.Some [head tail])
- (if (\ equivalence = previous head)
- (distinct' equivalence previous tail)
- (wrap (#.Some [head (distinct' equivalence head tail)])))
-
- #.None
- (wrap #.None))))
-
-(def: #export (distinct equivalence channel)
- (All [a] (-> (Equivalence a) (Channel a) (Channel a)))
- (do promise.monad
- [cons channel]
- (case cons
- (#.Some [head tail])
- (wrap (#.Some [head (distinct' equivalence head tail)]))
-
- #.None
- (wrap #.None))))
-
-(def: #export (consume channel)
- {#.doc "Reads the entirety of a channel's content and returns it as a list."}
- (All [a] (-> (Channel a) (Promise (List a))))
- (do {! promise.monad}
- [cons channel]
- (case cons
- (#.Some [head tail])
- (\ ! map (|>> (#.Cons head))
- (consume tail))
-
- #.None
- (wrap #.Nil))))
-
-(def: #export (sequential milli_seconds values)
- (All [a] (-> Nat (List a) (Channel a)))
- (case values
- #.Nil
- ..empty
-
- (#.Cons head tail)
- (promise.resolved (#.Some [head (do promise.monad
- [_ (promise.wait milli_seconds)]
- (sequential milli_seconds tail))]))))
diff --git a/stdlib/source/lux/control/concurrency/promise.lux b/stdlib/source/lux/control/concurrency/promise.lux
deleted file mode 100644
index 8e0acf8b9..000000000
--- a/stdlib/source/lux/control/concurrency/promise.lux
+++ /dev/null
@@ -1,199 +0,0 @@
-(.module:
- [lux (#- and or)
- [abstract
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- ["." monad (#+ Monad do)]]
- [control
- [pipe (#+ case>)]
- ["." function]
- ["." io (#+ IO io)]]
- [data
- ["." product]]
- [type (#+ :share)
- abstract]]
- [//
- ["." thread]
- ["." atom (#+ Atom atom)]])
-
-(abstract: #export (Promise a)
- (Atom [(Maybe a) (List (-> a (IO Any)))])
-
- {#.doc "Represents values produced by asynchronous computations (unlike IO, which is synchronous)."}
-
- (type: #export (Resolver a)
- (-> a (IO Bit)))
-
- (def: (resolver promise)
- {#.doc "Sets an promise's value if it has not been done yet."}
- (All [a] (-> (Promise a) (Resolver a)))
- (function (resolve value)
- (let [promise (:representation promise)]
- (do {! io.monad}
- [(^@ old [_value _observers]) (atom.read promise)]
- (case _value
- (#.Some _)
- (wrap #0)
-
- #.None
- (do !
- [#let [new [(#.Some value) #.None]]
- succeeded? (atom.compare_and_swap old new promise)]
- (if succeeded?
- (do !
- [_ (monad.map ! (function (_ f) (f value))
- _observers)]
- (wrap #1))
- (resolve value))))))))
-
- (def: #export (resolved value)
- (All [a] (-> a (Promise a)))
- (:abstraction (atom [(#.Some value) (list)])))
-
- (def: #export (promise _)
- (All [a] (-> Any [(Promise a) (Resolver a)]))
- (let [promise (:abstraction (atom [#.None (list)]))]
- [promise (..resolver promise)]))
-
- (def: #export poll
- {#.doc "Polls a promise's value."}
- (All [a] (-> (Promise a) (IO (Maybe a))))
- (|>> :representation
- atom.read
- (\ io.functor map product.left)))
-
- (def: #export (await f promise)
- (All [a] (-> (-> a (IO Any)) (Promise a) (IO Any)))
- (do {! io.monad}
- [#let [promise (:representation promise)]
- (^@ old [_value _observers]) (atom.read promise)]
- (case _value
- (#.Some value)
- (f value)
-
- #.None
- (let [new [_value (#.Cons f _observers)]]
- (do !
- [swapped? (atom.compare_and_swap old new promise)]
- (if swapped?
- (wrap [])
- (await f (:abstraction promise))))))))
- )
-
-(def: #export resolved?
- {#.doc "Checks whether a promise's value has already been resolved."}
- (All [a] (-> (Promise a) (IO Bit)))
- (|>> ..poll
- (\ io.functor map
- (|>> (case> #.None
- #0
-
- (#.Some _)
- #1)))))
-
-(implementation: #export functor
- (Functor Promise)
-
- (def: (map f fa)
- (let [[fb resolve] (..promise [])]
- (exec (io.run (..await (|>> f resolve) fa))
- fb))))
-
-(implementation: #export apply
- (Apply Promise)
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (let [[fb resolve] (..promise [])]
- (exec (io.run (..await (function (_ f)
- (..await (|>> f resolve) fa))
- ff))
- fb))))
-
-(implementation: #export monad
- (Monad Promise)
-
- (def: &functor ..functor)
-
- (def: wrap ..resolved)
-
- (def: (join mma)
- (let [[ma resolve] (promise [])]
- (exec (io.run (..await (..await resolve) mma))
- ma))))
-
-(def: #export (and left right)
- {#.doc "Sequencing combinator."}
- (All [a b] (-> (Promise a) (Promise b) (Promise [a b])))
- (let [[read! write!] (:share [a b]
- [(Promise a) (Promise b)]
- [left right]
-
- [(Promise [a b])
- (Resolver [a b])]
- (..promise []))
- _ (io.run (..await (function (_ left)
- (..await (function (_ right)
- (write! [left right]))
- right))
- left))]
- read!))
-
-(def: #export (or left right)
- {#.doc "Heterogeneous alternative combinator."}
- (All [a b] (-> (Promise a) (Promise b) (Promise (| a b))))
- (let [[a|b resolve] (..promise [])]
- (with_expansions
- [<sides> (template [<promise> <tag>]
- [(io.run (await (|>> <tag> resolve) <promise>))]
-
- [left #.Left]
- [right #.Right]
- )]
- (exec <sides>
- a|b))))
-
-(def: #export (either left right)
- {#.doc "Homogeneous alternative combinator."}
- (All [a] (-> (Promise a) (Promise a) (Promise a)))
- (let [[left||right resolve] (..promise [])]
- (`` (exec (~~ (template [<promise>]
- [(io.run (await resolve <promise>))]
-
- [left]
- [right]))
- left||right))))
-
-(def: #export (schedule millis_delay computation)
- {#.doc (doc "Runs an I/O computation on its own thread (after a specified delay)."
- "Returns a Promise that will eventually host its result.")}
- (All [a] (-> Nat (IO a) (Promise a)))
- (let [[!out resolve] (..promise [])]
- (exec (|> (do io.monad
- [value computation]
- (resolve value))
- (thread.schedule millis_delay)
- io.run)
- !out)))
-
-(def: #export future
- {#.doc (doc "Runs an I/O computation on its own thread."
- "Returns a Promise that will eventually host its result.")}
- (All [a] (-> (IO a) (Promise a)))
- (..schedule 0))
-
-(def: #export (delay time_millis value)
- {#.doc "Delivers a value after a certain period has passed."}
- (All [a] (-> Nat a (Promise a)))
- (..schedule time_millis (io value)))
-
-(def: #export (wait time_millis)
- {#.doc "Returns a promise that will be resolved after the specified amount of milliseconds."}
- (-> Nat (Promise Any))
- (..delay time_millis []))
-
-(def: #export (time_out time_millis promise)
- {#.doc "Wait for a promise to be resolved within the specified amount of milliseconds."}
- (All [a] (-> Nat (Promise a) (Promise (Maybe a))))
- (..or (wait time_millis) promise))
diff --git a/stdlib/source/lux/control/concurrency/semaphore.lux b/stdlib/source/lux/control/concurrency/semaphore.lux
deleted file mode 100644
index 0e8fa2b94..000000000
--- a/stdlib/source/lux/control/concurrency/semaphore.lux
+++ /dev/null
@@ -1,173 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- [pipe (#+ if>)]
- ["." io (#+ IO)]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- [text
- ["%" format (#+ format)]]
- [collection
- ["." queue (#+ Queue)]]]
- [math
- [number
- ["n" nat]
- ["i" int]]]
- [type
- abstract
- ["." refinement]]]
- [//
- ["." atom (#+ Atom)]
- ["." promise (#+ Promise Resolver)]])
-
-(type: State
- {#max_positions Nat
- #open_positions Int
- #waiting_list (Queue (Resolver Any))})
-
-(abstract: #export Semaphore
- (Atom State)
-
- {#.doc "A tool for controlling access to resources by multiple concurrent processes."}
-
- (def: most_positions_possible
- (.nat (\ i.interval top)))
-
- (def: #export (semaphore initial_open_positions)
- (-> Nat Semaphore)
- (let [max_positions (n.min initial_open_positions
- ..most_positions_possible)]
- (:abstraction (atom.atom {#max_positions max_positions
- #open_positions (.int max_positions)
- #waiting_list queue.empty}))))
-
- (def: #export (wait semaphore)
- (Ex [k] (-> Semaphore (Promise Any)))
- (let [semaphore (:representation semaphore)
- [signal sink] (: [(Promise Any) (Resolver Any)]
- (promise.promise []))]
- (exec (io.run
- (with_expansions [<had_open_position?> (as_is (get@ #open_positions) (i.> -1))]
- (do io.monad
- [[_ state'] (atom.update (|>> (update@ #open_positions dec)
- (if> [<had_open_position?>]
- []
- [(update@ #waiting_list (queue.push sink))]))
- semaphore)]
- (with_expansions [<go_ahead> (sink [])
- <get_in_line> (wrap false)]
- (if (|> state' <had_open_position?>)
- <go_ahead>
- <get_in_line>)))))
- signal)))
-
- (exception: #export (semaphore_is_maxed_out {max_positions Nat})
- (exception.report
- ["Max Positions" (%.nat max_positions)]))
-
- (def: #export (signal semaphore)
- (Ex [k] (-> Semaphore (Promise (Try Int))))
- (let [semaphore (:representation semaphore)]
- (promise.future
- (do {! io.monad}
- [[pre post] (atom.update (function (_ state)
- (if (i.= (.int (get@ #max_positions state))
- (get@ #open_positions state))
- state
- (|> state
- (update@ #open_positions inc)
- (update@ #waiting_list queue.pop))))
- semaphore)]
- (if (is? pre post)
- (wrap (exception.throw ..semaphore_is_maxed_out [(get@ #max_positions pre)]))
- (do !
- [_ (case (queue.peek (get@ #waiting_list pre))
- #.None
- (wrap true)
-
- (#.Some sink)
- (sink []))]
- (wrap (#try.Success (get@ #open_positions post)))))))))
- )
-
-(abstract: #export Mutex
- Semaphore
-
- {#.doc "A mutual-exclusion lock that can only be acquired by one process at a time."}
-
- (def: #export (mutex _)
- (-> Any Mutex)
- (:abstraction (semaphore 1)))
-
- (def: acquire
- (-> Mutex (Promise Any))
- (|>> :representation ..wait))
-
- (def: release
- (-> Mutex (Promise Any))
- (|>> :representation ..signal))
-
- (def: #export (synchronize mutex procedure)
- (All [a] (-> Mutex (IO (Promise a)) (Promise a)))
- (do promise.monad
- [_ (..acquire mutex)
- output (io.run procedure)
- _ (..release mutex)]
- (wrap output)))
- )
-
-(def: #export limit
- (refinement.refinement (n.> 0)))
-
-(type: #export Limit
- (:~ (refinement.type limit)))
-
-(abstract: #export Barrier
- {#limit Limit
- #count (Atom Nat)
- #start_turnstile Semaphore
- #end_turnstile Semaphore}
-
- {#.doc "A barrier that blocks all processes from proceeding until a given number of processes are parked at the barrier."}
-
- (def: #export (barrier limit)
- (-> Limit Barrier)
- (:abstraction {#limit limit
- #count (atom.atom 0)
- #start_turnstile (..semaphore 0)
- #end_turnstile (..semaphore 0)}))
-
- (def: (un_block times turnstile)
- (-> Nat Semaphore (Promise Any))
- (loop [step 0]
- (if (n.< times step)
- (do promise.monad
- [outcome (..signal turnstile)]
- (recur (inc step)))
- (\ promise.monad wrap []))))
-
- (template [<phase> <update> <goal> <turnstile>]
- [(def: (<phase> (^:representation barrier))
- (-> Barrier (Promise Any))
- (do promise.monad
- [#let [limit (refinement.un_refine (get@ #limit barrier))
- goal <goal>
- [_ count] (io.run (atom.update <update> (get@ #count barrier)))
- reached? (n.= goal count)]]
- (if reached?
- (..un_block (dec limit) (get@ <turnstile> barrier))
- (..wait (get@ <turnstile> barrier)))))]
-
- [start inc limit #start_turnstile]
- [end dec 0 #end_turnstile]
- )
-
- (def: #export (block barrier)
- (-> Barrier (Promise Any))
- (do promise.monad
- [_ (..start barrier)]
- (..end barrier)))
- )
diff --git a/stdlib/source/lux/control/concurrency/stm.lux b/stdlib/source/lux/control/concurrency/stm.lux
deleted file mode 100644
index d375059a4..000000000
--- a/stdlib/source/lux/control/concurrency/stm.lux
+++ /dev/null
@@ -1,273 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- ["." monad (#+ Monad do)]]
- [control
- ["." io (#+ IO io)]
- ["." try]]
- [data
- ["." product]
- ["." maybe]
- [collection
- ["." list]]]
- [type
- abstract]]
- [//
- ["." atom (#+ Atom atom)]
- ["." promise (#+ Promise Resolver)]
- ["." frp (#+ Channel Sink)]])
-
-(type: (Observer a)
- (-> a (IO Any)))
-
-(abstract: #export (Var a)
- (Atom [a (List (Sink a))])
-
- {#.doc "A mutable cell containing a value, and observers that will be alerted of any change to it."}
-
- (def: #export (var value)
- {#.doc "Creates a new STM var, with a default value."}
- (All [a] (-> a (Var a)))
- (:abstraction (atom.atom [value (list)])))
-
- (def: read!
- (All [a] (-> (Var a) a))
- (|>> :representation atom.read io.run product.left))
-
- (def: (un_follow sink var)
- (All [a] (-> (Sink a) (Var a) (IO Any)))
- (do io.monad
- [_ (atom.update (function (_ [value observers])
- [value (list.filter (|>> (is? sink) not) observers)])
- (:representation var))]
- (wrap [])))
-
- (def: (write! new_value var)
- (All [a] (-> a (Var a) (IO Any)))
- (do {! io.monad}
- [#let [var' (:representation var)]
- (^@ old [old_value observers]) (atom.read var')
- succeeded? (atom.compare_and_swap old [new_value observers] var')]
- (if succeeded?
- (do !
- [_ (monad.map ! (function (_ sink)
- (do !
- [result (\ sink feed new_value)]
- (case result
- (#try.Success _)
- (wrap [])
-
- (#try.Failure _)
- (un_follow sink var))))
- observers)]
- (wrap []))
- (write! new_value var))))
-
- (def: #export (follow target)
- {#.doc "Creates a channel that will receive all changes to the value of the given var."}
- (All [a] (-> (Var a) (IO [(Channel a) (Sink a)])))
- (do io.monad
- [#let [[channel sink] (frp.channel [])]
- _ (atom.update (function (_ [value observers])
- [value (#.Cons sink observers)])
- (:representation target))]
- (wrap [channel sink])))
- )
-
-(type: (Tx_Frame a)
- {#var (Var a)
- #original a
- #current a})
-
-(type: Tx
- (List (Ex [a] (Tx_Frame a))))
-
-(type: #export (STM a)
- {#.doc "A computation which updates a transaction and produces a value."}
- (-> Tx [Tx a]))
-
-(def: (find_var_value var tx)
- (All [a] (-> (Var a) Tx (Maybe a)))
- (|> tx
- (list.find (function (_ [_var _original _current])
- (is? (:as (Var Any) var)
- (:as (Var Any) _var))))
- (\ maybe.monad map (function (_ [_var _original _current])
- _current))
- (:assume)
- ))
-
-(def: #export (read var)
- (All [a] (-> (Var a) (STM a)))
- (function (_ tx)
- (case (find_var_value var tx)
- (#.Some value)
- [tx value]
-
- #.None
- (let [value (..read! var)]
- [(#.Cons [var value value] tx)
- 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 (is? (:as (Var Any) var)
- (:as (Var Any) _var))
- (#.Cons {#var (:as (Var Any) _var)
- #original (:as Any _original)
- #current (:as Any value)}
- tx')
- (#.Cons {#var _var
- #original _original
- #current _current}
- (update_tx_value var value tx')))))
-
-(def: #export (write value var)
- {#.doc "Writes value to var."}
- (All [a] (-> a (Var a) (STM Any)))
- (function (_ tx)
- (case (find_var_value var tx)
- (#.Some _)
- [(update_tx_value var value tx)
- []]
-
- #.None
- [(#.Cons [var (..read! var) value] tx)
- []])))
-
-(implementation: #export functor
- (Functor STM)
-
- (def: (map f fa)
- (function (_ tx)
- (let [[tx' a] (fa tx)]
- [tx' (f a)]))))
-
-(implementation: #export apply
- (Apply STM)
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (function (_ tx)
- (let [[tx' f] (ff tx)
- [tx'' a] (fa tx')]
- [tx'' (f a)]))))
-
-(implementation: #export monad
- (Monad STM)
-
- (def: &functor ..functor)
-
- (def: (wrap a)
- (function (_ tx)
- [tx a]))
-
- (def: (join mma)
- (function (_ tx)
- (let [[tx' ma] (mma tx)]
- (ma tx')))))
-
-(def: #export (update f var)
- {#.doc "Will update a Var's value, and return a tuple with the old and the new values."}
- (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 Bit)
- (list.every? (function (_ [_var _original _current])
- (is? _original (..read! _var)))
- tx))
-
-(def: (commit_var! [_var _original _current])
- (-> (Ex [a] (Tx_Frame a)) (IO Any))
- (if (is? _original _current)
- (io [])
- (..write! _current _var)))
-
-(def: fresh_tx Tx (list))
-
-(type: (Commit a)
- [(STM a)
- (Promise a)
- (Resolver a)])
-
-(def: pending_commits
- (Atom (Rec Commits
- [(Promise [(Ex [a] (Commit a)) Commits])
- (Resolver [(Ex [a] (Commit a)) Commits])]))
- (atom (promise.promise [])))
-
-(def: commit_processor_flag
- (Atom Bit)
- (atom #0))
-
-(def: (issue_commit commit)
- (All [a] (-> (Commit a) (IO Any)))
- (let [entry [commit (promise.promise [])]]
- (do {! io.monad}
- [|commits|&resolve (atom.read pending_commits)]
- (loop [[|commits| resolve] |commits|&resolve]
- (do !
- [|commits| (promise.poll |commits|)]
- (case |commits|
- #.None
- (do io.monad
- [resolved? (resolve entry)]
- (if resolved?
- (atom.write (product.right entry) pending_commits)
- (recur |commits|&resolve)))
-
- (#.Some [head tail])
- (recur tail)))))))
-
-(def: (process_commit commit)
- (All [a] (-> (Commit a) (IO Any)))
- (let [[stm_proc output resolve] commit
- [finished_tx value] (stm_proc fresh_tx)]
- (if (can_commit? finished_tx)
- (do {! io.monad}
- [_ (monad.map ! commit_var! finished_tx)]
- (resolve value))
- (issue_commit commit))))
-
-(def: init_processor!
- (IO Any)
- (do {! io.monad}
- [flag (atom.read commit_processor_flag)]
- (if flag
- (wrap [])
- (do !
- [was_first? (atom.compare_and_swap flag #1 commit_processor_flag)]
- (if was_first?
- (do !
- [[promise resolve] (atom.read pending_commits)]
- (promise.await (function (recur [head [tail _resolve]])
- (do !
- [_ (process_commit head)]
- (promise.await recur tail)))
- promise))
- (wrap [])))
- )))
-
-(def: #export (commit stm_proc)
- {#.doc (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 resolver] (promise.promise [])]
- (exec (io.run (do io.monad
- [_ init_processor!]
- (issue_commit [stm_proc output resolver])))
- output)))
diff --git a/stdlib/source/lux/control/concurrency/thread.lux b/stdlib/source/lux/control/concurrency/thread.lux
deleted file mode 100644
index d6dc71c37..000000000
--- a/stdlib/source/lux/control/concurrency/thread.lux
+++ /dev/null
@@ -1,169 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- ["." ffi]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try]
- ["." exception (#+ exception:)]
- ["." io (#+ IO io)]]
- [data
- ["." text]
- [collection
- ["." list]]]
- [math
- [number
- ["n" nat]
- ["f" frac]]]
- [time
- ["." instant]]]
- [//
- ["." atom (#+ Atom)]])
-
-(with_expansions [<jvm> (as_is (ffi.import: java/lang/Object)
-
- (ffi.import: java/lang/Runtime
- ["#::."
- (#static getRuntime [] java/lang/Runtime)
- (availableProcessors [] int)])
-
- (ffi.import: java/lang/Runnable)
-
- (ffi.import: java/util/concurrent/TimeUnit
- ["#::."
- (#enum MILLISECONDS)])
-
- (ffi.import: java/util/concurrent/Executor
- ["#::."
- (execute [java/lang/Runnable] #io void)])
-
- (ffi.import: (java/util/concurrent/ScheduledFuture a))
-
- (ffi.import: java/util/concurrent/ScheduledThreadPoolExecutor
- ["#::."
- (new [int])
- (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object))]))]
- (for {@.old (as_is <jvm>)
- @.jvm (as_is <jvm>)
-
- @.js
- (as_is (ffi.import: (setTimeout [ffi.Function ffi.Number] #io Any)))
-
- @.python
- (ffi.import: threading/Timer
- ["#::."
- (new [ffi.Float ffi.Function])
- (start [] #io #? Any)])}
-
- ## Default
- (type: Thread
- {#creation Nat
- #delay Nat
- #action (IO Any)})
- ))
-
-(def: #export parallelism
- Nat
- (with_expansions [<jvm> (|> (java/lang/Runtime::getRuntime)
- (java/lang/Runtime::availableProcessors)
- .nat)]
- (for {@.old <jvm>
- @.jvm <jvm>}
- ## Default
- 1)))
-
-(with_expansions [<jvm> (as_is (def: runner
- java/util/concurrent/ScheduledThreadPoolExecutor
- (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))))]
- (for {@.old <jvm>
- @.jvm <jvm>
- @.js (as_is)
- @.python (as_is)}
-
- ## Default
- (def: runner
- (Atom (List Thread))
- (atom.atom (list)))))
-
-(def: (execute! action)
- (-> (IO Any) Any)
- (case (try (io.run action))
- (#try.Failure error)
- (exec
- ("lux io log" ($_ "lux text concat"
- "ERROR DURING THREAD EXECUTION:" text.new_line
- error))
- [])
-
- (#try.Success _)
- []))
-
-(def: #export (schedule milli_seconds action)
- (-> Nat (IO Any) (IO Any))
- (with_expansions [<jvm> (as_is (let [runnable (ffi.object [] [java/lang/Runnable]
- []
- (java/lang/Runnable [] (run self) void
- (..execute! action)))]
- (case milli_seconds
- 0 (java/util/concurrent/Executor::execute runnable runner)
- _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule runnable (.int milli_seconds) java/util/concurrent/TimeUnit::MILLISECONDS
- runner))))]
- (for {@.old <jvm>
- @.jvm <jvm>
-
- @.js
- (..setTimeout [(ffi.closure [] (..execute! action))
- (n.frac milli_seconds)])
-
- @.python
- (do io.monad
- [_ (|> (ffi.lambda [] (..execute! action))
- [(|> milli_seconds n.frac (f./ +1,000.0))]
- threading/Timer::new
- (threading/Timer::start []))]
- (wrap []))}
-
- ## Default
- (do {! io.monad}
- [now (\ ! map (|>> instant.to_millis .nat) instant.now)
- _ (atom.update (|>> (#.Cons {#creation now
- #delay milli_seconds
- #action action}))
- ..runner)]
- (wrap [])))))
-
-(for {@.old (as_is)
- @.jvm (as_is)
- @.js (as_is)
- @.python (as_is)}
-
- ## Default
- (as_is (exception: #export cannot_continue_running_threads)
-
- (def: #export run!
- (IO Any)
- (loop [_ []]
- (do {! io.monad}
- [threads (atom.read ..runner)]
- (case threads
- ## And... we're done!
- #.Nil
- (wrap [])
-
- _
- (do !
- [now (\ ! map (|>> instant.to_millis .nat) instant.now)
- #let [[ready pending] (list.partition (function (_ thread)
- (|> (get@ #creation thread)
- (n.+ (get@ #delay thread))
- (n.<= now)))
- threads)]
- swapped? (atom.compare_and_swap threads pending ..runner)]
- (if swapped?
- (do !
- [_ (monad.map ! (|>> (get@ #action) ..execute! io.io) ready)]
- (recur []))
- (error! (exception.construct ..cannot_continue_running_threads []))))
- ))))
- ))
diff --git a/stdlib/source/lux/control/continuation.lux b/stdlib/source/lux/control/continuation.lux
deleted file mode 100644
index 03a9607ce..000000000
--- a/stdlib/source/lux/control/continuation.lux
+++ /dev/null
@@ -1,99 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- [monad (#+ Monad do)]]
- [control
- ["." function]
- [parser
- ["s" code]]]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]]])
-
-(type: #export (Cont i o)
- {#.doc "Continuations."}
- (-> (-> i o) o))
-
-(def: #export (continue next cont)
- {#.doc "Continues a continuation thunk."}
- (All [i o] (-> (-> i o) (Cont i o) o))
- (cont next))
-
-(def: #export (run cont)
- {#.doc "Forces a continuation thunk to be evaluated."}
- (All [a] (-> (Cont a a) a))
- (cont function.identity))
-
-(def: #export (call/cc f)
- {#.doc "Call with current continuation."}
- (All [a b z]
- (-> (-> (-> a (Cont b z))
- (Cont a z))
- (Cont a z)))
- (function (_ k)
- (f (function (_ a) (function (_ _) (k a)))
- k)))
-
-(syntax: #export (pending expr)
- {#.doc (doc "Turns any expression into a function that is pending a continuation."
- (pending (some_function some_input)))}
- (with_gensyms [g!_ g!k]
- (wrap (list (` (.function ((~ g!_) (~ g!k)) ((~ g!k) (~ expr))))))))
-
-(def: #export (reset scope)
- (All [i o] (-> (Cont i i) (Cont i o)))
- (function (_ k)
- (k (run scope))))
-
-(def: #export (shift f)
- (All [a]
- (-> (-> (-> a (Cont a a))
- (Cont a a))
- (Cont a a)))
- (function (_ oc)
- (f (function (_ a) (function (_ ic) (ic (oc a))))
- function.identity)))
-
-(implementation: #export functor
- (All [o] (Functor (All [i] (Cont i o))))
-
- (def: (map f fv)
- (function (_ k) (fv (function.compose k f)))))
-
-(implementation: #export apply
- (All [o] (Apply (All [i] (Cont i o))))
-
- (def: &functor ..functor)
-
- (def: (apply ff fv)
- (function (_ k)
- (|> (k (f v))
- (function (_ v)) fv
- (function (_ f)) ff))))
-
-(implementation: #export monad
- (All [o] (Monad (All [i] (Cont i o))))
-
- (def: &functor ..functor)
-
- (def: (wrap value)
- (function (_ k) (k value)))
-
- (def: (join ffa)
- (function (_ k)
- (ffa (continue k)))))
-
-(def: #export (portal init)
- (All [i o z]
- (-> i
- (Cont [(-> i (Cont o z))
- i]
- z)))
- (call/cc (function (_ k)
- (do ..monad
- [#let [nexus (function (nexus val)
- (k [nexus val]))]
- _ (k [nexus init])]
- (wrap (undefined))))))
diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux
deleted file mode 100644
index 0f5f62aa3..000000000
--- a/stdlib/source/lux/control/exception.lux
+++ /dev/null
@@ -1,183 +0,0 @@
-(.module: {#.doc "Exception-handling functionality."}
- [lux #*
- ["." macro]
- ["." meta]
- [abstract
- [monad (#+ do)]]
- [control
- ["p" parser
- ["s" code (#+ Parser)]]]
- [data
- ["." maybe]
- ["." product]
- ["." text ("#\." monoid)]
- [collection
- ["." list ("#\." functor fold)]]]
- [macro
- ["." code]
- [syntax (#+ syntax:)
- ["|.|" export]
- ["|.|" input]
- ["." type #_
- ["|#_.|" variable]]]]
- [math
- [number
- ["n" nat ("#\." decimal)]]]]
- [//
- ["//" try (#+ Try)]])
-
-(type: #export (Exception a)
- {#.doc "An exception provides a way to decorate error messages."}
- {#label Text
- #constructor (-> a Text)})
-
-(def: #export (match? exception error)
- (All [e] (-> (Exception e) Text Bit))
- (text.starts_with? (get@ #label exception) error))
-
-(def: #export (catch exception then try)
- {#.doc (doc "If a particular exception is detected on a possibly-erroneous value, handle it."
- "If no exception was detected, or a different one from the one being checked, then pass along the original value.")}
- (All [e a]
- (-> (Exception e) (-> Text a) (Try a)
- (Try a)))
- (case try
- (#//.Success output)
- (#//.Success output)
-
- (#//.Failure error)
- (let [reference (get@ #label exception)]
- (if (text.starts_with? reference error)
- (#//.Success (|> error
- (text.clip' (text.size reference))
- maybe.assume
- then))
- (#//.Failure error)))))
-
-(def: #export (otherwise to_do try)
- {#.doc "If no handler could be found to catch the exception, then run a function as a last-resort measure."}
- (All [a]
- (-> (-> Text a) (Try a) a))
- (case try
- (#//.Success output)
- output
-
- (#//.Failure error)
- (to_do error)))
-
-(def: #export (return value)
- {#.doc "A way to lift normal values into the error-handling context."}
- (All [a] (-> a (Try a)))
- (#//.Success value))
-
-(def: #export (construct exception message)
- {#.doc "Constructs an exception."}
- (All [e] (-> (Exception e) e Text))
- ((get@ #..constructor exception) message))
-
-(def: #export (throw exception message)
- {#.doc "Decorate an error message with an Exception and lift it into the error-handling context."}
- (All [e a] (-> (Exception e) e (Try a)))
- (#//.Failure (..construct exception message)))
-
-(def: #export (assert exception message test)
- (All [e] (-> (Exception e) e Bit (Try Any)))
- (if test
- (#//.Success [])
- (..throw exception message)))
-
-(syntax: #export (exception: {export |export|.parser}
- {t_vars (p.default (list) (s.tuple (p.some |type_variable|.parser)))}
- {[name inputs] (p.either (p.and s.local_identifier (wrap (list)))
- (s.form (p.and s.local_identifier (p.some |input|.parser))))}
- {body (p.maybe s.any)})
- {#.doc (doc "Define a new exception type."
- "It mostly just serves as a way to tag error messages for later catching."
- ""
- "Simple case:"
- (exception: #export some_exception)
- ""
- "Complex case:"
- (exception: #export [optional type variables] (some_exception {optional Text} {arguments Int})
- optional_body))}
- (macro.with_gensyms [g!descriptor]
- (do meta.monad
- [current_module meta.current_module_name
- #let [descriptor ($_ text\compose "{" current_module "." name "}" text.new_line)
- g!self (code.local_identifier name)]]
- (wrap (list (` (def: (~+ (|export|.format export))
- (~ g!self)
- (All [(~+ (list\map |type_variable|.format t_vars))]
- (..Exception [(~+ (list\map (get@ #|input|.type) inputs))]))
- (let [(~ g!descriptor) (~ (code.text descriptor))]
- {#..label (~ g!descriptor)
- #..constructor (function ((~ g!self) [(~+ (list\map (get@ #|input|.binding) inputs))])
- ((~! text\compose) (~ g!descriptor)
- (~ (maybe.default (' "") body))))})))))
- )))
-
-(def: (report' entries)
- (-> (List [Text Text]) Text)
- (let [header_separator ": "
- largest_header_size (list\fold (function (_ [header _] max)
- (n.max (text.size header) max))
- 0
- entries)
- on_new_line (|> " "
- (list.repeat (n.+ (text.size header_separator)
- largest_header_size))
- (text.join_with "")
- (text\compose text.new_line))]
- (|> entries
- (list\map (function (_ [header message])
- (let [padding (|> " "
- (list.repeat (n.- (text.size header)
- largest_header_size))
- (text.join_with ""))]
- (|> message
- (text.replace_all text.new_line on_new_line)
- ($_ text\compose padding header header_separator)))))
- (text.join_with text.new_line))))
-
-(syntax: #export (report {entries (p.many (s.tuple (p.and s.any s.any)))})
- (wrap (list (` ((~! report') (list (~+ (|> entries
- (list\map (function (_ [header message])
- (` [(~ header) (~ message)])))))))))))
-
-(def: #export (enumerate format entries)
- (All [a]
- (-> (-> a Text) (List a) Text))
- (|> entries
- list.enumeration
- (list\map (function (_ [index entry])
- [(n\encode index) (format entry)]))
- report'))
-
-(def: separator
- (let [gap ($_ "lux text concat" text.new_line text.new_line)
- horizontal_line (|> "-" (list.repeat 64) (text.join_with ""))]
- ($_ "lux text concat"
- gap
- horizontal_line
- gap)))
-
-(def: (decorate prelude error)
- (-> Text Text Text)
- ($_ "lux text concat"
- prelude
- ..separator
- error))
-
-(def: #export (with exception message computation)
- (All [e a] (-> (Exception e) e (Try a) (Try a)))
- (case computation
- (#//.Failure error)
- (#//.Failure (case error
- ""
- (..construct exception message)
-
- _
- (..decorate (..construct exception message) error)))
-
- success
- success))
diff --git a/stdlib/source/lux/control/function.lux b/stdlib/source/lux/control/function.lux
deleted file mode 100644
index 56e54509c..000000000
--- a/stdlib/source/lux/control/function.lux
+++ /dev/null
@@ -1,46 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monoid (#+ Monoid)]]])
-
-(def: #export identity
- {#.doc (doc "Identity function."
- "Does nothing to its argument and just returns it."
- (is? (identity value)
- value))}
- (All [a] (-> a a))
- (|>>))
-
-(def: #export (compose f g)
- {#.doc (doc "Function composition."
- (= ((compose f g) "foo")
- (f (g "foo"))))}
- (All [a b c]
- (-> (-> b c) (-> a b) (-> a c)))
- (|>> g f))
-
-(def: #export (constant value)
- {#.doc (doc "Create constant functions."
- (= ((constant "foo") "bar")
- "foo"))}
- (All [o] (-> o (All [i] (-> i o))))
- (function (_ _) value))
-
-(def: #export (flip f)
- {#.doc (doc "Flips the order of the arguments of a function."
- (= ((flip f) "foo" "bar")
- (f "bar" "foo")))}
- (All [a b c]
- (-> (-> a b c) (-> b a c)))
- (function (_ x y) (f y x)))
-
-(def: #export (apply input function)
- (All [i o]
- (-> i (-> i o) o))
- (function input))
-
-(implementation: #export monoid
- (All [a] (Monoid (-> a a)))
-
- (def: identity ..identity)
- (def: compose ..compose))
diff --git a/stdlib/source/lux/control/function/contract.lux b/stdlib/source/lux/control/function/contract.lux
deleted file mode 100644
index fef0280c7..000000000
--- a/stdlib/source/lux/control/function/contract.lux
+++ /dev/null
@@ -1,51 +0,0 @@
-(.module:
- [lux #*
- [control
- ["." exception (#+ exception:)]]
- [data
- [text
- ["%" format (#+ format)]]]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number
- ["i" int]]]])
-
-(template [<name>]
- [(exception: (<name> {condition Code})
- (exception.report
- ["Condition" (%.code condition)]))]
-
- [pre_condition_failed]
- [post_condition_failed]
- )
-
-(def: (assert! message test)
- (-> Text Bit [])
- (if test
- []
- (error! message)))
-
-(syntax: #export (pre test expr)
- {#.doc (doc "Pre-conditions."
- "Given a test and an expression to run, only runs the expression if the test passes."
- "Otherwise, an error is raised."
- (pre (i.= +4 (i.+ +2 +2))
- (foo +123 +456 +789)))}
- (wrap (list (` (exec ((~! ..assert!) (~ (code.text (exception.construct ..pre_condition_failed test)))
- (~ test))
- (~ expr))))))
-
-(syntax: #export (post test expr)
- {#.doc (doc "Post-conditions."
- "Given a predicate and an expression to run, evaluates the expression and then tests the output with the predicate."
- "If the predicate returns #1, returns the value of the expression."
- "Otherwise, an error is raised."
- (post i.even?
- (i.+ +2 +2)))}
- (with_gensyms [g!output]
- (wrap (list (` (let [(~ g!output) (~ expr)]
- (exec ((~! ..assert!) (~ (code.text (exception.construct ..post_condition_failed test)))
- ((~ test) (~ g!output)))
- (~ g!output))))))))
diff --git a/stdlib/source/lux/control/function/memo.lux b/stdlib/source/lux/control/function/memo.lux
deleted file mode 100644
index 324fae7d1..000000000
--- a/stdlib/source/lux/control/function/memo.lux
+++ /dev/null
@@ -1,63 +0,0 @@
-## Inspired by;
-## "The Different Aspects of Monads and Mixins" by Bruno C. d. S. Oliveira
-
-(.module:
- [lux #*
- [abstract
- [hash (#+ Hash)]
- [monad (#+ do)]]
- [control
- ["." state (#+ State)]]
- [data
- ["." product]
- [collection
- ["." dictionary (#+ Dictionary)]]]]
- ["." // #_
- ["#" mixin (#+ Mixin Recursive)]])
-
-(def: #export memoization
- (All [i o]
- (Mixin i (State (Dictionary i o) o)))
- (function (_ delegate recur)
- (function (_ input)
- (do {! state.monad}
- [memory state.get]
- (case (dictionary.get input memory)
- (#.Some output)
- (wrap output)
-
- #.None
- (do !
- [output (delegate input)
- _ (state.update (dictionary.put input output))]
- (wrap output)))))))
-
-(type: #export (Memo i o)
- (Recursive i (State (Dictionary i o) o)))
-
-(def: #export (open memo)
- {#.doc (doc "Memoization where the memoized results can be re-used accross invocations.")}
- (All [i o]
- (:let [Memory (Dictionary i o)]
- (-> (Memo i o) (-> [Memory i] [Memory o]))))
- (let [memo (//.mixin (//.inherit ..memoization (//.from-recursive memo)))]
- (function (_ [memory input])
- (|> input memo (state.run memory)))))
-
-(def: #export (closed hash memo)
- {#.doc (doc "Memoization confined to a single invocation to the function (not counting any subsequent recursive invocations)."
- "Memoized results will be re-used during recursive invocations, but cannot be accessed after the main invocation has ended.")}
- (All [i o]
- (-> (Hash i) (Memo i o) (-> i o)))
- (let [memo (//.mixin (//.inherit ..memoization (//.from-recursive memo)))
- empty (dictionary.new hash)]
- (|>> memo (state.run empty) product.right)))
-
-(def: #export (none hash memo)
- {#.doc (doc "No memoization at all."
- "This is useful as a test control when measuring the effect of using memoization.")}
- (All [i o]
- (-> (Hash i) (Memo i o) (-> i o)))
- (let [memo (//.mixin (//.from-recursive memo))
- empty (dictionary.new hash)]
- (|>> memo (state.run empty) product.right)))
diff --git a/stdlib/source/lux/control/function/mixin.lux b/stdlib/source/lux/control/function/mixin.lux
deleted file mode 100644
index 4d1c9fcb8..000000000
--- a/stdlib/source/lux/control/function/mixin.lux
+++ /dev/null
@@ -1,63 +0,0 @@
-## Inspired by;
-## "The Different Aspects of Monads and Mixins" by Bruno C. d. S. Oliveira
-
-(.module:
- [lux #*
- [abstract
- [monoid (#+ Monoid)]
- [predicate (#+ Predicate)]
- [monad (#+ Monad do)]]])
-
-(type: #export (Mixin i o)
- (-> (-> i o) (-> i o) (-> i o)))
-
-(def: #export (mixin f)
- (All [i o] (-> (Mixin i o) (-> i o)))
- (function (mix input)
- ((f mix mix) input)))
-
-(def: #export nothing
- Mixin
- (function (_ delegate recur)
- delegate))
-
-(def: #export (inherit parent child)
- (All [i o] (-> (Mixin i o) (Mixin i o) (Mixin i o)))
- (function (_ delegate recur)
- (parent (child delegate recur) recur)))
-
-(implementation: #export monoid
- (All [i o] (Monoid (Mixin i o)))
-
- (def: identity ..nothing)
- (def: compose ..inherit))
-
-(def: #export (advice when then)
- (All [i o] (-> (Predicate i) (Mixin i o) (Mixin i o)))
- (function (_ delegate recur input)
- (if (when input)
- ((then delegate recur) input)
- (delegate input))))
-
-(def: #export (before monad action)
- (All [! i o] (-> (Monad !) (-> i (! Any)) (Mixin i (! o))))
- (function (_ delegate recur input)
- (do monad
- [_ (action input)]
- (delegate input))))
-
-(def: #export (after monad action)
- (All [! i o] (-> (Monad !) (-> i o (! Any)) (Mixin i (! o))))
- (function (_ delegate recur input)
- (do monad
- [output (delegate input)
- _ (action input output)]
- (wrap output))))
-
-(type: #export (Recursive i o)
- (-> (-> i o) (-> i o)))
-
-(def: #export (from-recursive recursive)
- (All [i o] (-> (Recursive i o) (Mixin i o)))
- (function (_ delegate recur)
- (recursive recur)))
diff --git a/stdlib/source/lux/control/function/mutual.lux b/stdlib/source/lux/control/function/mutual.lux
deleted file mode 100644
index c1960253a..000000000
--- a/stdlib/source/lux/control/function/mutual.lux
+++ /dev/null
@@ -1,157 +0,0 @@
-(.module:
- [lux (#- Definition let def:)
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["<>" parser ("#\." monad)
- ["<.>" code (#+ Parser)]]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]
- [dictionary
- ["." plist (#+ PList)]]]]
- ["." macro
- ["." local]
- ["." code]
- [syntax (#+ syntax:)
- ["." export]
- ["." declaration (#+ Declaration)]]]]
- ["." //])
-
-(type: Mutual
- {#declaration Declaration
- #type Code
- #body Code})
-
-(.def: mutual
- (Parser [Declaration Code Code])
- ($_ <>.and
- declaration.parser
- <code>.any
- <code>.any
- ))
-
-(.def: (mutual_definition context g!context [g!name mutual])
- (-> (List Code) Code [Code Mutual] Code)
- (` (function ((~ g!name) (~ g!context))
- (.let [[(~+ context)] (~ g!context)]
- (function (~ (declaration.format (get@ #declaration mutual)))
- (~ (get@ #body mutual)))))))
-
-(.def: (macro g!context g!self)
- (-> Code Code Macro)
- (<| (:as Macro)
- (: Macro')
- (function (_ parameters)
- (\ meta.monad wrap (list (` (((~ g!self) (~ g!context)) (~+ parameters))))))))
-
-(syntax: #export (let {functions (<code>.tuple (<>.some ..mutual))}
- body)
- (case functions
- #.Nil
- (wrap (list body))
-
- (#.Cons mutual #.Nil)
- (.let [g!name (|> mutual (get@ [#declaration #declaration.name]) code.local_identifier)]
- (wrap (list (` (.let [(~ g!name) (: (~ (get@ #type mutual))
- (function (~ (declaration.format (get@ #declaration mutual)))
- (~ (get@ #body mutual))))]
- (~ body))))))
-
- _
- (macro.with_gensyms [g!context g!output]
- (do {! meta.monad}
- [here_name meta.current_module_name
- hidden_names (monad.map ! (//.constant (macro.gensym "mutual_function#"))
- functions)
- #let [definitions (list\map (..mutual_definition hidden_names g!context)
- (list.zip/2 hidden_names
- functions))
- context_types (list\map (function (_ mutual)
- (` (-> (~ g!context) (~ (get@ #type mutual)))))
- functions)
- user_names (list\map (|>> (get@ [#declaration #declaration.name]) code.local_identifier)
- functions)]
- g!pop (local.push (list\map (function (_ [g!name mutual])
- [[here_name (get@ [#declaration #declaration.name] mutual)]
- (..macro g!context g!name)])
- (list.zip/2 hidden_names
- functions)))]
- (wrap (list (` (.let [(~ g!context) (: (Rec (~ g!context)
- [(~+ context_types)])
- [(~+ definitions)])
- [(~+ user_names)] (.let [[(~+ user_names)] (~ g!context)]
- [(~+ (list\map (function (_ g!name)
- (` ((~ g!name) (~ g!context))))
- user_names))])
- (~ g!output) (~ body)]
- (exec (~ g!pop)
- (~ g!output))))))))))
-
-(type: Definition
- {#exported? Bit
- #mutual Mutual})
-
-(.def: definition
- (Parser Definition)
- (<code>.tuple (<>.and export.parser
- ..mutual)))
-
-(syntax: #export (def: {functions (<>.many ..definition)})
- (case functions
- #.Nil
- (wrap (list))
-
- (#.Cons definition #.Nil)
- (.let [(^slots [#exported? #mutual]) definition
- (^slots [#declaration #type #body]) mutual]
- (wrap (list (` (.def:
- (~+ (export.format exported?))
- (~ (declaration.format declaration))
- (~ type)
- (~ body))))))
-
- _
- (macro.with_gensyms [g!context g!output]
- (do {! meta.monad}
- [here_name meta.current_module_name
- hidden_names (monad.map ! (//.constant (macro.gensym "mutual_function#"))
- functions)
- #let [definitions (list\map (..mutual_definition hidden_names g!context)
- (list.zip/2 hidden_names
- (list\map (get@ #mutual) functions)))
- context_types (list\map (function (_ mutual)
- (` (-> (~ g!context) (~ (get@ [#mutual #type] mutual)))))
- functions)
- user_names (list\map (|>> (get@ [#mutual #declaration #declaration.name]) code.local_identifier)
- functions)]
- g!pop (local.push (list\map (function (_ [g!name mutual])
- [[here_name (get@ [#mutual #declaration #declaration.name] mutual)]
- (..macro g!context g!name)])
- (list.zip/2 hidden_names
- functions)))]
- (wrap (list& (` (.def: (~ g!context)
- [(~+ (list\map (get@ [#mutual #type]) functions))]
- (.let [(~ g!context) (: (Rec (~ g!context)
- [(~+ context_types)])
- [(~+ definitions)])
- [(~+ user_names)] (~ g!context)]
- [(~+ (list\map (function (_ g!name)
- (` ((~ g!name) (~ g!context))))
- user_names))])))
- g!pop
- (list\map (function (_ mutual)
- (.let [g!name (|> mutual (get@ [#mutual #declaration #declaration.name]) code.local_identifier)]
- (` (.def:
- (~+ (export.format (get@ #exported? mutual)))
- (~ g!name)
- (~ (get@ [#mutual #type] mutual))
- (.let [[(~+ user_names)] (~ g!context)]
- (~ g!name))))))
- functions)))))))
diff --git a/stdlib/source/lux/control/io.lux b/stdlib/source/lux/control/io.lux
deleted file mode 100644
index fea9083ec..000000000
--- a/stdlib/source/lux/control/io.lux
+++ /dev/null
@@ -1,71 +0,0 @@
-(.module: {#.doc "A method for abstracting I/O and effectful computations to make it safe while writing pure functional code."}
- [lux #*
- [abstract
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- [monad (#+ Monad do)]]
- [control
- [parser
- ["s" code]]]
- [type
- abstract]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." template]]])
-
-(abstract: #export (IO a)
- (-> Any a)
-
- {#.doc "A type that represents synchronous, effectful computations that may interact with the outside world."}
-
- (def: label
- (All [a] (-> (-> Any a) (IO a)))
- (|>> :abstraction))
-
- (template: (!io computation)
- (:abstraction (template.with_locals [g!func g!arg]
- (function (g!func g!arg)
- computation))))
-
- (template: (!run io)
- ## creatio ex nihilo
- ((:representation io) []))
-
- (syntax: #export (io computation)
- {#.doc (doc "Delays the evaluation of an expression, by wrapping it in an IO 'thunk'."
- "Great for wrapping effectful computations (which will not be performed until the IO is 'run')."
- (io (exec
- (log! msg)
- "Some value...")))}
- (with_gensyms [g!func g!arg]
- (wrap (list (` ((~! ..label) (function ((~ g!func) (~ g!arg))
- (~ computation))))))))
-
- (def: #export run
- {#.doc "A way to execute IO computations and perform their side-effects."}
- (All [a] (-> (IO a) a))
- (|>> !run))
-
- (implementation: #export functor
- (Functor IO)
-
- (def: (map f)
- (|>> !run f !io)))
-
- (implementation: #export apply
- (Apply IO)
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (!io ((!run ff) (!run fa)))))
-
- (implementation: #export monad
- (Monad IO)
-
- (def: &functor ..functor)
-
- (def: wrap (|>> !io))
-
- (def: join (|>> !run !run !io)))
- )
diff --git a/stdlib/source/lux/control/parser.lux b/stdlib/source/lux/control/parser.lux
deleted file mode 100644
index fb8e856ae..000000000
--- a/stdlib/source/lux/control/parser.lux
+++ /dev/null
@@ -1,323 +0,0 @@
-(.module:
- [lux (#- or and not)
- [abstract
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- [monad (#+ Monad do)]
- [codec (#+ Codec)]]
- [control
- ["." try (#+ Try)]]
- [data
- ["." product]
- [collection
- ["." list ("#\." functor monoid)]]]
- [math
- [number
- ["n" nat]]]])
-
-(type: #export (Parser s a)
- {#.doc "A generic parser."}
- (-> s (Try [s a])))
-
-(implementation: #export functor
- (All [s] (Functor (Parser s)))
-
- (def: (map f ma)
- (function (_ input)
- (case (ma input)
- (#try.Failure msg)
- (#try.Failure msg)
-
- (#try.Success [input' a])
- (#try.Success [input' (f a)])))))
-
-(implementation: #export apply
- (All [s] (Apply (Parser s)))
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (function (_ input)
- (case (ff input)
- (#try.Success [input' f])
- (case (fa input')
- (#try.Success [input'' a])
- (#try.Success [input'' (f a)])
-
- (#try.Failure msg)
- (#try.Failure msg))
-
- (#try.Failure msg)
- (#try.Failure msg)))))
-
-(implementation: #export monad
- (All [s] (Monad (Parser s)))
-
- (def: &functor ..functor)
-
- (def: (wrap x)
- (function (_ input)
- (#try.Success [input x])))
-
- (def: (join mma)
- (function (_ input)
- (case (mma input)
- (#try.Failure msg)
- (#try.Failure msg)
-
- (#try.Success [input' ma])
- (ma input')))))
-
-(def: #export (assert message test)
- {#.doc "Fails with the given message if the test is #0."}
- (All [s] (-> Text Bit (Parser s Any)))
- (function (_ input)
- (if test
- (#try.Success [input []])
- (#try.Failure message))))
-
-(def: #export (maybe parser)
- {#.doc "Optionality combinator."}
- (All [s a]
- (-> (Parser s a) (Parser s (Maybe a))))
- (function (_ input)
- (case (parser input)
- (#try.Failure _)
- (#try.Success [input #.None])
-
- (#try.Success [input' x])
- (#try.Success [input' (#.Some x)]))))
-
-(def: #export (run parser input)
- (All [s a]
- (-> (Parser s a) s (Try [s a])))
- (parser input))
-
-(def: #export (and first second)
- {#.doc "Sequencing combinator."}
- (All [s a b]
- (-> (Parser s a) (Parser s b) (Parser s [a b])))
- (do {! ..monad}
- [head first]
- (\ ! map (|>> [head]) second)))
-
-(def: #export (or left right)
- {#.doc "Heterogeneous alternative combinator."}
- (All [s a b]
- (-> (Parser s a) (Parser s b) (Parser s (| a b))))
- (function (_ tokens)
- (case (left tokens)
- (#try.Success [tokens' output])
- (#try.Success [tokens' (0 #0 output)])
-
- (#try.Failure _)
- (case (right tokens)
- (#try.Success [tokens' output])
- (#try.Success [tokens' (0 #1 output)])
-
- (#try.Failure error)
- (#try.Failure error)))))
-
-(def: #export (either this that)
- {#.doc "Homogeneous alternative combinator."}
- (All [s a]
- (-> (Parser s a) (Parser s a) (Parser s a)))
- (function (_ tokens)
- (case (this tokens)
- (#try.Failure _)
- (that tokens)
-
- output
- output)))
-
-(def: #export (some parser)
- {#.doc "0-or-more combinator."}
- (All [s a]
- (-> (Parser s a) (Parser s (List a))))
- (function (_ input)
- (case (parser input)
- (#try.Failure _)
- (#try.Success [input (list)])
-
- (#try.Success [input' head])
- (..run (\ ..monad map (|>> (list& head))
- (some parser))
- input'))))
-
-(def: #export (many parser)
- {#.doc "1-or-more combinator."}
- (All [s a]
- (-> (Parser s a) (Parser s (List a))))
- (|> (..some parser)
- (..and parser)
- (\ ..monad map (|>> #.Cons))))
-
-(def: #export (exactly amount parser)
- {#.doc "Parse exactly N times."}
- (All [s a] (-> Nat (Parser s a) (Parser s (List a))))
- (case amount
- 0 (\ ..monad wrap (list))
- _ (do {! ..monad}
- [x parser]
- (|> parser
- (exactly (dec amount))
- (\ ! map (|>> (#.Cons x)))))))
-
-(def: #export (at_least amount parser)
- {#.doc "Parse at least N times."}
- (All [s a] (-> Nat (Parser s a) (Parser s (List a))))
- (do {! ..monad}
- [minimum (..exactly amount parser)]
- (\ ! map (list\compose minimum) (..some parser))))
-
-(def: #export (at_most amount parser)
- {#.doc "Parse at most N times."}
- (All [s a] (-> Nat (Parser s a) (Parser s (List a))))
- (case amount
- 0 (\ ..monad wrap (list))
- _ (function (_ input)
- (case (parser input)
- (#try.Failure msg)
- (#try.Success [input (list)])
-
- (#try.Success [input' x])
- (..run (\ ..monad map (|>> (#.Cons x))
- (at_most (dec amount) parser))
- input')))))
-
-(def: #export (between from to parser)
- {#.doc "Parse between N and M times."}
- (All [s a] (-> Nat Nat (Parser s a) (Parser s (List a))))
- (do {! ..monad}
- [minimum (..exactly from parser)]
- (if (n.< to from)
- (\ ! map (list\compose minimum)
- (..at_most (n.- from to) parser))
- (wrap minimum))))
-
-(def: #export (separated_by separator parser)
- {#.doc "Parsers instances of 'parser' that are separated by instances of 'separator'."}
- (All [s a b] (-> (Parser s b) (Parser s a) (Parser s (List a))))
- (do {! ..monad}
- [?x (..maybe parser)]
- (case ?x
- #.None
- (wrap #.Nil)
-
- (#.Some x)
- (|> parser
- (..and separator)
- ..some
- (\ ! map (|>> (list\map product.right) (#.Cons x)))))))
-
-(def: #export (not parser)
- (All [s a] (-> (Parser s a) (Parser s Any)))
- (function (_ input)
- (case (parser input)
- (#try.Failure msg)
- (#try.Success [input []])
-
- _
- (#try.Failure "Expected to fail; yet succeeded."))))
-
-(def: #export (fail message)
- (All [s a] (-> Text (Parser s a)))
- (function (_ input)
- (#try.Failure message)))
-
-(def: #export (lift operation)
- (All [s a] (-> (Try a) (Parser s a)))
- (function (_ input)
- (case operation
- (#try.Success output)
- (#try.Success [input output])
-
- (#try.Failure error)
- (#try.Failure error))))
-
-(def: #export (default value parser)
- {#.doc "If the given parser fails, returns the default value."}
- (All [s a] (-> a (Parser s a) (Parser s a)))
- (function (_ input)
- (case (parser input)
- (#try.Failure error)
- (#try.Success [input value])
-
- (#try.Success [input' output])
- (#try.Success [input' output]))))
-
-(def: #export remaining
- (All [s] (Parser s s))
- (function (_ inputs)
- (#try.Success [inputs inputs])))
-
-(def: #export (rec parser)
- {#.doc "Combinator for recursive parser."}
- (All [s a] (-> (-> (Parser s a) (Parser s a)) (Parser s a)))
- (function (_ inputs)
- (..run (parser (rec parser)) inputs)))
-
-(def: #export (after param subject)
- (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a)))
- (do ..monad
- [_ param]
- subject))
-
-(def: #export (before param subject)
- (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a)))
- (do ..monad
- [output subject
- _ param]
- (wrap output)))
-
-(def: #export (filter test parser)
- (All [s a] (-> (-> a Bit) (Parser s a) (Parser s a)))
- (do ..monad
- [output parser
- _ (..assert "Constraint failed." (test output))]
- (wrap output)))
-
-(def: #export (parses? parser)
- (All [s a] (-> (Parser s a) (Parser s Bit)))
- (function (_ input)
- (case (parser input)
- (#try.Failure error)
- (#try.Success [input false])
-
- (#try.Success [input' _])
- (#try.Success [input' true]))))
-
-(def: #export (parses parser)
- (All [s a] (-> (Parser s a) (Parser s Any)))
- (function (_ input)
- (case (parser input)
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success [input' _])
- (#try.Success [input' []]))))
-
-(def: #export (speculative parser)
- (All [s a] (-> (Parser s a) (Parser s a)))
- (function (_ input)
- (case (parser input)
- (#try.Success [input' output])
- (#try.Success [input output])
-
- output
- output)))
-
-(def: #export (codec codec parser)
- (All [s a z] (-> (Codec a z) (Parser s a) (Parser s z)))
- (function (_ input)
- (case (parser input)
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success [input' to_decode])
- (case (\ codec decode to_decode)
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success value)
- (#try.Success [input' value])))))
diff --git a/stdlib/source/lux/control/parser/analysis.lux b/stdlib/source/lux/control/parser/analysis.lux
deleted file mode 100644
index b825354c1..000000000
--- a/stdlib/source/lux/control/parser/analysis.lux
+++ /dev/null
@@ -1,134 +0,0 @@
-(.module:
- [lux (#- nat int rev)
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." bit]
- ["." name]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]]]
- [math
- [number
- ["." i64]
- ["." nat]
- ["." int]
- ["." rev]
- ["." frac]]]
- [tool
- [compiler
- [arity (#+ Arity)]
- [reference (#+)
- [variable (#+)]]
- [language
- [lux
- ["/" analysis (#+ Variant Tuple Environment Analysis)]]]]]]
- ["." //])
-
-(def: (remaining_inputs asts)
- (-> (List Analysis) Text)
- (format text.new_line "Remaining input: "
- (|> asts
- (list\map /.%analysis)
- (list.interpose " ")
- (text.join_with ""))))
-
-(exception: #export (cannot_parse {input (List Analysis)})
- (exception.report
- ["Input" (exception.enumerate /.%analysis input)]))
-
-(exception: #export (unconsumed_input {input (List Analysis)})
- (exception.report
- ["Input" (exception.enumerate /.%analysis input)]))
-
-(type: #export Parser
- (//.Parser (List Analysis)))
-
-(def: #export (run parser input)
- (All [a] (-> (Parser a) (List Analysis) (Try a)))
- (case (parser input)
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success [#.Nil value])
- (#try.Success value)
-
- (#try.Success [unconsumed _])
- (exception.throw ..unconsumed_input unconsumed)))
-
-(def: #export any
- (Parser Analysis)
- (function (_ input)
- (case input
- #.Nil
- (exception.throw ..cannot_parse input)
-
- (#.Cons [head tail])
- (#try.Success [tail head]))))
-
-(def: #export end!
- {#.doc "Ensures there are no more inputs."}
- (Parser Any)
- (function (_ tokens)
- (case tokens
- #.Nil (#try.Success [tokens []])
- _ (#try.Failure (format "Expected list of tokens to be empty!"
- (remaining_inputs tokens))))))
-
-(def: #export end?
- {#.doc "Checks whether there are no more inputs."}
- (Parser Bit)
- (function (_ tokens)
- (#try.Success [tokens (case tokens
- #.Nil true
- _ false)])))
-
-(template [<query> <assertion> <tag> <type> <eq>]
- [(def: #export <query>
- (Parser <type>)
- (function (_ input)
- (case input
- (^ (list& (<tag> x) input'))
- (#try.Success [input' x])
-
- _
- (exception.throw ..cannot_parse input))))
-
- (def: #export (<assertion> expected)
- (-> <type> (Parser Any))
- (function (_ input)
- (case input
- (^ (list& (<tag> actual) input'))
- (if (\ <eq> = expected actual)
- (#try.Success [input' []])
- (exception.throw ..cannot_parse input))
-
- _
- (exception.throw ..cannot_parse input))))]
-
- [bit bit! /.bit Bit bit.equivalence]
- [nat nat! /.nat Nat nat.equivalence]
- [int int! /.int Int int.equivalence]
- [rev rev! /.rev Rev rev.equivalence]
- [frac frac! /.frac Frac frac.equivalence]
- [text text! /.text Text text.equivalence]
- [local local! /.variable/local Nat nat.equivalence]
- [foreign foreign! /.variable/foreign Nat nat.equivalence]
- [constant constant! /.constant Name name.equivalence]
- )
-
-(def: #export (tuple parser)
- (All [a] (-> (Parser a) (Parser a)))
- (function (_ input)
- (case input
- (^ (list& (/.tuple head) tail))
- (do try.monad
- [output (..run parser head)]
- (#try.Success [tail output]))
-
- _
- (exception.throw ..cannot_parse input))))
diff --git a/stdlib/source/lux/control/parser/binary.lux b/stdlib/source/lux/control/parser/binary.lux
deleted file mode 100644
index 37423b091..000000000
--- a/stdlib/source/lux/control/parser/binary.lux
+++ /dev/null
@@ -1,274 +0,0 @@
-(.module:
- [lux (#- and or nat int rev list type)
- [type (#+ :share)]
- [abstract
- [hash (#+ Hash)]
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["/" binary (#+ Binary)]
- [text
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." list]
- ["." row (#+ Row)]
- ["." set (#+ Set)]]]
- [macro
- ["." template]]
- [math
- [number
- ["n" nat]
- ["." frac]]]]
- ["." // ("#\." monad)])
-
-(type: #export Offset Nat)
-
-(type: #export Parser
- (//.Parser [Offset Binary]))
-
-(exception: #export (binary_was_not_fully_read {binary_length Nat} {bytes_read Nat})
- (exception.report
- ["Binary length" (%.nat binary_length)]
- ["Bytes read" (%.nat bytes_read)]))
-
-(def: #export (run parser input)
- (All [a] (-> (Parser a) Binary (Try a)))
- (case (parser [0 input])
- (#try.Failure msg)
- (#try.Failure msg)
-
- (#try.Success [[end _] output])
- (let [length (/.size input)]
- (if (n.= end length)
- (#try.Success output)
- (exception.throw ..binary_was_not_fully_read [length end])))))
-
-(def: #export end?
- (Parser Bit)
- (function (_ (^@ input [offset data]))
- (#try.Success [input (n.= offset (/.size data))])))
-
-(def: #export offset
- (Parser Offset)
- (function (_ (^@ input [offset data]))
- (#try.Success [input offset])))
-
-(def: #export remaining
- (Parser Nat)
- (function (_ (^@ input [offset data]))
- (#try.Success [input (n.- offset (/.size data))])))
-
-(type: #export Size Nat)
-
-(def: #export size/8 Size 1)
-(def: #export size/16 Size (n.* 2 size/8))
-(def: #export size/32 Size (n.* 2 size/16))
-(def: #export size/64 Size (n.* 2 size/32))
-
-(template [<name> <size> <read>]
- [(def: #export <name>
- (Parser I64)
- (function (_ [offset binary])
- (case (<read> offset binary)
- (#try.Success data)
- (#try.Success [(n.+ <size> offset) binary] data)
-
- (#try.Failure error)
- (#try.Failure error))))]
-
- [bits/8 ..size/8 /.read/8]
- [bits/16 ..size/16 /.read/16]
- [bits/32 ..size/32 /.read/32]
- [bits/64 ..size/64 /.read/64]
- )
-
-(template [<name> <type>]
- [(def: #export <name> (Parser <type>) ..bits/64)]
-
- [nat Nat]
- [int Int]
- [rev Rev]
- )
-
-(def: #export frac
- (Parser Frac)
- (//\map frac.from_bits ..bits/64))
-
-(exception: #export (invalid_tag {range Nat} {byte Nat})
- (exception.report
- ["Tag range" (%.nat range)]
- ["Tag value" (%.nat byte)]))
-
-(template: (!variant <case>+)
- (do {! //.monad}
- [flag (: (Parser Nat)
- ..bits/8)]
- (`` (case flag
- (^template [<number> <tag> <parser>]
- [<number> (\ ! map (|>> <tag>) <parser>)])
- ((~~ (template.splice <case>+)))
- _ (//.lift (exception.throw ..invalid_tag [(~~ (template.count <case>+)) flag]))))))
-
-(def: #export (or left right)
- (All [l r] (-> (Parser l) (Parser r) (Parser (| l r))))
- (!variant [[0 #.Left left]
- [1 #.Right right]]))
-
-(def: #export (rec body)
- (All [a] (-> (-> (Parser a) (Parser a)) (Parser a)))
- (function (_ input)
- (let [parser (body (rec body))]
- (parser input))))
-
-(def: #export any
- (Parser Any)
- (//\wrap []))
-
-(exception: #export (not_a_bit {value Nat})
- (exception.report
- ["Expected values" "either 0 or 1"]
- ["Actual value" (%.nat value)]))
-
-(def: #export bit
- (Parser Bit)
- (do //.monad
- [value (: (Parser Nat)
- ..bits/8)]
- (case value
- 0 (wrap #0)
- 1 (wrap #1)
- _ (//.lift (exception.throw ..not_a_bit [value])))))
-
-(def: #export (segment size)
- (-> Nat (Parser Binary))
- (function (_ [offset binary])
- (case size
- 0 (#try.Success [[offset binary] (/.create 0)])
- _ (|> binary
- (/.slice offset size)
- (\ try.monad map (|>> [[(n.+ size offset) binary]]))))))
-
-(template [<name> <bits>]
- [(def: #export <name>
- (Parser Binary)
- (do //.monad
- [size (//\map .nat <bits>)]
- (..segment size)))]
-
- [binary/8 ..bits/8]
- [binary/16 ..bits/16]
- [binary/32 ..bits/32]
- [binary/64 ..bits/64]
- )
-
-(template [<name> <binary>]
- [(def: #export <name>
- (Parser Text)
- (do //.monad
- [utf8 <binary>]
- (//.lift (\ utf8.codec decode utf8))))]
-
- [utf8/8 ..binary/8]
- [utf8/16 ..binary/16]
- [utf8/32 ..binary/32]
- [utf8/64 ..binary/64]
- )
-
-(def: #export text ..utf8/64)
-
-(template [<name> <bits>]
- [(def: #export (<name> valueP)
- (All [v] (-> (Parser v) (Parser (Row v))))
- (do //.monad
- [count (: (Parser Nat)
- <bits>)]
- (loop [index 0
- output (:share [v]
- (Parser v)
- valueP
-
- (Row v)
- row.empty)]
- (if (n.< count index)
- (do //.monad
- [value valueP]
- (recur (.inc index)
- (row.add value output)))
- (//\wrap output)))))]
-
- [row/8 ..bits/8]
- [row/16 ..bits/16]
- [row/32 ..bits/32]
- [row/64 ..bits/64]
- )
-
-(def: #export maybe
- (All [a] (-> (Parser a) (Parser (Maybe a))))
- (..or ..any))
-
-(def: #export (list value)
- (All [a] (-> (Parser a) (Parser (List a))))
- (..rec
- (|>> (//.and value)
- (..or ..any))))
-
-(exception: #export set_elements_are_not_unique)
-
-(def: #export (set hash value)
- (All [a] (-> (Hash a) (Parser a) (Parser (Set a))))
- (do //.monad
- [raw (..list value)
- #let [output (set.from_list hash raw)]
- _ (//.assert (exception.construct ..set_elements_are_not_unique [])
- (n.= (list.size raw)
- (set.size output)))]
- (wrap output)))
-
-(def: #export name
- (Parser Name)
- (//.and ..text ..text))
-
-(def: #export type
- (Parser Type)
- (..rec
- (function (_ type)
- (let [pair (//.and type type)
- indexed ..nat
- quantified (//.and (..list type) type)]
- (!variant [[0 #.Primitive (//.and ..text (..list type))]
- [1 #.Sum pair]
- [2 #.Product pair]
- [3 #.Function pair]
- [4 #.Parameter indexed]
- [5 #.Var indexed]
- [6 #.Ex indexed]
- [7 #.UnivQ quantified]
- [8 #.ExQ quantified]
- [9 #.Apply pair]
- [10 #.Named (//.and ..name type)]])))))
-
-(def: #export location
- (Parser Location)
- ($_ //.and ..text ..nat ..nat))
-
-(def: #export code
- (Parser Code)
- (..rec
- (function (_ recur)
- (let [sequence (..list recur)]
- (//.and ..location
- (!variant [[0 #.Bit ..bit]
- [1 #.Nat ..nat]
- [2 #.Int ..int]
- [3 #.Rev ..rev]
- [4 #.Frac ..frac]
- [5 #.Text ..text]
- [6 #.Identifier ..name]
- [7 #.Tag ..name]
- [8 #.Form sequence]
- [9 #.Tuple sequence]
- [10 #.Record (..list (//.and recur recur))]]))))))
diff --git a/stdlib/source/lux/control/parser/cli.lux b/stdlib/source/lux/control/parser/cli.lux
deleted file mode 100644
index b39b4234c..000000000
--- a/stdlib/source/lux/control/parser/cli.lux
+++ /dev/null
@@ -1,98 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]]
- ["." //])
-
-(type: #export (Parser a)
- {#.doc "A command-line interface parser."}
- (//.Parser (List Text) a))
-
-(def: #export (run parser inputs)
- (All [a] (-> (Parser a) (List Text) (Try a)))
- (case (//.run parser inputs)
- (#try.Success [remaining output])
- (case remaining
- #.Nil
- (#try.Success output)
-
- _
- (#try.Failure (format "Remaining CLI inputs: " (text.join_with " " remaining))))
-
- (#try.Failure try)
- (#try.Failure try)))
-
-(def: #export any
- {#.doc "Just returns the next input without applying any logic."}
- (Parser Text)
- (function (_ inputs)
- (case inputs
- (#.Cons arg inputs')
- (#try.Success [inputs' arg])
-
- _
- (#try.Failure "Cannot parse empty arguments."))))
-
-(def: #export (parse parser)
- {#.doc "Parses the next input with a parsing function."}
- (All [a] (-> (-> Text (Try a)) (Parser a)))
- (function (_ inputs)
- (do try.monad
- [[remaining raw] (any inputs)
- output (parser raw)]
- (wrap [remaining output]))))
-
-(def: #export (this reference)
- {#.doc "Checks that a token is in the inputs."}
- (-> Text (Parser Any))
- (function (_ inputs)
- (do try.monad
- [[remaining raw] (any inputs)]
- (if (text\= reference raw)
- (wrap [remaining []])
- (try.fail (format "Missing token: '" reference "'"))))))
-
-(def: #export (somewhere cli)
- {#.doc "Given a parser, tries to parse it somewhere in the inputs (i.e. not necessarily parsing the immediate inputs)."}
- (All [a] (-> (Parser a) (Parser a)))
- (function (_ inputs)
- (loop [immediate inputs]
- (case (//.run cli immediate)
- (#try.Success [remaining output])
- (#try.Success [remaining output])
-
- (#try.Failure try)
- (case immediate
- #.Nil
- (#try.Failure try)
-
- (#.Cons to_omit immediate')
- (do try.monad
- [[remaining output] (recur immediate')]
- (wrap [(#.Cons to_omit remaining)
- output])))))))
-
-(def: #export end
- {#.doc "Ensures there are no more inputs."}
- (Parser Any)
- (function (_ inputs)
- (case inputs
- #.Nil (#try.Success [inputs []])
- _ (#try.Failure (format "Unknown parameters: " (text.join_with " " inputs))))))
-
-(def: #export (named name value)
- (All [a] (-> Text (Parser a) (Parser a)))
- (|> value
- (//.after (..this name))
- ..somewhere))
-
-(def: #export (parameter [short long] value)
- (All [a] (-> [Text Text] (Parser a) (Parser a)))
- (|> value
- (//.after (//.either (..this short) (..this long)))
- ..somewhere))
diff --git a/stdlib/source/lux/control/parser/code.lux b/stdlib/source/lux/control/parser/code.lux
deleted file mode 100644
index 86ee0a1d8..000000000
--- a/stdlib/source/lux/control/parser/code.lux
+++ /dev/null
@@ -1,198 +0,0 @@
-(.module:
- [lux (#- nat int rev)
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]]
- [data
- ["." bit]
- ["." text ("#\." monoid)]
- ["." name]
- [collection
- ["." list ("#\." functor)]]]
- [macro
- ["." code ("#\." equivalence)]]
- [math
- [number
- ["." nat]
- ["." int]
- ["." rev]
- ["." frac]]]]
- ["." //])
-
-(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'))))
-
-(type: #export Parser
- {#.doc "A Lux syntax parser."}
- (//.Parser (List Code)))
-
-(def: (remaining_inputs asts)
- (-> (List Code) Text)
- ($_ text\compose text.new_line "Remaining input: "
- (|> asts (list\map code.format) (list.interpose " ") (text.join_with ""))))
-
-(def: #export any
- {#.doc "Just returns the next input without applying any logic."}
- (Parser Code)
- (function (_ tokens)
- (case tokens
- #.Nil
- (#try.Failure "There are no tokens to parse!")
-
- (#.Cons [t tokens'])
- (#try.Success [tokens' t]))))
-
-(template [<query> <check> <type> <tag> <eq> <desc>]
- [(with_expansions [<failure> (as_is (#try.Failure ($_ text\compose "Cannot parse " <desc> (remaining_inputs tokens))))]
- (def: #export <query>
- {#.doc (code.text ($_ text\compose "Parses the next " <desc> " input."))}
- (Parser <type>)
- (function (_ tokens)
- (case tokens
- (#.Cons [[_ (<tag> x)] tokens'])
- (#try.Success [tokens' x])
-
- _
- <failure>)))
-
- (def: #export (<check> expected)
- (-> <type> (Parser Any))
- (function (_ tokens)
- (case tokens
- (#.Cons [[_ (<tag> actual)] tokens'])
- (if (\ <eq> = expected actual)
- (#try.Success [tokens' []])
- <failure>)
-
- _
- <failure>))))]
-
- [bit bit! Bit #.Bit bit.equivalence "bit"]
- [nat nat! Nat #.Nat nat.equivalence "nat"]
- [int int! Int #.Int int.equivalence "int"]
- [rev rev! Rev #.Rev rev.equivalence "rev"]
- [frac frac! Frac #.Frac frac.equivalence "frac"]
- [text text! Text #.Text text.equivalence "text"]
- [identifier identifier! Name #.Identifier name.equivalence "identifier"]
- [tag tag! Name #.Tag name.equivalence "tag"]
- )
-
-(def: #export (this! ast)
- {#.doc "Ensures the given Code is the next input."}
- (-> Code (Parser Any))
- (function (_ tokens)
- (case tokens
- (#.Cons [token tokens'])
- (if (code\= ast token)
- (#try.Success [tokens' []])
- (#try.Failure ($_ text\compose "Expected a " (code.format ast) " but instead got " (code.format token)
- (remaining_inputs tokens))))
-
- _
- (#try.Failure "There are no tokens to parse!"))))
-
-(template [<query> <check> <tag> <eq> <desc>]
- [(with_expansions [<failure> (as_is (#try.Failure ($_ text\compose "Cannot parse " <desc> (remaining_inputs tokens))))]
- (def: #export <query>
- {#.doc (code.text ($_ text\compose "Parse a local " <desc> " (a " <desc> " that has no module prefix)."))}
- (Parser Text)
- (function (_ tokens)
- (case tokens
- (#.Cons [[_ (<tag> ["" x])] tokens'])
- (#try.Success [tokens' x])
-
- _
- <failure>)))
-
- (def: #export (<check> expected)
- (-> Text (Parser Any))
- (function (_ tokens)
- (case tokens
- (#.Cons [[_ (<tag> ["" actual])] tokens'])
- (if (\ <eq> = expected actual)
- (#try.Success [tokens' []])
- <failure>)
-
- _
- <failure>))))]
-
- [local_identifier local_identifier! #.Identifier text.equivalence "local identifier"]
- [ local_tag local_tag! #.Tag text.equivalence "local tag"]
- )
-
-(template [<name> <tag> <desc>]
- [(def: #export (<name> p)
- {#.doc (code.text ($_ text\compose "Parse inside the contents of a " <desc> " as if they were the input Codes."))}
- (All [a]
- (-> (Parser a) (Parser a)))
- (function (_ tokens)
- (case tokens
- (#.Cons [[_ (<tag> members)] tokens'])
- (case (p members)
- (#try.Success [#.Nil x]) (#try.Success [tokens' x])
- _ (#try.Failure ($_ text\compose "Parser was expected to fully consume " <desc> (remaining_inputs tokens))))
-
- _
- (#try.Failure ($_ text\compose "Cannot parse " <desc> (remaining_inputs tokens))))))]
-
- [ form #.Form "form"]
- [tuple #.Tuple "tuple"]
- )
-
-(def: #export (record p)
- {#.doc (code.text ($_ text\compose "Parse inside the contents of a record as if they were the input Codes."))}
- (All [a]
- (-> (Parser a) (Parser a)))
- (function (_ tokens)
- (case tokens
- (#.Cons [[_ (#.Record pairs)] tokens'])
- (case (p (join_pairs pairs))
- (#try.Success [#.Nil x]) (#try.Success [tokens' x])
- _ (#try.Failure ($_ text\compose "Parser was expected to fully consume record" (remaining_inputs tokens))))
-
- _
- (#try.Failure ($_ text\compose "Cannot parse record" (remaining_inputs tokens))))))
-
-(def: #export end!
- {#.doc "Ensures there are no more inputs."}
- (Parser Any)
- (function (_ tokens)
- (case tokens
- #.Nil (#try.Success [tokens []])
- _ (#try.Failure ($_ text\compose "Expected list of tokens to be empty!" (remaining_inputs tokens))))))
-
-(def: #export end?
- {#.doc "Checks whether there are no more inputs."}
- (Parser Bit)
- (function (_ tokens)
- (#try.Success [tokens (case tokens
- #.Nil true
- _ false)])))
-
-(def: #export (run syntax inputs)
- (All [a] (-> (Parser a) (List Code) (Try a)))
- (case (syntax inputs)
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success [unconsumed value])
- (case unconsumed
- #.Nil
- (#try.Success value)
-
- _
- (#try.Failure (text\compose "Unconsumed inputs: "
- (|> (list\map code.format unconsumed)
- (text.join_with ", ")))))))
-
-(def: #export (local inputs syntax)
- {#.doc "Run a syntax parser with the given list of inputs, instead of the real ones."}
- (All [a] (-> (List Code) (Parser a) (Parser a)))
- (function (_ real)
- (do try.monad
- [value (..run syntax inputs)]
- (wrap [real value]))))
diff --git a/stdlib/source/lux/control/parser/environment.lux b/stdlib/source/lux/control/parser/environment.lux
deleted file mode 100644
index 509369d68..000000000
--- a/stdlib/source/lux/control/parser/environment.lux
+++ /dev/null
@@ -1,43 +0,0 @@
-(.module:
- [lux #*
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary (#+ Dictionary)]]]]
- ["." //])
-
-(type: #export Property
- Text)
-
-(type: #export Environment
- (Dictionary Property Text))
-
-(exception: #export (unknown {property Property})
- (exception.report
- ["Property" (%.text property)]))
-
-(type: #export (Parser a)
- (//.Parser Environment a))
-
-(def: #export empty
- Environment
- (dictionary.new text.hash))
-
-(def: #export (property name)
- (-> Text (Parser Text))
- (function (_ environment)
- (case (dictionary.get name environment)
- (#.Some value)
- (exception.return [environment value])
-
- #.None
- (exception.throw ..unknown name))))
-
-(def: #export (run parser environment)
- (All [a] (-> (Parser a) Environment (Try a)))
- (\ try.monad map product.right (parser environment)))
diff --git a/stdlib/source/lux/control/parser/json.lux b/stdlib/source/lux/control/parser/json.lux
deleted file mode 100644
index abc3ded7c..000000000
--- a/stdlib/source/lux/control/parser/json.lux
+++ /dev/null
@@ -1,206 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." bit]
- ["." text ("#\." equivalence monoid)]
- [collection
- ["." list ("#\." functor)]
- ["." row]
- ["." dictionary (#+ Dictionary)]]
- [format
- ["/" json (#+ JSON)]]]
- [macro
- ["." code]]
- [math
- [number
- ["." frac]]]]
- ["." // ("#\." functor)])
-
-(type: #export (Parser a)
- {#.doc "JSON parser."}
- (//.Parser (List JSON) a))
-
-(exception: #export (unconsumed_input {input (List JSON)})
- (exception.report
- ["Input" (exception.enumerate /.format input)]))
-
-(exception: #export empty_input)
-
-(def: #export (run parser json)
- (All [a] (-> (Parser a) JSON (Try a)))
- (case (//.run parser (list json))
- (#try.Success [remainder output])
- (case remainder
- #.Nil
- (#try.Success output)
-
- _
- (exception.throw ..unconsumed_input remainder))
-
- (#try.Failure error)
- (#try.Failure error)))
-
-(def: #export any
- {#.doc "Just returns the JSON input without applying any logic."}
- (Parser JSON)
- (<| (function (_ inputs))
- (case inputs
- #.Nil
- (exception.throw ..empty_input [])
-
- (#.Cons head tail)
- (#try.Success [tail head]))))
-
-(exception: #export (unexpected_value {value JSON})
- (exception.report
- ["Value" (/.format value)]))
-
-(template [<name> <type> <tag> <desc>]
- [(def: #export <name>
- {#.doc (code.text ($_ text\compose "Reads a JSON value as " <desc> "."))}
- (Parser <type>)
- (do //.monad
- [head ..any]
- (case head
- (<tag> value)
- (wrap value)
-
- _
- (//.fail (exception.construct ..unexpected_value [head])))))]
-
- [null /.Null #/.Null "null"]
- [boolean /.Boolean #/.Boolean "boolean"]
- [number /.Number #/.Number "number"]
- [string /.String #/.String "string"]
- )
-
-(exception: #export [a] (value_mismatch {reference JSON} {sample JSON})
- (exception.report
- ["Reference" (/.format reference)]
- ["Sample" (/.format sample)]))
-
-(template [<test> <check> <type> <equivalence> <tag> <desc>]
- [(def: #export (<test> test)
- {#.doc (code.text ($_ text\compose "Asks whether a JSON value is a " <desc> "."))}
- (-> <type> (Parser Bit))
- (do //.monad
- [head ..any]
- (case head
- (<tag> value)
- (wrap (\ <equivalence> = test value))
-
- _
- (//.fail (exception.construct ..unexpected_value [head])))))
-
- (def: #export (<check> test)
- {#.doc (code.text ($_ text\compose "Ensures a JSON value is a " <desc> "."))}
- (-> <type> (Parser Any))
- (do //.monad
- [head ..any]
- (case head
- (<tag> value)
- (if (\ <equivalence> = test value)
- (wrap [])
- (//.fail (exception.construct ..value_mismatch [(<tag> test) (<tag> value)])))
-
- _
- (//.fail (exception.construct ..unexpected_value [head])))))]
-
- [boolean? boolean! /.Boolean bit.equivalence #/.Boolean "boolean"]
- [number? number! /.Number frac.equivalence #/.Number "number"]
- [string? string! /.String text.equivalence #/.String "string"]
- )
-
-(def: #export (nullable parser)
- (All [a] (-> (Parser a) (Parser (Maybe a))))
- (//.or ..null
- parser))
-
-(def: #export (array parser)
- {#.doc "Parses a JSON array."}
- (All [a] (-> (Parser a) (Parser a)))
- (do //.monad
- [head ..any]
- (case head
- (#/.Array values)
- (case (//.run parser (row.to_list values))
- (#try.Failure error)
- (//.fail error)
-
- (#try.Success [remainder output])
- (case remainder
- #.Nil
- (wrap output)
-
- _
- (//.fail (exception.construct ..unconsumed_input remainder))))
-
- _
- (//.fail (exception.construct ..unexpected_value [head])))))
-
-(def: #export (object parser)
- {#.doc "Parses a JSON object. Use this with the 'field' combinator."}
- (All [a] (-> (Parser a) (Parser a)))
- (do //.monad
- [head ..any]
- (case head
- (#/.Object kvs)
- (case (|> kvs
- dictionary.entries
- (list\map (function (_ [key value])
- (list (#/.String key) value)))
- list.concat
- (//.run parser))
- (#try.Failure error)
- (//.fail error)
-
- (#try.Success [remainder output])
- (case remainder
- #.Nil
- (wrap output)
-
- _
- (//.fail (exception.construct ..unconsumed_input remainder))))
-
- _
- (//.fail (exception.construct ..unexpected_value [head])))))
-
-(def: #export (field field_name parser)
- {#.doc "Parses a field inside a JSON object. Use this inside the 'object' combinator."}
- (All [a] (-> Text (Parser a) (Parser a)))
- (function (recur inputs)
- (case inputs
- (^ (list& (#/.String key) value inputs'))
- (if (text\= key field_name)
- (case (//.run parser (list value))
- (#try.Success [#.Nil output])
- (#try.Success [inputs' output])
-
- (#try.Success [inputs'' _])
- (exception.throw ..unconsumed_input inputs'')
-
- (#try.Failure error)
- (#try.Failure error))
- (do try.monad
- [[inputs'' output] (recur inputs')]
- (wrap [(list& (#/.String key) value inputs'')
- output])))
-
- #.Nil
- (exception.throw ..empty_input [])
-
- _
- (exception.throw ..unconsumed_input inputs))))
-
-(def: #export dictionary
- {#.doc "Parses a dictionary-like JSON object."}
- (All [a] (-> (Parser a) (Parser (Dictionary Text a))))
- (|>> (//.and ..string)
- //.some
- ..object
- (//\map (dictionary.from_list text.hash))))
diff --git a/stdlib/source/lux/control/parser/synthesis.lux b/stdlib/source/lux/control/parser/synthesis.lux
deleted file mode 100644
index f6ae1c1ae..000000000
--- a/stdlib/source/lux/control/parser/synthesis.lux
+++ /dev/null
@@ -1,163 +0,0 @@
-(.module:
- [lux (#- function loop i64)
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." bit]
- ["." name]
- ["." text
- ["%" format (#+ format)]]]
- [math
- [number
- ["n" nat]
- ["." i64]
- ["." frac]]]
- [tool
- [compiler
- [reference (#+)
- [variable (#+ Register)]]
- [arity (#+ Arity)]
- [language
- [lux
- [analysis (#+ Variant Tuple Environment)]
- ["/" synthesis (#+ Synthesis Abstraction)]]]]]]
- ["." //])
-
-## TODO: Use "type:" ASAP.
-(def: Input
- Type
- (type (List Synthesis)))
-
-(exception: #export (cannot_parse {input ..Input})
- (exception.report
- ["Input" (exception.enumerate /.%synthesis input)]))
-
-(exception: #export (unconsumed_input {input ..Input})
- (exception.report
- ["Input" (exception.enumerate /.%synthesis input)]))
-
-(exception: #export (expected_empty_input {input ..Input})
- (exception.report
- ["Input" (exception.enumerate /.%synthesis input)]))
-
-(exception: #export (wrong_arity {expected Arity} {actual Arity})
- (exception.report
- ["Expected" (%.nat expected)]
- ["Actual" (%.nat actual)]))
-
-(exception: #export empty_input)
-
-(type: #export Parser
- (//.Parser ..Input))
-
-(def: #export (run parser input)
- (All [a] (-> (Parser a) ..Input (Try a)))
- (case (parser input)
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success [#.Nil value])
- (#try.Success value)
-
- (#try.Success [unconsumed _])
- (exception.throw ..unconsumed_input unconsumed)))
-
-(def: #export any
- (Parser Synthesis)
- (.function (_ input)
- (case input
- #.Nil
- (exception.throw ..empty_input [])
-
- (#.Cons [head tail])
- (#try.Success [tail head]))))
-
-(def: #export end!
- {#.doc "Ensures there are no more inputs."}
- (Parser Any)
- (.function (_ tokens)
- (case tokens
- #.Nil (#try.Success [tokens []])
- _ (exception.throw ..expected_empty_input [tokens]))))
-
-(def: #export end?
- {#.doc "Checks whether there are no more inputs."}
- (Parser Bit)
- (.function (_ tokens)
- (#try.Success [tokens (case tokens
- #.Nil true
- _ false)])))
-
-(template [<query> <assertion> <tag> <type> <eq>]
- [(def: #export <query>
- (Parser <type>)
- (.function (_ input)
- (case input
- (^ (list& (<tag> x) input'))
- (#try.Success [input' x])
-
- _
- (exception.throw ..cannot_parse input))))
-
- (def: #export (<assertion> expected)
- (-> <type> (Parser Any))
- (.function (_ input)
- (case input
- (^ (list& (<tag> actual) input'))
- (if (\ <eq> = expected actual)
- (#try.Success [input' []])
- (exception.throw ..cannot_parse input))
-
- _
- (exception.throw ..cannot_parse input))))]
-
- [bit bit! /.bit Bit bit.equivalence]
- [i64 i64! /.i64 (I64 Any) i64.equivalence]
- [f64 f64! /.f64 Frac frac.equivalence]
- [text text! /.text Text text.equivalence]
- [local local! /.variable/local Nat n.equivalence]
- [foreign foreign! /.variable/foreign Nat n.equivalence]
- [constant constant! /.constant Name name.equivalence]
- )
-
-(def: #export (tuple parser)
- (All [a] (-> (Parser a) (Parser a)))
- (.function (_ input)
- (case input
- (^ (list& (/.tuple head) tail))
- (do try.monad
- [output (..run parser head)]
- (#try.Success [tail output]))
-
- _
- (exception.throw ..cannot_parse input))))
-
-(def: #export (function expected parser)
- (All [a] (-> Arity (Parser a) (Parser [(Environment Synthesis) a])))
- (.function (_ input)
- (case input
- (^ (list& (/.function/abstraction [environment actual body]) tail))
- (if (n.= expected actual)
- (do try.monad
- [output (..run parser (list body))]
- (#try.Success [tail [environment output]]))
- (exception.throw ..wrong_arity [expected actual]))
-
- _
- (exception.throw ..cannot_parse input))))
-
-(def: #export (loop init_parsers iteration_parser)
- (All [a b] (-> (Parser a) (Parser b) (Parser [Register a b])))
- (.function (_ input)
- (case input
- (^ (list& (/.loop/scope [start inits iteration]) tail))
- (do try.monad
- [inits (..run init_parsers inits)
- iteration (..run iteration_parser (list iteration))]
- (#try.Success [tail [start inits iteration]]))
-
- _
- (exception.throw ..cannot_parse input))))
diff --git a/stdlib/source/lux/control/parser/text.lux b/stdlib/source/lux/control/parser/text.lux
deleted file mode 100644
index 7dc6001b5..000000000
--- a/stdlib/source/lux/control/parser/text.lux
+++ /dev/null
@@ -1,376 +0,0 @@
-(.module:
- [lux (#- or and not)
- [abstract
- [monad (#+ Monad do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["/" text (#+ Char) ("#\." monoid)]
- ["." product]
- ["." maybe]
- [collection
- ["." list ("#\." fold)]]]
- [macro
- ["." code]]
- [math
- [number
- ["n" nat ("#\." decimal)]]]]
- ["." //])
-
-(type: #export Offset Nat)
-
-(def: start_offset Offset 0)
-
-(type: #export Parser
- (//.Parser [Offset Text]))
-
-(type: #export Slice
- {#basis Offset
- #distance Offset})
-
-(def: (remaining offset tape)
- (-> Offset Text Text)
- (|> tape (/.split offset) maybe.assume product.right))
-
-(exception: #export (unconsumed_input {offset Offset} {tape Text})
- (exception.report
- ["Offset" (n\encode offset)]
- ["Input size" (n\encode (/.size tape))]
- ["Remaining input" (remaining offset tape)]))
-
-(exception: #export (expected_to_fail {offset Offset} {tape Text})
- (exception.report
- ["Offset" (n\encode offset)]
- ["Input" (remaining offset tape)]))
-
-(exception: #export cannot_parse)
-(exception: #export cannot_slice)
-
-(def: #export (run parser input)
- (All [a] (-> (Parser a) Text (Try a)))
- (case (parser [start_offset input])
- (#try.Failure msg)
- (#try.Failure msg)
-
- (#try.Success [[end_offset _] output])
- (if (n.= end_offset (/.size input))
- (#try.Success output)
- (exception.throw ..unconsumed_input [end_offset input]))))
-
-(def: #export offset
- (Parser Offset)
- (function (_ (^@ input [offset tape]))
- (#try.Success [input offset])))
-
-(def: (with_slices parser)
- (-> (Parser (List Slice)) (Parser Slice))
- (do //.monad
- [offset ..offset
- slices parser]
- (wrap (list\fold (function (_ [slice::basis slice::distance]
- [total::basis total::distance])
- [total::basis ("lux i64 +" slice::distance total::distance)])
- {#basis offset
- #distance 0}
- slices))))
-
-(def: #export any
- {#.doc "Just returns the next character without applying any logic."}
- (Parser Text)
- (function (_ [offset tape])
- (case (/.nth offset tape)
- (#.Some output)
- (#try.Success [[("lux i64 +" 1 offset) tape] (/.from_code output)])
-
- _
- (exception.throw ..cannot_parse []))))
-
-(def: #export any!
- {#.doc "Just returns the next character without applying any logic."}
- (Parser Slice)
- (function (_ [offset tape])
- (case (/.nth offset tape)
- (#.Some _)
- (#try.Success [[("lux i64 +" 1 offset) tape]
- {#basis offset
- #distance 1}])
-
- _
- (exception.throw ..cannot_slice []))))
-
-(template [<name> <type> <any>]
- [(def: #export (<name> p)
- {#.doc "Produce a character if the parser fails."}
- (All [a] (-> (Parser a) (Parser <type>)))
- (function (_ input)
- (case (p input)
- (#try.Failure msg)
- (<any> input)
-
- _
- (exception.throw ..expected_to_fail input))))]
-
- [not Text ..any]
- [not! Slice ..any!]
- )
-
-(exception: #export (cannot_match {reference Text})
- (exception.report
- ["Reference" (/.format reference)]))
-
-(def: #export (this reference)
- {#.doc "Lex a text if it matches the given sample."}
- (-> Text (Parser Any))
- (function (_ [offset tape])
- (case (/.index_of' reference offset tape)
- (#.Some where)
- (if (n.= offset where)
- (#try.Success [[("lux i64 +" (/.size reference) offset) tape]
- []])
- (exception.throw ..cannot_match [reference]))
-
- _
- (exception.throw ..cannot_match [reference]))))
-
-(def: #export end!
- {#.doc "Ensure the parser's input is empty."}
- (Parser Any)
- (function (_ (^@ input [offset tape]))
- (if (n.= offset (/.size tape))
- (#try.Success [input []])
- (exception.throw ..unconsumed_input input))))
-
-(def: #export peek
- {#.doc "Lex the next character (without consuming it from the input)."}
- (Parser Text)
- (function (_ (^@ input [offset tape]))
- (case (/.nth offset tape)
- (#.Some output)
- (#try.Success [input (/.from_code output)])
-
- _
- (exception.throw ..cannot_parse []))))
-
-(def: #export get_input
- {#.doc "Get all of the remaining input (without consuming it)."}
- (Parser Text)
- (function (_ (^@ input [offset tape]))
- (#try.Success [input (remaining offset tape)])))
-
-(def: #export (range bottom top)
- {#.doc "Only lex characters within a range."}
- (-> Nat Nat (Parser Text))
- (do //.monad
- [char any
- #let [char' (maybe.assume (/.nth 0 char))]
- _ (//.assert ($_ /\compose "Character is not within range: " (/.from_code bottom) "-" (/.from_code top))
- (.and (n.>= bottom char')
- (n.<= top char')))]
- (wrap char)))
-
-(template [<name> <bottom> <top> <desc>]
- [(def: #export <name>
- {#.doc (code.text ($_ /\compose "Only lex " <desc> " characters."))}
- (Parser Text)
- (..range (char <bottom>) (char <top>)))]
-
- [upper "A" "Z" "uppercase"]
- [lower "a" "z" "lowercase"]
- [decimal "0" "9" "decimal"]
- [octal "0" "7" "octal"]
- )
-
-(def: #export alpha
- {#.doc "Only lex alphabetic characters."}
- (Parser Text)
- (//.either lower upper))
-
-(def: #export alpha_num
- {#.doc "Only lex alphanumeric characters."}
- (Parser Text)
- (//.either alpha decimal))
-
-(def: #export hexadecimal
- {#.doc "Only lex hexadecimal digits."}
- (Parser Text)
- ($_ //.either
- decimal
- (range (char "a") (char "f"))
- (range (char "A") (char "F"))))
-
-(template [<name>]
- [(exception: #export (<name> {options Text} {character Char})
- (exception.report
- ["Options" (/.format options)]
- ["Character" (/.format (/.from_code character))]))]
-
- [character_should_be]
- [character_should_not_be]
- )
-
-(template [<name> <modifier> <exception> <description_modifier>]
- [(def: #export (<name> options)
- {#.doc (code.text ($_ /\compose "Only lex characters that are" <description_modifier> " part of a piece of text."))}
- (-> Text (Parser Text))
- (function (_ [offset tape])
- (case (/.nth offset tape)
- (#.Some output)
- (let [output' (/.from_code output)]
- (if (<modifier> (/.contains? output' options))
- (#try.Success [[("lux i64 +" 1 offset) tape] output'])
- (exception.throw <exception> [options output])))
-
- _
- (exception.throw ..cannot_parse []))))]
-
- [one_of |> ..character_should_be ""]
- [none_of .not ..character_should_not_be " not"]
- )
-
-(template [<name> <modifier> <exception> <description_modifier>]
- [(def: #export (<name> options)
- {#.doc (code.text ($_ /\compose "Only lex characters that are" <description_modifier> " part of a piece of text."))}
- (-> Text (Parser Slice))
- (function (_ [offset tape])
- (case (/.nth offset tape)
- (#.Some output)
- (let [output' (/.from_code output)]
- (if (<modifier> (/.contains? output' options))
- (#try.Success [[("lux i64 +" 1 offset) tape]
- {#basis offset
- #distance 1}])
- (exception.throw <exception> [options output])))
-
- _
- (exception.throw ..cannot_slice []))))]
-
- [one_of! |> ..character_should_be ""]
- [none_of! .not ..character_should_not_be " not"]
- )
-
-(exception: #export (character_does_not_satisfy_predicate {character Char})
- (exception.report
- ["Character" (/.format (/.from_code character))]))
-
-(def: #export (satisfies p)
- {#.doc "Only lex characters that satisfy a predicate."}
- (-> (-> Char Bit) (Parser Text))
- (function (_ [offset tape])
- (case (/.nth offset tape)
- (#.Some output)
- (if (p output)
- (#try.Success [[("lux i64 +" 1 offset) tape] (/.from_code output)])
- (exception.throw ..character_does_not_satisfy_predicate [output]))
-
- _
- (exception.throw ..cannot_parse []))))
-
-(def: #export space
- {#.doc "Only lex white-space."}
- (Parser Text)
- (..satisfies /.space?))
-
-(def: #export (and left right)
- (-> (Parser Text) (Parser Text) (Parser Text))
- (do //.monad
- [=left left
- =right right]
- (wrap ($_ /\compose =left =right))))
-
-(def: #export (and! left right)
- (-> (Parser Slice) (Parser Slice) (Parser Slice))
- (do //.monad
- [[left::basis left::distance] left
- [right::basis right::distance] right]
- (wrap [left::basis ("lux i64 +" left::distance right::distance)])))
-
-(template [<name> <base> <doc_modifier>]
- [(def: #export (<name> parser)
- {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " characters as a single continuous text."))}
- (-> (Parser Text) (Parser Text))
- (|> parser <base> (\ //.monad map /.concat)))]
-
- [some //.some "some"]
- [many //.many "many"]
- )
-
-(template [<name> <base> <doc_modifier>]
- [(def: #export (<name> parser)
- {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " characters as a single continuous text."))}
- (-> (Parser Slice) (Parser Slice))
- (with_slices (<base> parser)))]
-
- [some! //.some "some"]
- [many! //.many "many"]
- )
-
-(template [<name> <base> <doc_modifier>]
- [(def: #export (<name> amount parser)
- {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " N characters."))}
- (-> Nat (Parser Text) (Parser Text))
- (|> parser (<base> amount) (\ //.monad map /.concat)))]
-
- [exactly //.exactly "exactly"]
- [at_most //.at_most "at most"]
- [at_least //.at_least "at least"]
- )
-
-(template [<name> <base> <doc_modifier>]
- [(def: #export (<name> amount parser)
- {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " N characters."))}
- (-> Nat (Parser Slice) (Parser Slice))
- (with_slices (<base> amount parser)))]
-
- [exactly! //.exactly "exactly"]
- [at_most! //.at_most "at most"]
- [at_least! //.at_least "at least"]
- )
-
-(def: #export (between from to parser)
- {#.doc "Lex between N and M characters."}
- (-> Nat Nat (Parser Text) (Parser Text))
- (|> parser (//.between from to) (\ //.monad map /.concat)))
-
-(def: #export (between! from to parser)
- {#.doc "Lex between N and M characters."}
- (-> Nat Nat (Parser Slice) (Parser Slice))
- (with_slices (//.between from to parser)))
-
-(def: #export (enclosed [start end] parser)
- (All [a] (-> [Text Text] (Parser a) (Parser a)))
- (|> parser
- (//.before (this end))
- (//.after (this start))))
-
-(def: #export (local local_input parser)
- {#.doc "Run a parser with the given input, instead of the real one."}
- (All [a] (-> Text (Parser a) (Parser a)))
- (function (_ real_input)
- (case (..run parser local_input)
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success value)
- (#try.Success [real_input value]))))
-
-(def: #export (slice parser)
- (-> (Parser Slice) (Parser Text))
- (do //.monad
- [[basis distance] parser]
- (function (_ (^@ input [offset tape]))
- (case (/.clip basis distance tape)
- (#.Some output)
- (#try.Success [input output])
-
- #.None
- (exception.throw ..cannot_slice [])))))
-
-(def: #export (embed structured text)
- (All [s a]
- (-> (Parser a)
- (//.Parser s Text)
- (//.Parser s a)))
- (do //.monad
- [raw text]
- (//.lift (..run structured raw))))
diff --git a/stdlib/source/lux/control/parser/tree.lux b/stdlib/source/lux/control/parser/tree.lux
deleted file mode 100644
index ac824638a..000000000
--- a/stdlib/source/lux/control/parser/tree.lux
+++ /dev/null
@@ -1,59 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- [collection
- [tree (#+ Tree)
- ["." zipper (#+ Zipper)]]]]]
- ["." //])
-
-(type: #export (Parser t a)
- (//.Parser (Zipper t) a))
-
-(def: #export (run' parser zipper)
- (All [t a] (-> (Parser t a) (Zipper t) (Try a)))
- (do try.monad
- [[zipper output] (//.run parser zipper)]
- (wrap output)))
-
-(def: #export (run parser tree)
- (All [t a] (-> (Parser t a) (Tree t) (Try a)))
- (run' parser (zipper.zip tree)))
-
-(def: #export value
- (All [t] (Parser t t))
- (function (_ zipper)
- (#try.Success [zipper (zipper.value zipper)])))
-
-(exception: #export cannot-move-further)
-
-(template [<name> <direction>]
- [(def: #export <name>
- (All [t] (Parser t []))
- (function (_ zipper)
- (case (<direction> zipper)
- #.None
- (exception.throw ..cannot-move-further [])
-
- (#.Some next)
- (#try.Success [next []]))))]
-
- [down zipper.down]
- [up zipper.up]
-
- [right zipper.right]
- [rightmost zipper.rightmost]
-
- [left zipper.left]
- [leftmost zipper.leftmost]
-
- [next zipper.next]
- [end zipper.end]
-
- [previous zipper.previous]
- [start zipper.start]
- )
diff --git a/stdlib/source/lux/control/parser/type.lux b/stdlib/source/lux/control/parser/type.lux
deleted file mode 100644
index ce58c5ce3..000000000
--- a/stdlib/source/lux/control/parser/type.lux
+++ /dev/null
@@ -1,348 +0,0 @@
-(.module:
- [lux (#- function)
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." function]]
- [data
- ["." text ("#\." monoid)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]
- ["." dictionary (#+ Dictionary)]]]
- [macro
- ["." code]]
- [math
- [number
- ["n" nat ("#\." decimal)]]]
- ["." type ("#\." equivalence)
- ["." check]]]
- ["." //])
-
-(template [<name>]
- [(exception: #export (<name> {type Type})
- (exception.report
- ["Type" (%.type type)]))]
-
- [not_existential]
- [not_recursive]
- [not_named]
- [not_parameter]
- [unknown_parameter]
- [not_function]
- [not_application]
- [not_polymorphic]
- [not_variant]
- [not_tuple]
- )
-
-(template [<name>]
- [(exception: #export (<name> {expected Type} {actual Type})
- (exception.report
- ["Expected" (%.type expected)]
- ["Actual" (%.type actual)]))]
-
- [types_do_not_match]
- [wrong_parameter]
- )
-
-(exception: #export empty_input)
-
-(exception: #export (unconsumed_input {remaining (List Type)})
- (exception.report
- ["Types" (|> remaining
- (list\map (|>> %.type (format text.new_line "* ")))
- (text.join_with ""))]))
-
-(type: #export Env
- (Dictionary Nat [Type Code]))
-
-(type: #export (Parser a)
- (//.Parser [Env (List Type)] a))
-
-(def: #export fresh
- Env
- (dictionary.new n.hash))
-
-(def: (run' env poly types)
- (All [a] (-> Env (Parser a) (List Type) (Try a)))
- (case (//.run poly [env types])
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success [[env' remaining] output])
- (case remaining
- #.Nil
- (#try.Success output)
-
- _
- (exception.throw ..unconsumed_input remaining))))
-
-(def: #export (run poly type)
- (All [a] (-> (Parser a) Type (Try a)))
- (run' ..fresh poly (list type)))
-
-(def: #export env
- (Parser Env)
- (.function (_ [env inputs])
- (#try.Success [[env inputs] env])))
-
-(def: (with_env temp poly)
- (All [a] (-> Env (Parser a) (Parser a)))
- (.function (_ [env inputs])
- (case (//.run poly [temp inputs])
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success [[_ remaining] output])
- (#try.Success [[env remaining] output]))))
-
-(def: #export peek
- (Parser Type)
- (.function (_ [env inputs])
- (case inputs
- #.Nil
- (exception.throw ..empty_input [])
-
- (#.Cons headT tail)
- (#try.Success [[env inputs] headT]))))
-
-(def: #export any
- (Parser Type)
- (.function (_ [env inputs])
- (case inputs
- #.Nil
- (exception.throw ..empty_input [])
-
- (#.Cons headT tail)
- (#try.Success [[env tail] headT]))))
-
-(def: #export (local types poly)
- (All [a] (-> (List Type) (Parser a) (Parser a)))
- (.function (_ [env pass_through])
- (case (run' env poly types)
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success output)
- (#try.Success [[env pass_through] output]))))
-
-(def: (label idx)
- (-> Nat Code)
- (code.local_identifier ($_ text\compose "label" text.tab (n\encode idx))))
-
-(def: #export (with_extension type poly)
- (All [a] (-> Type (Parser a) (Parser [Code a])))
- (.function (_ [env inputs])
- (let [current_id (dictionary.size env)
- g!var (label current_id)]
- (case (//.run poly
- [(dictionary.put current_id [type g!var] env)
- inputs])
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success [[_ inputs'] output])
- (#try.Success [[env inputs'] [g!var output]])))))
-
-(template [<name> <flattener> <tag> <exception>]
- [(def: #export (<name> poly)
- (All [a] (-> (Parser a) (Parser a)))
- (do //.monad
- [headT ..any]
- (let [members (<flattener> (type.un_name headT))]
- (if (n.> 1 (list.size members))
- (local members poly)
- (//.fail (exception.construct <exception> headT))))))]
-
- [variant type.flatten_variant #.Sum ..not_variant]
- [tuple type.flatten_tuple #.Product ..not_tuple]
- )
-
-(def: polymorphic'
- (Parser [Nat Type])
- (do //.monad
- [headT any
- #let [[num_arg bodyT] (type.flatten_univ_q (type.un_name headT))]]
- (if (n.= 0 num_arg)
- (//.fail (exception.construct ..not_polymorphic headT))
- (wrap [num_arg bodyT]))))
-
-(def: #export (polymorphic poly)
- (All [a] (-> (Parser a) (Parser [Code (List Code) a])))
- (do {! //.monad}
- [headT any
- funcI (\ ! map dictionary.size ..env)
- [num_args non_poly] (local (list headT) ..polymorphic')
- env ..env
- #let [funcL (label funcI)
- [all_varsL env'] (loop [current_arg 0
- env' env
- all_varsL (: (List Code) (list))]
- (if (n.< num_args current_arg)
- (if (n.= 0 current_arg)
- (let [varL (label (inc funcI))]
- (recur (inc current_arg)
- (|> env'
- (dictionary.put funcI [headT funcL])
- (dictionary.put (inc funcI) [(#.Parameter (inc funcI)) varL]))
- (#.Cons varL all_varsL)))
- (let [partialI (|> current_arg (n.* 2) (n.+ funcI))
- partial_varI (inc partialI)
- partial_varL (label partial_varI)
- partialC (` ((~ funcL) (~+ (|> (list.indices num_args)
- (list\map (|>> (n.* 2) inc (n.+ funcI) label))
- list.reverse))))]
- (recur (inc current_arg)
- (|> env'
- (dictionary.put partialI [.Nothing partialC])
- (dictionary.put partial_varI [(#.Parameter partial_varI) partial_varL]))
- (#.Cons partial_varL all_varsL))))
- [all_varsL env']))]]
- (<| (with_env env')
- (local (list non_poly))
- (do !
- [output poly]
- (wrap [funcL all_varsL output])))))
-
-(def: #export (function in_poly out_poly)
- (All [i o] (-> (Parser i) (Parser o) (Parser [i o])))
- (do //.monad
- [headT any
- #let [[inputsT outputT] (type.flatten_function (type.un_name headT))]]
- (if (n.> 0 (list.size inputsT))
- (//.and (local inputsT in_poly)
- (local (list outputT) out_poly))
- (//.fail (exception.construct ..not_function headT)))))
-
-(def: #export (apply poly)
- (All [a] (-> (Parser a) (Parser a)))
- (do //.monad
- [headT any
- #let [[funcT paramsT] (type.flatten_application (type.un_name headT))]]
- (if (n.= 0 (list.size paramsT))
- (//.fail (exception.construct ..not_application headT))
- (..local (#.Cons funcT paramsT) poly))))
-
-(template [<name> <test>]
- [(def: #export (<name> expected)
- (-> Type (Parser Any))
- (do //.monad
- [actual any]
- (if (<test> expected actual)
- (wrap [])
- (//.fail (exception.construct ..types_do_not_match [expected actual])))))]
-
- [exactly type\=]
- [sub check.checks?]
- [super (function.flip check.checks?)]
- )
-
-(def: #export (adjusted_idx env idx)
- (-> Env Nat Nat)
- (let [env_level (n./ 2 (dictionary.size env))
- parameter_level (n./ 2 idx)
- parameter_idx (n.% 2 idx)]
- (|> env_level dec (n.- parameter_level) (n.* 2) (n.+ parameter_idx))))
-
-(def: #export parameter
- (Parser Code)
- (do //.monad
- [env ..env
- headT any]
- (case headT
- (#.Parameter idx)
- (case (dictionary.get (adjusted_idx env idx) env)
- (#.Some [poly_type poly_code])
- (wrap poly_code)
-
- #.None
- (//.fail (exception.construct ..unknown_parameter headT)))
-
- _
- (//.fail (exception.construct ..not_parameter headT)))))
-
-(def: #export (parameter! id)
- (-> Nat (Parser Any))
- (do //.monad
- [env ..env
- headT any]
- (case headT
- (#.Parameter idx)
- (if (n.= id (adjusted_idx env idx))
- (wrap [])
- (//.fail (exception.construct ..wrong_parameter [(#.Parameter id) headT])))
-
- _
- (//.fail (exception.construct ..not_parameter headT)))))
-
-(def: #export existential
- (Parser Nat)
- (do //.monad
- [headT any]
- (case headT
- (#.Ex ex_id)
- (wrap ex_id)
-
- _
- (//.fail (exception.construct ..not_existential headT)))))
-
-(def: #export named
- (Parser [Name Type])
- (do //.monad
- [inputT any]
- (case inputT
- (#.Named name anonymousT)
- (wrap [name anonymousT])
-
- _
- (//.fail (exception.construct ..not_named inputT)))))
-
-(template: (|nothing|)
- (#.Named ["lux" "Nothing"]
- (#.UnivQ #.Nil
- (#.Parameter 1))))
-
-(def: #export (recursive poly)
- (All [a] (-> (Parser a) (Parser [Code a])))
- (do {! //.monad}
- [headT any]
- (case (type.un_name headT)
- (^ (#.Apply (|nothing|) (#.UnivQ _ headT')))
- (do !
- [[recT _ output] (|> poly
- (with_extension .Nothing)
- (with_extension headT)
- (local (list headT')))]
- (wrap [recT output]))
-
- _
- (//.fail (exception.construct ..not_recursive headT)))))
-
-(def: #export recursive_self
- (Parser Code)
- (do //.monad
- [env ..env
- headT any]
- (case (type.un_name headT)
- (^multi (^ (#.Apply (|nothing|) (#.Parameter funcT_idx)))
- (n.= 0 (adjusted_idx env funcT_idx))
- [(dictionary.get 0 env) (#.Some [self_type self_call])])
- (wrap self_call)
-
- _
- (//.fail (exception.construct ..not_recursive headT)))))
-
-(def: #export recursive_call
- (Parser Code)
- (do {! //.monad}
- [env ..env
- [funcT argsT] (..apply (//.and any (//.many any)))
- _ (local (list funcT) (..parameter! 0))
- allC (let [allT (list& funcT argsT)]
- (|> allT
- (monad.map ! (function.constant ..parameter))
- (local allT)))]
- (wrap (` ((~+ allC))))))
diff --git a/stdlib/source/lux/control/parser/xml.lux b/stdlib/source/lux/control/parser/xml.lux
deleted file mode 100644
index 9eb794c2d..000000000
--- a/stdlib/source/lux/control/parser/xml.lux
+++ /dev/null
@@ -1,141 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try) ("#\." functor)]
- ["." exception (#+ exception:)]]
- [data
- ["." name ("#\." equivalence codec)]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list]
- ["." dictionary]]
- [format
- ["/" xml (#+ Attribute Attrs Tag XML)]]]]
- ["." //])
-
-(type: #export (Parser a)
- (//.Parser [Attrs (List XML)] a))
-
-(exception: #export empty_input)
-(exception: #export unexpected_input)
-
-(exception: #export (wrong_tag {expected Tag} {actual Tag})
- (exception.report
- ["Expected" (%.text (/.tag expected))]
- ["Actual" (%.text (/.tag actual))]))
-
-(exception: #export (unknown_attribute {expected Attribute} {available (List Attribute)})
- (exception.report
- ["Expected" (%.text (/.attribute expected))]
- ["Available" (exception.enumerate (|>> /.attribute %.text) available)]))
-
-(exception: #export (unconsumed_inputs {inputs (List XML)})
- (exception.report
- ["Inputs" (exception.enumerate (\ /.codec encode) inputs)]))
-
-(def: (run' parser attrs documents)
- (All [a] (-> (Parser a) Attrs (List XML) (Try a)))
- (case (//.run parser [attrs documents])
- (#try.Success [[attrs' remaining] output])
- (if (list.empty? remaining)
- (#try.Success output)
- (exception.throw ..unconsumed_inputs remaining))
-
- (#try.Failure error)
- (#try.Failure error)))
-
-(def: #export (run parser documents)
- (All [a] (-> (Parser a) (List XML) (Try a)))
- (..run' parser /.attributes documents))
-
-(def: #export text
- (Parser Text)
- (function (_ [attrs documents])
- (case documents
- #.Nil
- (exception.throw ..empty_input [])
-
- (#.Cons head tail)
- (case head
- (#/.Text value)
- (#try.Success [[attrs tail] value])
-
- (#/.Node _)
- (exception.throw ..unexpected_input [])))))
-
-(def: #export tag
- (Parser Tag)
- (function (_ [attrs documents])
- (case documents
- #.Nil
- (exception.throw ..empty_input [])
-
- (#.Cons head _)
- (case head
- (#/.Text _)
- (exception.throw ..unexpected_input [])
-
- (#/.Node tag _ _)
- (#try.Success [[attrs documents] tag])))))
-
-(def: #export (attribute name)
- (-> Attribute (Parser Text))
- (function (_ [attrs documents])
- (case (dictionary.get name attrs)
- #.None
- (exception.throw ..unknown_attribute [name (dictionary.keys attrs)])
-
- (#.Some value)
- (#try.Success [[attrs documents] value]))))
-
-(def: #export (node expected parser)
- (All [a] (-> Tag (Parser a) (Parser a)))
- (function (_ [attrs documents])
- (case documents
- #.Nil
- (exception.throw ..empty_input [])
-
- (#.Cons head tail)
- (case head
- (#/.Text _)
- (exception.throw ..unexpected_input [])
-
- (#/.Node actual attrs' children)
- (if (name\= expected actual)
- (|> children
- (..run' parser attrs')
- (try\map (|>> [[attrs tail]])))
- (exception.throw ..wrong_tag [expected actual]))))))
-
-(def: #export ignore
- (Parser Any)
- (function (_ [attrs documents])
- (case documents
- #.Nil
- (exception.throw ..empty_input [])
-
- (#.Cons head tail)
- (#try.Success [[attrs tail] []]))))
-
-(exception: #export nowhere)
-
-(def: #export (somewhere parser)
- (All [a] (-> (Parser a) (Parser a)))
- (function (recur [attrs input])
- (case (//.run parser [attrs input])
- (#try.Success [[attrs remaining] output])
- (#try.Success [[attrs remaining] output])
-
- (#try.Failure error)
- (case input
- #.Nil
- (exception.throw ..nowhere [])
-
- (#.Cons head tail)
- (do try.monad
- [[[attrs tail'] output] (recur [attrs tail])]
- (wrap [[attrs (#.Cons head tail')]
- output]))))))
diff --git a/stdlib/source/lux/control/pipe.lux b/stdlib/source/lux/control/pipe.lux
deleted file mode 100644
index 3453b1779..000000000
--- a/stdlib/source/lux/control/pipe.lux
+++ /dev/null
@@ -1,160 +0,0 @@
-(.module: {#.doc "Composable extensions to the piping macros (|> and <|) that enhance them with various abilities."}
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["e" try]
- ["p" parser
- ["s" code (#+ Parser)]]]
- [data
- ["." identity]
- [collection
- ["." list ("#\." fold monad)]]]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number
- ["n" nat]
- ["i" int]]]])
-
-(def: body^
- (Parser (List Code))
- (s.tuple (p.some s.any)))
-
-(syntax: #export (new> start
- {body body^}
- prev)
- {#.doc (doc "Ignores the piped argument, and begins a new pipe."
- (n.= 1
- (|> 20
- (n.* 3)
- (n.+ 4)
- (new> 0 [inc]))))}
- (wrap (list (` (|> (~ start) (~+ body))))))
-
-(syntax: #export (let> binding body prev)
- {#.doc (doc "Gives a name to the piped-argument, within the given expression."
- (n.= 10
- (|> 5
- (let> x (n.+ x x)))))}
- (wrap (list (` (let [(~ binding) (~ prev)]
- (~ body))))))
-
-(def: _reverse_
- (Parser Any)
- (function (_ tokens)
- (#e.Success [(list.reverse tokens) []])))
-
-(syntax: #export (cond> {_ _reverse_}
- prev
- {else body^}
- {_ _reverse_}
- {branches (p.some (p.and body^ body^))})
- {#.doc (doc "Branching for pipes."
- "Both the tests and the bodies are piped-code, and must be given inside a tuple."
- (|> +5
- (cond> [i.even?] [(i.* +2)]
- [i.odd?] [(i.* +3)]
- [(new> -1 [])])))}
- (with_gensyms [g!temp]
- (wrap (list (` (let [(~ g!temp) (~ prev)]
- (cond (~+ (do list.monad
- [[test then] branches]
- (list (` (|> (~ g!temp) (~+ test)))
- (` (|> (~ g!temp) (~+ then))))))
- (|> (~ g!temp) (~+ else)))))))))
-
-(syntax: #export (if> {test body^} {then body^} {else body^} prev)
- (wrap (list (` (cond> [(~+ test)] [(~+ then)]
- [(~+ else)]
- (~ prev))))))
-
-(syntax: #export (when> {test body^} {then body^} prev)
- (wrap (list (` (cond> [(~+ test)] [(~+ then)]
- []
- (~ prev))))))
-
-(syntax: #export (loop> {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
- (loop> [(i.< +10)]
- [inc])))}
- (with_gensyms [g!temp]
- (wrap (list (` (loop [(~ g!temp) (~ prev)]
- (if (|> (~ g!temp) (~+ test))
- ((~' recur) (|> (~ g!temp) (~+ then)))
- (~ g!temp))))))))
-
-(syntax: #export (do> monad
- {steps (p.some body^)}
- prev)
- {#.doc (doc "Monadic pipes."
- "Each steps in the monadic computation is a pipe and must be given inside a tuple."
- (|> +5
- (do> identity.monad
- [(i.* +3)]
- [(i.+ +4)]
- [inc])))}
- (with_gensyms [g!temp]
- (case (list.reverse steps)
- (^ (list& last_step prev_steps))
- (let [step_bindings (do list.monad
- [step (list.reverse prev_steps)]
- (list g!temp (` (|> (~ g!temp) (~+ step)))))]
- (wrap (list (` ((~! do) (~ monad)
- [(~' #let) [(~ g!temp) (~ prev)]
- (~+ step_bindings)]
- (|> (~ g!temp) (~+ last_step)))))))
-
- _
- (wrap (list prev)))))
-
-(syntax: #export (exec> {body body^}
- prev)
- {#.doc (doc "Non-updating pipes."
- "Will generate piped computations, but their results will not be used in the larger scope."
- (|> +5
- (exec> [.nat %n log!])
- (i.* +10)))}
- (with_gensyms [g!temp]
- (wrap (list (` (let [(~ g!temp) (~ prev)]
- (exec (|> (~ g!temp) (~+ body))
- (~ g!temp))))))))
-
-(syntax: #export (tuple> {paths (p.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
- (tuple> [(i.* +10)]
- [dec (i./ +2)]
- [Int/encode]))
- "Will become: [+50 +2 '+5']")}
- (with_gensyms [g!temp]
- (wrap (list (` (let [(~ g!temp) (~ prev)]
- [(~+ (list\map (function (_ body) (` (|> (~ g!temp) (~+ body))))
- paths))]))))))
-
-(syntax: #export (case> {branches (p.many (p.and 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"
- _ "???")))}
- (wrap (list (` (case (~ prev)
- (~+ (list\join (list\map (function (_ [pattern body]) (list pattern body))
- branches))))))))
diff --git a/stdlib/source/lux/control/reader.lux b/stdlib/source/lux/control/reader.lux
deleted file mode 100644
index 615bdfe80..000000000
--- a/stdlib/source/lux/control/reader.lux
+++ /dev/null
@@ -1,71 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." functor (#+ Functor)]
- [apply (#+ Apply)]
- ["." monad (#+ Monad do)]]])
-
-(type: #export (Reader r a)
- {#.doc "Computations that have access to some environmental value."}
- (-> r a))
-
-(def: #export ask
- {#.doc "Get the environment."}
- (All [r] (Reader r r))
- (function (_ env) env))
-
-(def: #export (local change proc)
- {#.doc "Run computation with a locally-modified environment."}
- (All [r a] (-> (-> r r) (Reader r a) (Reader r a)))
- (|>> change proc))
-
-(def: #export (run env proc)
- (All [r a] (-> r (Reader r a) a))
- (proc env))
-
-(implementation: #export functor
- (All [r] (Functor (Reader r)))
-
- (def: (map f fa)
- (function (_ env)
- (f (fa env)))))
-
-(implementation: #export apply
- (All [r] (Apply (Reader r)))
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (function (_ env)
- ((ff env) (fa env)))))
-
-(implementation: #export monad
- (All [r] (Monad (Reader r)))
-
- (def: &functor ..functor)
-
- (def: (wrap x)
- (function (_ env) x))
-
- (def: (join mma)
- (function (_ env)
- (mma env env))))
-
-(implementation: #export (with monad)
- {#.doc "Monad transformer for Reader."}
- (All [M] (-> (Monad M) (All [e] (Monad (All [a] (Reader e (M a)))))))
-
- (def: &functor (functor.compose ..functor (get@ #monad.&functor monad)))
-
- (def: wrap (|>> (\ monad wrap) (\ ..monad wrap)))
-
- (def: (join eMeMa)
- (function (_ env)
- (do monad
- [eMa (run env eMeMa)]
- (run env eMa)))))
-
-(def: #export lift
- {#.doc "Lift monadic values to the Reader wrapper."}
- (All [M e a] (-> (M a) (Reader e (M a))))
- (\ ..monad wrap))
diff --git a/stdlib/source/lux/control/region.lux b/stdlib/source/lux/control/region.lux
deleted file mode 100644
index 5b2a6fef1..000000000
--- a/stdlib/source/lux/control/region.lux
+++ /dev/null
@@ -1,157 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- ["." monad (#+ Monad do)]]
- [control
- ["." try (#+ Try)]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." fold)]]]]
- [//
- ["." exception (#+ Exception exception:)]])
-
-(type: (Cleaner r !)
- (-> r (! (Try Any))))
-
-(type: #export (Region r ! a)
- (-> [r (List (Cleaner r !))]
- (! [(List (Cleaner r !))
- (Try a)])))
-
-(def: separator
- Text
- (format text.new_line
- "-----------------------------------------" text.new_line
- "-----------------------------------------" text.new_line
- "-----------------------------------------" text.new_line
- text.new_line))
-
-(exception: #export [a] (clean_up_error {error Text}
- {output (Try a)})
- (format error
- (case output
- (#try.Success _)
- ""
-
- (#try.Failure error|output)
- (format separator
- error|output))))
-
-(def: (combine_outcomes clean_up output)
- (All [a] (-> (Try Any) (Try a) (Try a)))
- (case clean_up
- (#try.Success _)
- output
-
- (#try.Failure error)
- (exception.throw ..clean_up_error [error output])))
-
-(def: #export (run monad computation)
- (All [! a]
- (-> (Monad !) (All [r] (Region r ! a))
- (! (Try a))))
- (do {! monad}
- [[cleaners output] (computation [[] (list)])
- results (monad.map ! (function (_ cleaner) (cleaner []))
- cleaners)]
- (wrap (list\fold combine_outcomes output results))))
-
-(def: #export (acquire monad cleaner value)
- (All [! a] (-> (Monad !) (-> a (! (Try Any))) a
- (All [r] (Region r ! a))))
- (function (_ [region cleaners])
- (\ monad wrap [(#.Cons (function (_ region) (cleaner value))
- cleaners)
- (#try.Success value)])))
-
-(implementation: #export (functor super)
- (All [!]
- (-> (Functor !)
- (All [r] (Functor (Region r !)))))
-
- (def: (map f)
- (function (_ fa)
- (function (_ region+cleaners)
- (\ super map
- (function (_ [cleaners' temp])
- [cleaners' (case temp
- (#try.Success value)
- (#try.Success (f value))
-
- (#try.Failure error)
- (#try.Failure error))])
- (fa region+cleaners))))))
-
-(implementation: #export (apply super)
- (All [!]
- (-> (Monad !)
- (All [r] (Apply (Region r !)))))
-
- (def: &functor
- (..functor (get@ #monad.&functor super)))
-
- (def: (apply ff fa)
- (function (_ [region cleaners])
- (do super
- [[cleaners ef] (ff [region cleaners])
- [cleaners ea] (fa [region cleaners])]
- (case ef
- (#try.Success f)
- (case ea
- (#try.Success a)
- (wrap [cleaners (#try.Success (f a))])
-
- (#try.Failure error)
- (wrap [cleaners (#try.Failure error)]))
-
- (#try.Failure error)
- (wrap [cleaners (#try.Failure error)]))))))
-
-(implementation: #export (monad super)
- (All [!]
- (-> (Monad !)
- (All [r] (Monad (Region r !)))))
-
- (def: &functor
- (..functor (get@ #monad.&functor super)))
-
- (def: (wrap value)
- (function (_ [region cleaners])
- (\ super wrap [cleaners (#try.Success value)])))
-
- (def: (join ffa)
- (function (_ [region cleaners])
- (do super
- [[cleaners efa] (ffa [region cleaners])]
- (case efa
- (#try.Success fa)
- (fa [region cleaners])
-
- (#try.Failure error)
- (wrap [cleaners (#try.Failure error)]))))))
-
-(def: #export (fail monad error)
- (All [! a]
- (-> (Monad !) Text
- (All [r] (Region r ! a))))
- (function (_ [region cleaners])
- (\ monad wrap [cleaners (#try.Failure error)])))
-
-(def: #export (throw monad exception message)
- (All [! e a]
- (-> (Monad !) (Exception e) e
- (All [r] (Region r ! a))))
- (fail monad (exception.construct exception message)))
-
-(def: #export (lift monad operation)
- (All [! a]
- (-> (Monad !) (! a)
- (All [r] (Region r ! a))))
- (function (_ [region cleaners])
- (do monad
- [output operation]
- (wrap [cleaners (#try.Success output)]))))
diff --git a/stdlib/source/lux/control/remember.lux b/stdlib/source/lux/control/remember.lux
deleted file mode 100644
index aeda22262..000000000
--- a/stdlib/source/lux/control/remember.lux
+++ /dev/null
@@ -1,73 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." io]
- ["." try]
- ["." exception (#+ exception:)]
- ["<>" parser ("#\." functor)
- ["<c>" code (#+ Parser)]]]
- [data
- ["." text
- ["%" format (#+ format)]]]
- [time
- ["." instant]
- ["." date (#+ Date) ("#\." order)]]
- ["." meta]
- [macro
- ["." code]
- [syntax (#+ syntax:)]]])
-
-(exception: #export (must_remember {deadline Date} {today Date} {message Text} {focus (Maybe Code)})
- (exception.report
- ["Deadline" (%.date deadline)]
- ["Today" (%.date today)]
- ["Message" message]
- ["Code" (case focus
- (#.Some focus)
- (%.code focus)
-
- #.None
- "")]))
-
-(def: deadline
- (Parser Date)
- ($_ <>.either
- (<>\map (|>> instant.from_millis instant.date)
- <c>.int)
- (do <>.monad
- [raw <c>.text]
- (case (\ date.codec decode raw)
- (#try.Success date)
- (wrap date)
-
- (#try.Failure message)
- (<>.fail message)))))
-
-(syntax: #export (remember {deadline ..deadline} {message <c>.text} {focus (<>.maybe <c>.any)})
- (let [now (io.run instant.now)
- today (instant.date now)]
- (if (date\< deadline today)
- (wrap (case focus
- (#.Some focus)
- (list focus)
-
- #.None
- (list)))
- (meta.fail (exception.construct ..must_remember [deadline today message focus])))))
-
-(template [<name> <message>]
- [(syntax: #export (<name> {deadline ..deadline} {message <c>.text} {focus (<>.maybe <c>.any)})
- (wrap (list (` (..remember (~ (code.text (%.date deadline)))
- (~ (code.text (format <message> " " message)))
- (~+ (case focus
- (#.Some focus)
- (list focus)
-
- #.None
- (list))))))))]
-
- [to_do "TODO"]
- [fix_me "FIXME"]
- )
diff --git a/stdlib/source/lux/control/security/capability.lux b/stdlib/source/lux/control/security/capability.lux
deleted file mode 100644
index db3e38c26..000000000
--- a/stdlib/source/lux/control/security/capability.lux
+++ /dev/null
@@ -1,70 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["<>" parser
- ["<c>" code]]
- ["." io (#+ IO)]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]]]
- [type
- abstract]
- ["." meta]
- ["." macro
- ["." code]
- [syntax (#+ syntax:)
- ["|.|" export]
- ["|.|" declaration]
- ["|.|" annotations]]]])
-
-(abstract: #export (Capability brand input output)
- (-> input output)
-
- {#.doc (doc "Represents the capability to perform an operation."
- "This operation is assumed to have security implications.")}
-
- (def: forge
- (All [brand input output]
- (-> (-> input output)
- (Capability brand input output)))
- (|>> :abstraction))
-
- (def: #export (use capability input)
- (All [brand input output]
- (-> (Capability brand input output)
- input
- output))
- ((:representation capability) input))
-
- (syntax: #export (capability: {export |export|.parser}
- {declaration |declaration|.parser}
- {annotations (<>.maybe |annotations|.parser)}
- {[forge input output] (<c>.form ($_ <>.and <c>.local_identifier <c>.any <c>.any))})
- (do {! meta.monad}
- [this_module meta.current_module_name
- #let [[name vars] declaration]
- g!brand (\ ! map (|>> %.code code.text)
- (macro.gensym (format (%.name [this_module name]))))
- #let [capability (` (..Capability (.primitive (~ g!brand)) (~ input) (~ output)))]]
- (wrap (list (` (type: (~+ (|export|.format export))
- (~ (|declaration|.format declaration))
- (~ capability)))
- (` (def: (~ (code.local_identifier forge))
- (All [(~+ (list\map code.local_identifier vars))]
- (-> (-> (~ input) (~ output))
- (~ capability)))
- (~! ..forge)))
- ))))
-
- (def: #export (async capability)
- (All [brand input output]
- (-> (Capability brand input (IO output))
- (Capability brand input (Promise output))))
- (..forge (|>> ((:representation capability)) promise.future)))
- )
diff --git a/stdlib/source/lux/control/security/policy.lux b/stdlib/source/lux/control/security/policy.lux
deleted file mode 100644
index 1d3c0e43e..000000000
--- a/stdlib/source/lux/control/security/policy.lux
+++ /dev/null
@@ -1,92 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- [monad (#+ Monad)]]
- [type
- abstract]])
-
-(abstract: #export (Policy brand value label)
- value
-
- (type: #export (Can_Upgrade brand label value)
- {#.doc (doc "Represents the capacity to 'upgrade' a value.")}
- (-> value (Policy brand value label)))
-
- (type: #export (Can_Downgrade brand label value)
- {#.doc (doc "Represents the capacity to 'downgrade' a value.")}
- (-> (Policy brand value label) value))
-
- (type: #export (Privilege brand label)
- {#.doc (doc "Represents the privilege to both 'upgrade' and 'downgrade' a value.")}
- {#can_upgrade (Can_Upgrade brand label)
- #can_downgrade (Can_Downgrade brand label)})
-
- (def: privilege
- Privilege
- {#can_upgrade (|>> :abstraction)
- #can_downgrade (|>> :representation)})
-
- (type: #export (Delegation brand from to)
- {#.doc (doc "Represents the act of delegating policy capacities.")}
- (All [value]
- (-> (Policy brand value from)
- (Policy brand value to))))
-
- (def: #export (delegation downgrade upgrade)
- {#.doc (doc "Delegating policy capacities.")}
- (All [brand from to]
- (-> (Can_Downgrade brand from) (Can_Upgrade brand to)
- (Delegation brand from to)))
- (|>> downgrade upgrade))
-
- (type: #export (Context brand scope label)
- {#.doc (doc "A computational context with an associated policy privilege.")}
- (-> (Privilege brand label)
- (scope label)))
-
- (def: #export (with_policy context)
- (All [brand scope]
- (Ex [label]
- (-> (Context brand scope label)
- (scope label))))
- (context ..privilege))
-
- (def: (decorate constructor)
- (-> Type Type)
- (type (All [brand label] (constructor (All [value] (Policy brand value label))))))
-
- (implementation: #export functor
- (:~ (decorate Functor))
-
- (def: (map f fa)
- (|> fa :representation f :abstraction)))
-
- (implementation: #export apply
- (:~ (decorate Apply))
-
- (def: &functor ..functor)
- (def: (apply ff fa)
- (:abstraction ((:representation ff) (:representation fa)))))
-
- (implementation: #export monad
- (:~ (decorate Monad))
-
- (def: &functor ..functor)
- (def: wrap (|>> :abstraction))
- (def: join (|>> :representation)))
- )
-
-(template [<brand> <value> <upgrade> <downgrade>]
- [(abstract: #export <brand>
- Any
-
- (type: #export <value> (Policy <brand>))
- (type: #export <upgrade> (Can_Upgrade <brand>))
- (type: #export <downgrade> (Can_Downgrade <brand>))
- )]
-
- [Privacy Private Can_Conceal Can_Reveal]
- [Safety Safe Can_Trust Can_Distrust]
- )
diff --git a/stdlib/source/lux/control/state.lux b/stdlib/source/lux/control/state.lux
deleted file mode 100644
index 0914f5dde..000000000
--- a/stdlib/source/lux/control/state.lux
+++ /dev/null
@@ -1,148 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- [monad (#+ Monad do)]]])
-
-(type: #export (State s a)
- {#.doc "Stateful computations."}
- (-> s [s a]))
-
-(def: #export get
- {#.doc "Read the current state."}
- (All [s] (State s s))
- (function (_ state)
- [state state]))
-
-(def: #export (put new-state)
- {#.doc "Set the new state."}
- (All [s] (-> s (State s Any)))
- (function (_ state)
- [new-state []]))
-
-(def: #export (update change)
- {#.doc "Compute the new state."}
- (All [s] (-> (-> s s) (State s Any)))
- (function (_ state)
- [(change state) []]))
-
-(def: #export (use user)
- {#.doc "Run function on current state."}
- (All [s a] (-> (-> s a) (State s a)))
- (function (_ 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)))
- (function (_ state)
- (let [[state' output] (action (change state))]
- [state output])))
-
-(def: #export (run state action)
- {#.doc "Run a stateful computation."}
- (All [s a] (-> s (State s a) [s a]))
- (action state))
-
-(implementation: #export functor
- (All [s] (Functor (State s)))
-
- (def: (map f ma)
- (function (_ state)
- (let [[state' a] (ma state)]
- [state' (f a)]))))
-
-(implementation: #export apply
- (All [s] (Apply (State s)))
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (function (_ state)
- (let [[state' f] (ff state)
- [state'' a] (fa state')]
- [state'' (f a)]))))
-
-(implementation: #export monad
- (All [s] (Monad (State s)))
-
- (def: &functor ..functor)
-
- (def: (wrap a)
- (function (_ state)
- [state a]))
-
- (def: (join mma)
- (function (_ state)
- (let [[state' ma] (mma state)]
- (ma state')))))
-
-(def: #export (while condition body)
- (All [s] (-> (State s Bit) (State s Any) (State s Any)))
- (do {! ..monad}
- [execute? condition]
- (if execute?
- (do !
- [_ body]
- (while condition body))
- (wrap []))))
-
-(def: #export (do-while condition body)
- (All [s] (-> (State s Bit) (State s Any) (State s Any)))
- (do ..monad
- [_ body]
- (while condition body)))
-
-(implementation: (with//functor functor)
- (All [M s] (-> (Functor M) (Functor (All [a] (-> s (M [s a]))))))
-
- (def: (map f sfa)
- (function (_ state)
- (\ functor map (function (_ [s a]) [s (f a)])
- (sfa state)))))
-
-(implementation: (with//apply monad)
- (All [M s] (-> (Monad M) (Apply (All [a] (-> s (M [s a]))))))
-
- (def: &functor (with//functor (\ monad &functor)))
-
- (def: (apply sFf sFa)
- (function (_ state)
- (do monad
- [[state f] (sFf state)
- [state a] (sFa state)]
- (wrap [state (f a)])))))
-
-(type: #export (State' M s a)
- {#.doc "Stateful computations decorated by a monad."}
- (-> s (M [s a])))
-
-(def: #export (run' state action)
- {#.doc "Run a stateful computation decorated by a monad."}
- (All [M s a] (-> s (State' M s a) (M [s a])))
- (action state))
-
-(implementation: #export (with monad)
- {#.doc "A monad transformer to create composite stateful computations."}
- (All [M s] (-> (Monad M) (Monad (State' M s))))
-
- (def: &functor (with//functor (\ monad &functor)))
-
- (def: (wrap a)
- (function (_ state)
- (\ monad wrap [state a])))
-
- (def: (join sMsMa)
- (function (_ state)
- (do monad
- [[state' sMa] (sMsMa state)]
- (sMa state')))))
-
-(def: #export (lift monad ma)
- {#.doc "Lift monadic values to the State' wrapper."}
- (All [M s a] (-> (Monad M) (M a) (State' M s a)))
- (function (_ state)
- (do monad
- [a ma]
- (wrap [state a]))))
diff --git a/stdlib/source/lux/control/thread.lux b/stdlib/source/lux/control/thread.lux
deleted file mode 100644
index 153fdc0ba..000000000
--- a/stdlib/source/lux/control/thread.lux
+++ /dev/null
@@ -1,105 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- [abstract
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- [monad (#+ Monad do)]]
- [control
- ["." io (#+ IO)]]
- [data
- [collection
- ["." array (#+ Array)]]]
- [type
- abstract]])
-
-(type: #export (Thread ! a)
- (-> ! a))
-
-(abstract: #export (Box t v)
- (Array v)
-
- {#.doc "A mutable box holding a value."}
-
- (def: #export (box init)
- (All [a] (-> a (All [!] (Thread ! (Box ! a)))))
- (function (_ !)
- (|> (array.new 1)
- (array.write! 0 init)
- :abstraction)))
-
- (def: #export (read box)
- (All [! a] (-> (Box ! a) (Thread ! a)))
- (function (_ !)
- (for {@.old
- ("jvm aaload" (:representation box) 0)
-
- @.jvm
- ("jvm array read object"
- (|> 0
- (:as (primitive "java.lang.Long"))
- "jvm object cast"
- "jvm conversion long-to-int")
- (:representation box))
-
- @.js ("js array read" 0 (:representation box))
- @.python ("python array read" 0 (:representation box))
- @.lua ("lua array read" 0 (:representation box))
- @.ruby ("ruby array read" 0 (:representation box))
- @.php ("php array read" 0 (:representation box))
- @.scheme ("scheme array read" 0 (:representation box))})))
-
- (def: #export (write value box)
- (All [a] (-> a (All [!] (-> (Box ! a) (Thread ! Any)))))
- (function (_ !)
- (|> box :representation (array.write! 0 value) :abstraction)))
- )
-
-(def: #export (run thread)
- (All [a]
- (-> (All [!] (Thread ! a))
- a))
- (thread []))
-
-(def: #export io
- (All [a]
- (-> (All [!] (Thread ! a))
- (IO a)))
- (|>> ..run io.io))
-
-(implementation: #export functor
- (All [!] (Functor (Thread !)))
-
- (def: (map f)
- (function (_ fa)
- (function (_ !)
- (f (fa !))))))
-
-(implementation: #export apply
- (All [!] (Apply (Thread !)))
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (function (_ !)
- ((ff !) (fa !)))))
-
-(implementation: #export monad
- (All [!] (Monad (Thread !)))
-
- (def: &functor ..functor)
-
- (def: (wrap value)
- (function (_ !)
- value))
-
- (def: (join ffa)
- (function (_ !)
- ((ffa !) !))))
-
-(def: #export (update f box)
- (All [a] (-> (-> a a) (All [!] (-> (Box ! a) (Thread ! a)))))
- (do ..monad
- [old (read box)
- _ (write (f old) box)]
- (wrap old)))
diff --git a/stdlib/source/lux/control/try.lux b/stdlib/source/lux/control/try.lux
deleted file mode 100644
index e60068cb1..000000000
--- a/stdlib/source/lux/control/try.lux
+++ /dev/null
@@ -1,151 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [apply (#+ Apply)]
- [equivalence (#+ Equivalence)]
- ["." functor (#+ Functor)]
- ["." monad (#+ Monad do)]]
- [meta
- ["." location]]])
-
-(type: #export (Try a)
- (#Failure Text)
- (#Success a))
-
-(implementation: #export functor
- (Functor Try)
-
- (def: (map f ma)
- (case ma
- (#Failure msg)
- (#Failure msg)
-
- (#Success datum)
- (#Success (f datum)))))
-
-(implementation: #export apply
- (Apply Try)
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (case ff
- (#Success f)
- (case fa
- (#Success a)
- (#Success (f a))
-
- (#Failure msg)
- (#Failure msg))
-
- (#Failure msg)
- (#Failure msg))
- ))
-
-(implementation: #export monad
- (Monad Try)
-
- (def: &functor ..functor)
-
- (def: (wrap a)
- (#Success a))
-
- (def: (join mma)
- (case mma
- (#Failure msg)
- (#Failure msg)
-
- (#Success ma)
- ma)))
-
-(implementation: #export (with monad)
- ## TODO: Replace (All [a] (M (Try a))) with (functor.Then M Try)
- (All [M] (-> (Monad M) (Monad (All [a] (M (Try a))))))
-
- (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor))
-
- (def: wrap (|>> (\ ..monad wrap) (\ monad wrap)))
-
- (def: (join MeMea)
- (do monad
- [eMea MeMea]
- (case eMea
- (#Failure try)
- (wrap (#Failure try))
-
- (#Success Mea)
- Mea))))
-
-(def: #export (lift monad)
- (All [M a] (-> (Monad M) (-> (M a) (M (Try a)))))
- (\ monad map (\ ..monad wrap)))
-
-(implementation: #export (equivalence (^open "_\."))
- (All [a] (-> (Equivalence a) (Equivalence (Try a))))
-
- (def: (= reference sample)
- (case [reference sample]
- [(#Success reference) (#Success sample)]
- (_\= reference sample)
-
- [(#Failure reference) (#Failure sample)]
- ("lux text =" reference sample)
-
- _
- false
- )))
-
-(def: #export (succeed value)
- (All [a] (-> a (Try a)))
- (#Success value))
-
-(def: #export (fail message)
- (-> Text Try)
- (#Failure message))
-
-(def: #export (assume try)
- (All [a] (-> (Try a) a))
- (case try
- (#Success value)
- value
-
- (#Failure message)
- (error! message)))
-
-(def: #export (to_maybe try)
- (All [a] (-> (Try a) (Maybe a)))
- (case try
- (#Success value)
- (#.Some value)
-
- (#Failure message)
- #.None))
-
-(def: #export (from_maybe maybe)
- (All [a] (-> (Maybe a) (Try a)))
- (case maybe
- (#.Some value)
- (#Success value)
-
- #.None
- (#Failure (("lux in-module" "lux" .name\encode) (name_of ..from_maybe)))))
-
-(macro: #export (default tokens compiler)
- {#.doc (doc "Allows you to provide a default value that will be used"
- "if a (Try x) value turns out to be #Failure."
- "Note: the expression for the default value will not be computed if the base computation succeeds."
- (= "bar"
- (default "foo" (#..Success "bar")))
- (= "foo"
- (default "foo" (#..Failure "KABOOM!"))))}
- (case tokens
- (^ (list else try))
- (#Success [compiler (list (` (case (~ try)
- (#..Success (~' g!temp))
- (~' g!temp)
-
- (#..Failure (~ [location.dummy (#.Identifier ["" ""])]))
- (~ else))))])
-
- _
- (#Failure "Wrong syntax for default")))
diff --git a/stdlib/source/lux/control/writer.lux b/stdlib/source/lux/control/writer.lux
deleted file mode 100644
index 92ab8f751..000000000
--- a/stdlib/source/lux/control/writer.lux
+++ /dev/null
@@ -1,77 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- [abstract
- monoid
- [apply (#+ Apply)]
- ["." functor (#+ Functor)]
- ["." monad (#+ Monad do)]]])
-
-(type: #export (Writer l a)
- {#.doc "Represents a value with an associated 'log' value to record arbitrary information."}
- {#log l
- #value a})
-
-(def: #export (write l)
- {#.doc "Set the log to a particular value."}
- (All [l] (-> l (Writer l Any)))
- [l []])
-
-(implementation: #export functor
- (All [l]
- (Functor (Writer l)))
-
- (def: (map f fa)
- (let [[log datum] fa]
- [log (f datum)])))
-
-(implementation: #export (apply monoid)
- (All [l]
- (-> (Monoid l) (Apply (Writer l))))
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (let [[log1 f] ff
- [log2 a] fa]
- [(\ monoid compose log1 log2) (f a)])))
-
-(implementation: #export (monad monoid)
- (All [l]
- (-> (Monoid l) (Monad (Writer l))))
-
- (def: &functor ..functor)
-
- (def: wrap
- (|>> [(\ monoid identity)]))
-
- (def: (join mma)
- (let [[log1 [log2 a]] mma]
- [(\ monoid compose log1 log2) a])))
-
-(implementation: #export (with monoid monad)
- (All [l M] (-> (Monoid l) (Monad M) (Monad (All [a] (M (Writer l a))))))
-
- (def: &functor
- (functor.compose (get@ #monad.&functor monad)
- ..functor))
-
- (def: wrap
- (let [writer (..monad monoid)]
- (|>> (\ writer wrap) (\ monad wrap))))
-
- (def: (join MlMla)
- (do monad
- [[l1 Mla] (for {@.old
- (: (($ 1) (Writer ($ 0) (($ 1) (Writer ($ 0) ($ 2)))))
- MlMla)}
- ## On new compiler
- MlMla)
- [l2 a] Mla]
- (wrap [(\ monoid compose l1 l2) a]))))
-
-(def: #export (lift monoid monad)
- (All [l M a]
- (-> (Monoid l) (Monad M)
- (-> (M a) (M (Writer l a)))))
- (\ monad map (|>> [(\ monoid identity)])))
diff --git a/stdlib/source/lux/data/binary.lux b/stdlib/source/lux/data/binary.lux
deleted file mode 100644
index a6f11ff5b..000000000
--- a/stdlib/source/lux/data/binary.lux
+++ /dev/null
@@ -1,366 +0,0 @@
-(.module:
- [lux (#- i64)
- ["@" target]
- ["." ffi]
- [abstract
- [monad (#+ do)]
- [equivalence (#+ Equivalence)]
- [monoid (#+ Monoid)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." maybe]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." array]]]
- [math
- [number (#+ hex)
- ["n" nat]
- ["f" frac]
- ["." i64]]]])
-
-(exception: #export (index_out_of_bounds {size Nat} {index Nat})
- (exception.report
- ["Size" (%.nat size)]
- ["Index" (%.nat index)]))
-
-(exception: #export (slice_out_of_bounds {size Nat} {offset Nat} {length Nat})
- (exception.report
- ["Size" (%.nat size)]
- ["Offset" (%.nat offset)]
- ["Length" (%.nat length)]))
-
-(with_expansions [<jvm> (as_is (type: #export Binary (ffi.type [byte]))
-
- (ffi.import: java/lang/Object)
-
- (ffi.import: java/lang/System
- ["#::."
- (#static arraycopy [java/lang/Object int java/lang/Object int int] #try void)])
-
- (ffi.import: java/util/Arrays
- ["#::."
- (#static copyOfRange [[byte] int int] [byte])
- (#static equals [[byte] [byte]] boolean)])
-
- (def: byte_mask
- I64
- (|> i64.bits_per_byte i64.mask .i64))
-
- (def: i64
- (-> (primitive "java.lang.Byte") I64)
- (|>> ffi.byte_to_long (:as I64) (i64.and ..byte_mask)))
-
- (def: byte
- (-> (I64 Any) (primitive "java.lang.Byte"))
- (for {@.old
- (|>> .int ffi.long_to_byte)
-
- @.jvm
- (|>> .int (:as (primitive "java.lang.Long")) ffi.long_to_byte)})))]
- (for {@.old (as_is <jvm>)
- @.jvm (as_is <jvm>)
-
- @.js
- (as_is (ffi.import: ArrayBuffer
- ["#::."
- (new [ffi.Number])])
-
- (ffi.import: Uint8Array
- ["#::."
- (new [ArrayBuffer])
- (length ffi.Number)])
-
- (type: #export Binary
- Uint8Array))
-
- @.python
- (type: #export Binary
- (primitive "bytearray"))
-
- @.scheme
- (as_is (type: #export Binary
- (primitive "bytevector"))
-
- (ffi.import: (make-bytevector [Nat] Binary))
- (ffi.import: (bytevector-u8-ref [Binary Nat] I64))
- (ffi.import: (bytevector-u8-set! [Binary Nat (I64 Any)] Any))
- (ffi.import: (bytevector-length [Binary] Nat)))}
-
- ## Default
- (type: #export Binary
- (array.Array (I64 Any)))))
-
-(template: (!size binary)
- (for {@.old (ffi.array_length binary)
- @.jvm (ffi.array_length binary)
-
- @.js
- (|> binary
- Uint8Array::length
- f.nat)
-
- @.python
- (|> binary
- (:as (array.Array (I64 Any)))
- "python array length")
-
- @.scheme
- (..bytevector-length [binary])}
-
- ## Default
- (array.size binary)))
-
-(template: (!read idx binary)
- (for {@.old (..i64 (ffi.array_read idx binary))
- @.jvm (..i64 (ffi.array_read idx binary))
-
- @.js
- (|> binary
- (: ..Binary)
- (:as (array.Array .Frac))
- ("js array read" idx)
- f.nat
- .i64)
-
- @.python
- (|> binary
- (:as (array.Array .I64))
- ("python array read" idx))
-
- @.scheme
- (..bytevector-u8-ref [binary idx])}
-
- ## Default
- (|> binary
- (array.read idx)
- (maybe.default (: (I64 Any) 0))
- (:as I64))))
-
-(template: (!!write <byte_type> <post> <write> idx value binary)
- (|> binary
- (: ..Binary)
- (:as (array.Array <byte_type>))
- (<write> idx (|> value .nat (n.% (hex "100")) <post>))
- (:as ..Binary)))
-
-(template: (!write idx value binary)
- (for {@.old (ffi.array_write idx (..byte value) binary)
- @.jvm (ffi.array_write idx (..byte value) binary)
-
- @.js (!!write .Frac n.frac "js array write" idx value binary)
- @.python (!!write (I64 Any) (:as (I64 Any)) "python array write" idx value binary)
- @.scheme (exec (..bytevector-u8-set! [binary idx value])
- binary)}
-
- ## Default
- (array.write! idx (|> value .nat (n.% (hex "100"))) binary)))
-
-(def: #export size
- (-> Binary Nat)
- (|>> !size))
-
-(def: #export create
- (-> Nat Binary)
- (for {@.old (|>> (ffi.array byte))
- @.jvm (|>> (ffi.array byte))
-
- @.js
- (|>> n.frac ArrayBuffer::new Uint8Array::new)
-
- @.python
- (|>> ("python apply" (:as ffi.Function ("python constant" "bytearray")))
- (:as Binary))
-
- @.scheme
- (|>> ..make-bytevector)}
-
- ## Default
- array.new))
-
-(def: #export (fold f init binary)
- (All [a] (-> (-> I64 a a) a Binary a))
- (let [size (..!size binary)]
- (loop [idx 0
- output init]
- (if (n.< size idx)
- (recur (inc idx) (f (!read idx binary) output))
- output))))
-
-(def: #export (read/8 idx binary)
- (-> Nat Binary (Try I64))
- (if (n.< (..!size binary) idx)
- (#try.Success (!read idx binary))
- (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
-
-(def: #export (read/16 idx binary)
- (-> Nat Binary (Try I64))
- (if (n.< (..!size binary) (n.+ 1 idx))
- (#try.Success ($_ i64.or
- (i64.left_shift 8 (!read idx binary))
- (!read (n.+ 1 idx) binary)))
- (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
-
-(def: #export (read/32 idx binary)
- (-> Nat Binary (Try I64))
- (if (n.< (..!size binary) (n.+ 3 idx))
- (#try.Success ($_ i64.or
- (i64.left_shift 24 (!read idx binary))
- (i64.left_shift 16 (!read (n.+ 1 idx) binary))
- (i64.left_shift 8 (!read (n.+ 2 idx) binary))
- (!read (n.+ 3 idx) binary)))
- (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
-
-(def: #export (read/64 idx binary)
- (-> Nat Binary (Try I64))
- (if (n.< (..!size binary) (n.+ 7 idx))
- (#try.Success ($_ i64.or
- (i64.left_shift 56 (!read idx binary))
- (i64.left_shift 48 (!read (n.+ 1 idx) binary))
- (i64.left_shift 40 (!read (n.+ 2 idx) binary))
- (i64.left_shift 32 (!read (n.+ 3 idx) binary))
- (i64.left_shift 24 (!read (n.+ 4 idx) binary))
- (i64.left_shift 16 (!read (n.+ 5 idx) binary))
- (i64.left_shift 8 (!read (n.+ 6 idx) binary))
- (!read (n.+ 7 idx) binary)))
- (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
-
-(def: #export (write/8 idx value binary)
- (-> Nat (I64 Any) Binary (Try Binary))
- (if (n.< (..!size binary) idx)
- (#try.Success (|> binary
- (!write idx value)))
- (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
-
-(def: #export (write/16 idx value binary)
- (-> Nat (I64 Any) Binary (Try Binary))
- (if (n.< (..!size binary) (n.+ 1 idx))
- (#try.Success (|> binary
- (!write idx (i64.right_shift 8 value))
- (!write (n.+ 1 idx) value)))
- (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
-
-(def: #export (write/32 idx value binary)
- (-> Nat (I64 Any) Binary (Try Binary))
- (if (n.< (..!size binary) (n.+ 3 idx))
- (#try.Success (|> binary
- (!write idx (i64.right_shift 24 value))
- (!write (n.+ 1 idx) (i64.right_shift 16 value))
- (!write (n.+ 2 idx) (i64.right_shift 8 value))
- (!write (n.+ 3 idx) value)))
- (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
-
-(def: #export (write/64 idx value binary)
- (-> Nat (I64 Any) Binary (Try Binary))
- (if (n.< (..!size binary) (n.+ 7 idx))
- (for {@.scheme (let [write_high (|>> (!write idx (i64.right_shift 56 value))
- (!write (n.+ 1 idx) (i64.right_shift 48 value))
- (!write (n.+ 2 idx) (i64.right_shift 40 value))
- (!write (n.+ 3 idx) (i64.right_shift 32 value)))
- write_low (|>> (!write (n.+ 4 idx) (i64.right_shift 24 value))
- (!write (n.+ 5 idx) (i64.right_shift 16 value))
- (!write (n.+ 6 idx) (i64.right_shift 8 value))
- (!write (n.+ 7 idx) value))]
- (|> binary write_high write_low #try.Success))}
- (#try.Success (|> binary
- (!write idx (i64.right_shift 56 value))
- (!write (n.+ 1 idx) (i64.right_shift 48 value))
- (!write (n.+ 2 idx) (i64.right_shift 40 value))
- (!write (n.+ 3 idx) (i64.right_shift 32 value))
- (!write (n.+ 4 idx) (i64.right_shift 24 value))
- (!write (n.+ 5 idx) (i64.right_shift 16 value))
- (!write (n.+ 6 idx) (i64.right_shift 8 value))
- (!write (n.+ 7 idx) value))))
- (exception.throw ..index_out_of_bounds [(..!size binary) idx])))
-
-(implementation: #export equivalence
- (Equivalence Binary)
-
- (def: (= reference sample)
- (with_expansions [<jvm> (java/util/Arrays::equals reference sample)]
- (for {@.old <jvm>
- @.jvm <jvm>}
- (let [limit (!size reference)]
- (and (n.= limit
- (!size sample))
- (loop [idx 0]
- (if (n.< limit idx)
- (and (n.= (!read idx reference)
- (!read idx sample))
- (recur (inc idx)))
- true))))))))
-
-(for {@.old (as_is)
- @.jvm (as_is)}
-
- ## Default
- (exception: #export (cannot_copy_bytes {bytes Nat}
- {source_input Nat}
- {target_output Nat})
- (exception.report
- ["Bytes" (%.nat bytes)]
- ["Source input space" (%.nat source_input)]
- ["Target output space" (%.nat target_output)])))
-
-(def: #export (copy bytes source_offset source target_offset target)
- (-> Nat Nat Binary Nat Binary (Try Binary))
- (with_expansions [<jvm> (as_is (do try.monad
- [_ (java/lang/System::arraycopy source (.int source_offset) target (.int target_offset) (.int bytes))]
- (wrap target)))]
- (for {@.old <jvm>
- @.jvm <jvm>}
-
- ## Default
- (let [source_input (n.- source_offset (!size source))
- target_output (n.- target_offset (!size target))]
- (if (n.<= source_input bytes)
- (loop [idx 0]
- (if (n.< bytes idx)
- (exec (!write (n.+ target_offset idx)
- (!read (n.+ source_offset idx) source)
- target)
- (recur (inc idx)))
- (#try.Success target)))
- (exception.throw ..cannot_copy_bytes [bytes source_input target_output]))))))
-
-(def: #export (slice offset length binary)
- (-> Nat Nat Binary (Try Binary))
- (let [size (..!size binary)
- limit (n.+ length offset)]
- (if (n.<= size limit)
- (with_expansions [<jvm> (as_is (#try.Success (java/util/Arrays::copyOfRange binary (.int offset) (.int limit))))]
- (for {@.old <jvm>
- @.jvm <jvm>}
-
- ## Default
- (..copy length offset binary 0 (..create length))))
- (exception.throw ..slice_out_of_bounds [size offset length]))))
-
-(def: #export (drop offset binary)
- (-> Nat Binary Binary)
- (case offset
- 0 binary
- _ (let [distance (n.- offset (..!size binary))]
- (case (..slice offset distance binary)
- (#try.Success slice)
- slice
-
- (#try.Failure _)
- (..create 0)))))
-
-(implementation: #export monoid
- (Monoid Binary)
-
- (def: identity
- (..create 0))
-
- (def: (compose left right)
- (let [sizeL (!size left)
- sizeR (!size right)
- output (..create (n.+ sizeL sizeR))]
- (exec
- (..copy sizeL 0 left 0 output)
- (..copy sizeR 0 right sizeL output)
- output))))
diff --git a/stdlib/source/lux/data/bit.lux b/stdlib/source/lux/data/bit.lux
deleted file mode 100644
index 88c9b4bd7..000000000
--- a/stdlib/source/lux/data/bit.lux
+++ /dev/null
@@ -1,58 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monoid (#+ Monoid)]
- [equivalence (#+ Equivalence)]
- hash
- [codec (#+ Codec)]]
- [control
- ["." function]]])
-
-(implementation: #export equivalence
- (Equivalence Bit)
-
- (def: (= x y)
- (if x
- y
- (not y))))
-
-(implementation: #export hash
- (Hash Bit)
-
- (def: &equivalence ..equivalence)
-
- (def: (hash value)
- (case value
- #0 2
- #1 3)))
-
-(template [<name> <identity> <op>]
- [(implementation: #export <name>
- (Monoid Bit)
-
- (def: identity <identity>)
- (def: (compose x y) (<op> x y)))]
-
- [disjunction #0 or]
- [conjunction #1 and]
- )
-
-(implementation: #export codec
- (Codec Text Bit)
-
- (def: (encode x)
- (if x
- "#1"
- "#0"))
-
- (def: (decode input)
- (case input
- "#1" (#.Right #1)
- "#0" (#.Right #0)
- _ (#.Left "Wrong syntax for Bit."))))
-
-(def: #export complement
- {#.doc (doc "Generates the complement of a predicate."
- "That is a predicate that returns the oposite of the original predicate.")}
- (All [a] (-> (-> a Bit) (-> a Bit)))
- (function.compose not))
diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux
deleted file mode 100644
index 0b2911c3e..000000000
--- a/stdlib/source/lux/data/collection/array.lux
+++ /dev/null
@@ -1,387 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- [abstract
- [monoid (#+ Monoid)]
- [functor (#+ Functor)]
- [equivalence (#+ Equivalence)]
- [fold (#+ Fold)]
- [predicate (#+ Predicate)]]
- [data
- ["." product]
- ["." maybe]
- [collection
- ["." list ("#\." fold)]]]
- [math
- [number
- ["n" nat]]]])
-
-(def: #export type_name
- "#Array")
-
-(type: #export (Array a)
- {#.doc "Mutable arrays."}
- (#.Primitive ..type_name (#.Cons a #.Nil)))
-
-(with_expansions [<index_type> (primitive "java.lang.Long")
- <elem_type> (primitive "java.lang.Object")
- <array_type> (type (Array <elem_type>))]
- (for {@.jvm
- (template: (!int value)
- (|> value
- (:as <index_type>)
- "jvm object cast"
- "jvm conversion long-to-int"))}
- (as_is))
-
- (def: #export (new size)
- (All [a] (-> Nat (Array a)))
- (for {@.old
- (:assume ("jvm anewarray" "(java.lang.Object )" size))
-
- @.jvm
- (|> size
- !int
- "jvm array new object"
- (: <array_type>)
- :assume)
-
- @.js ("js array new" size)
- @.python ("python array new" size)
- @.lua ("lua array new" size)
- @.ruby ("ruby array new" size)
- @.php ("php array new" size)
- @.scheme ("scheme array new" size)}))
-
- (def: #export (size array)
- (All [a] (-> (Array a) Nat))
- (for {@.old
- ("jvm arraylength" array)
-
- @.jvm
- (|> array
- (:as <array_type>)
- "jvm array length object"
- "jvm conversion int-to-long"
- "jvm object cast"
- (: <index_type>)
- (:as Nat))
-
- @.js ("js array length" array)
- @.python ("python array length" array)
- @.lua ("lua array length" array)
- @.ruby ("ruby array length" array)
- @.php ("php array length" array)
- @.scheme ("scheme array length" array)}))
-
- (template: (!read <read> <null?>)
- (let [output (<read> index array)]
- (if (<null?> output)
- #.None
- (#.Some output))))
-
- (def: #export (read index array)
- (All [a]
- (-> Nat (Array a) (Maybe a)))
- (if (n.< (size array) index)
- (for {@.old
- (let [value ("jvm aaload" array index)]
- (if ("jvm object null?" value)
- #.None
- (#.Some value)))
-
- @.jvm
- (let [value (|> array
- (:as <array_type>)
- ("jvm array read object" (!int index)))]
- (if ("jvm object null?" value)
- #.None
- (#.Some (:assume value))))
-
- @.js (!read "js array read" "js object undefined?")
- @.python (!read "python array read" "python object none?")
- @.lua (!read "lua array read" "lua object nil?")
- @.ruby (!read "ruby array read" "ruby object nil?")
- @.php (!read "php array read" "php object null?")
- @.scheme (!read "scheme array read" "scheme object nil?")})
- #.None))
-
- (def: #export (write! index value array)
- (All [a]
- (-> Nat a (Array a) (Array a)))
- (for {@.old
- ("jvm aastore" array index value)
-
- @.jvm
- (|> array
- (:as <array_type>)
- ("jvm array write object" (!int index) (:as <elem_type> value))
- :assume)
-
- @.js ("js array write" index value array)
- @.python ("python array write" index value array)
- @.lua ("lua array write" index value array)
- @.ruby ("ruby array write" index value array)
- @.php ("php array write" index value array)
- @.scheme ("scheme array write" index value array)}))
-
- (def: #export (delete! index array)
- (All [a]
- (-> Nat (Array a) (Array a)))
- (if (n.< (size array) index)
- (for {@.old
- (write! index (:assume ("jvm object null")) array)
-
- @.jvm
- (write! index (:assume (: <elem_type> ("jvm object null"))) array)
-
- @.js ("js array delete" index array)
- @.python ("python array delete" index array)
- @.lua ("lua array delete" index array)
- @.ruby ("ruby array delete" index array)
- @.php ("php array delete" index array)
- @.scheme ("scheme array delete" index array)})
- array))
- )
-
-(def: #export (contains? index array)
- (All [a]
- (-> Nat (Array a) Bit))
- (case (..read index array)
- (#.Some _)
- true
-
- _
- false))
-
-(def: #export (update! index transform array)
- (All [a]
- (-> Nat (-> a a) (Array a) (Array a)))
- (case (read index array)
- #.None
- array
-
- (#.Some value)
- (write! index (transform value) array)))
-
-(def: #export (upsert! index default transform array)
- (All [a]
- (-> Nat a (-> a a) (Array a) (Array a)))
- (write! index
- (|> array (read index) (maybe.default default) transform)
- array))
-
-(def: #export (copy! length src_start src_array dest_start dest_array)
- (All [a]
- (-> Nat Nat (Array a) Nat (Array a)
- (Array a)))
- (if (n.= 0 length)
- dest_array
- (list\fold (function (_ offset target)
- (case (read (n.+ offset src_start) src_array)
- #.None
- target
-
- (#.Some value)
- (write! (n.+ offset dest_start) value target)))
- dest_array
- (list.indices length))))
-
-(def: #export (occupancy array)
- {#.doc "Finds out how many cells in an array are occupied."}
- (All [a] (-> (Array a) Nat))
- (list\fold (function (_ idx count)
- (case (read idx array)
- #.None
- count
-
- (#.Some _)
- (inc count)))
- 0
- (list.indices (size array))))
-
-(def: #export (vacancy array)
- {#.doc "Finds out how many cells in an array are vacant."}
- (All [a] (-> (Array a) Nat))
- (n.- (..occupancy array) (..size array)))
-
-(def: #export (filter! p xs)
- (All [a]
- (-> (Predicate a) (Array a) (Array a)))
- (list\fold (function (_ idx xs')
- (case (read idx xs)
- #.None
- xs'
-
- (#.Some x)
- (if (p x)
- xs'
- (delete! idx xs'))))
- xs
- (list.indices (size xs))))
-
-(def: #export (find p xs)
- (All [a]
- (-> (Predicate a) (Array a) (Maybe a)))
- (let [arr_size (size xs)]
- (loop [idx 0]
- (if (n.< arr_size idx)
- (case (read 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 Bit) (Array a) (Maybe [Nat a])))
- (let [arr_size (size xs)]
- (loop [idx 0]
- (if (n.< arr_size idx)
- (case (read 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 (function (_ idx ys)
- (case (read idx xs)
- #.None
- ys
-
- (#.Some x)
- (write! 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 (function (_ x [idx arr])
- [(inc idx) (write! idx x arr)])
- [0 (new (list.size xs))]
- xs)))
-
-(def: underflow Nat (dec 0))
-
-(def: #export (to_list array)
- (All [a] (-> (Array a) (List a)))
- (loop [idx (dec (size array))
- output #.Nil]
- (if (n.= ..underflow idx)
- output
- (recur (dec idx)
- (case (read idx array)
- (#.Some head)
- (#.Cons head output)
-
- #.None
- output)))))
-
-(def: #export (to_list' default array)
- (All [a] (-> a (Array a) (List a)))
- (loop [idx (dec (size array))
- output #.Nil]
- (if (n.= ..underflow idx)
- output
- (recur (dec idx)
- (#.Cons (maybe.default default (read idx array))
- output)))))
-
-(implementation: #export (equivalence (^open ",\."))
- (All [a] (-> (Equivalence a) (Equivalence (Array a))))
-
- (def: (= xs ys)
- (let [sxs (size xs)
- sxy (size ys)]
- (and (n.= sxy sxs)
- (list\fold (function (_ idx prev)
- (and prev
- (case [(read idx xs) (read idx ys)]
- [#.None #.None]
- true
-
- [(#.Some x) (#.Some y)]
- (,\= x y)
-
- _
- false)))
- true
- (list.indices sxs))))))
-
-(implementation: #export monoid
- (All [a] (Monoid (Array a)))
-
- (def: identity (new 0))
-
- (def: (compose xs ys)
- (let [sxs (size xs)
- sxy (size ys)]
- (|> (new (n.+ sxy sxs))
- (copy! sxs 0 xs 0)
- (copy! sxy 0 ys sxs)))))
-
-(implementation: #export functor
- (Functor Array)
-
- (def: (map f ma)
- (let [arr_size (size ma)]
- (if (n.= 0 arr_size)
- (new arr_size)
- (list\fold (function (_ idx mb)
- (case (read idx ma)
- #.None
- mb
-
- (#.Some x)
- (write! idx (f x) mb)))
- (new arr_size)
- (list.indices arr_size))
- ))))
-
-(implementation: #export fold
- (Fold Array)
-
- (def: (fold f init xs)
- (let [arr_size (size xs)]
- (loop [so_far init
- idx 0]
- (if (n.< arr_size idx)
- (case (read idx xs)
- #.None
- (recur so_far (inc idx))
-
- (#.Some value)
- (recur (f value so_far) (inc idx)))
- so_far)))))
-
-(template [<name> <init> <op>]
- [(def: #export (<name> predicate array)
- (All [a]
- (-> (Predicate a) (Predicate (Array a))))
- (let [size (..size array)]
- (loop [idx 0]
- (if (n.< size idx)
- (case (..read idx array)
- (#.Some value)
- (<op> (predicate value)
- (recur (inc idx)))
-
- #.None
- (recur (inc idx)))
- <init>))))]
-
- [every? true and]
- [any? false or]
- )
diff --git a/stdlib/source/lux/data/collection/bits.lux b/stdlib/source/lux/data/collection/bits.lux
deleted file mode 100644
index 78d7df988..000000000
--- a/stdlib/source/lux/data/collection/bits.lux
+++ /dev/null
@@ -1,176 +0,0 @@
-(.module:
- [lux (#- not and or)
- [abstract
- [equivalence (#+ Equivalence)]]
- [control
- pipe]
- [data
- ["." maybe]
- [collection
- ["." array (#+ Array) ("#\." fold)]]]
- [math
- [number
- ["n" nat]
- ["." i64]]]])
-
-(type: #export Chunk
- I64)
-
-(def: #export chunk-size
- i64.width)
-
-(type: #export Bits
- (Array Chunk))
-
-(def: empty-chunk
- Chunk
- (.i64 0))
-
-(def: #export empty
- Bits
- (array.new 0))
-
-(def: #export (size bits)
- (-> Bits Nat)
- (array\fold (function (_ chunk total)
- (|> chunk i64.count (n.+ total)))
- 0
- bits))
-
-(def: #export (capacity bits)
- (-> Bits Nat)
- (|> bits array.size (n.* chunk-size)))
-
-(def: #export empty?
- (-> Bits Bit)
- (|>> size (n.= 0)))
-
-(def: #export (get index bits)
- (-> Nat Bits Bit)
- (let [[chunk-index bit-index] (n./% chunk-size index)]
- (.and (n.< (array.size bits) chunk-index)
- (|> (array.read chunk-index bits)
- (maybe.default empty-chunk)
- (i64.set? bit-index)))))
-
-(def: (chunk idx bits)
- (-> Nat Bits Chunk)
- (if (n.< (array.size bits) idx)
- (|> bits (array.read idx) (maybe.default empty-chunk))
- empty-chunk))
-
-(template [<name> <op>]
- [(def: #export (<name> index input)
- (-> Nat Bits Bits)
- (let [[chunk-index bit-index] (n./% chunk-size index)]
- (loop [size|output (n.max (inc chunk-index)
- (array.size input))
- output ..empty]
- (let [idx|output (dec size|output)]
- (if (n.> 0 size|output)
- (case (|> (..chunk idx|output input)
- (cond> [(new> (n.= chunk-index idx|output) [])]
- [(<op> bit-index)]
-
- ## else
- [])
- .nat)
- 0
- ## TODO: Remove 'no-op' once new-luxc is the official compiler.
- (let [no-op (recur (dec size|output) output)]
- no-op)
-
- chunk
- (|> (if (is? ..empty output)
- (: Bits (array.new size|output))
- output)
- (array.write! idx|output (.i64 chunk))
- (recur (dec size|output))))
- output)))))]
-
- [set i64.set]
- [clear i64.clear]
- [flip i64.flip]
- )
-
-(def: #export (intersects? reference sample)
- (-> Bits Bits Bit)
- (let [chunks (n.min (array.size reference)
- (array.size sample))]
- (loop [idx 0]
- (if (n.< chunks idx)
- (.or (|> (..chunk idx sample)
- (i64.and (..chunk idx reference))
- ("lux i64 =" empty-chunk)
- .not)
- (recur (inc idx)))
- #0))))
-
-(def: #export (not input)
- (-> Bits Bits)
- (case (array.size input)
- 0
- ..empty
-
- size|output
- (loop [size|output size|output
- output ..empty]
- (let [idx (dec size|output)]
- (case (|> input (..chunk idx) i64.not .nat)
- 0
- (recur (dec size|output) output)
-
- chunk
- (if (n.> 0 size|output)
- (|> (if (is? ..empty output)
- (: Bits (array.new size|output))
- output)
- (array.write! idx (.i64 chunk))
- (recur (dec size|output)))
- output))))))
-
-(template [<name> <op>]
- [(def: #export (<name> param subject)
- (-> Bits Bits Bits)
- (case (n.max (array.size param)
- (array.size subject))
- 0
- ..empty
-
- size|output
- (loop [size|output size|output
- output ..empty]
- (let [idx (dec size|output)]
- (if (n.> 0 size|output)
- (case (|> (..chunk idx subject)
- (<op> (..chunk idx param))
- .nat)
- 0
- (recur (dec size|output) output)
-
- chunk
- (|> (if (is? ..empty output)
- (: Bits (array.new size|output))
- output)
- (array.write! idx (.i64 chunk))
- (recur (dec size|output))))
- output)))))]
-
- [and i64.and]
- [or i64.or]
- [xor i64.xor]
- )
-
-(implementation: #export equivalence
- (Equivalence Bits)
-
- (def: (= reference sample)
- (let [size (n.max (array.size reference)
- (array.size sample))]
- (loop [idx 0]
- (if (n.< size idx)
- (.and ("lux i64 ="
- (..chunk idx reference)
- (..chunk idx sample))
- (recur (inc idx)))
- #1)))))
diff --git a/stdlib/source/lux/data/collection/dictionary.lux b/stdlib/source/lux/data/collection/dictionary.lux
deleted file mode 100644
index 4aa50c9a7..000000000
--- a/stdlib/source/lux/data/collection/dictionary.lux
+++ /dev/null
@@ -1,731 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [hash (#+ Hash)]
- [equivalence (#+ Equivalence)]
- [functor (#+ Functor)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." maybe]
- ["." product]
- [collection
- ["." list ("#\." fold functor monoid)]
- ["." array (#+ Array) ("#\." functor fold)]]]
- [math
- ["." number
- ["n" nat]
- ["." i64]]]])
-
-## 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.
-
-## 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 its 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
-## Dictionaries.
-(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
- (i64.left_shift (n.- 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
- (i64.left_shift (n.- 1 branching_exponent) 1))
-
-## The size of hierarchy-nodes, which is 2^(branching-exponent).
-(def: hierarchy_nodes_size
- Nat
- (i64.left_shift 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.new (inc old_size))
- (array.copy! idx 0 old_array 0)
- (array.write! idx value)
- (array.copy! (n.- 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.write! 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.delete! 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! (n.- idx new_size) (inc idx) array idx))))
-
-## Increases the level-shift by the branching-exponent, to explore
-## levels further down the tree.
-(def: level_up
- (-> Level Level)
- (n.+ 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)
- (i64.and ..hierarchy_mask
- (i64.right_shift level hash)))
-
-## A mechanism to go from indices to bit-positions.
-(def: (->bit_position index)
- (-> Index BitPosition)
- (i64.left_shift 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 Bit)
- (|> bitmap
- (i64.and bit)
- (n.= clean_bitmap)
- not))
-
-## Figures out whether a bitmap only contains a single bit-position.
-(def: only_bit_position?
- (-> BitPosition BitMap Bit)
- n.=)
-
-(def: (set_bit_position bit bitmap)
- (-> BitPosition BitMap BitMap)
- (i64.or bit bitmap))
-
-(def: unset_bit_position
- (-> BitPosition BitMap BitMap)
- i64.xor)
-
-## Figures out the size of a bitmap-indexed array by counting all the
-## 1s within the bitmap.
-(def: bitmap_size
- (-> BitMap Nat)
- i64.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 its bit-position.
-(def: (base_index bit_position bitmap)
- (-> BitPosition BitMap Index)
- (bitmap_size (i64.and (bit_position_mask bit_position)
- bitmap)))
-
-## Produces the index of a KV-pair within a #Collisions node.
-(def: (collision_index Hash<k> key colls)
- (All [k v] (-> (Hash k) k (Collisions k v) (Maybe Index)))
- (\ maybe.monad map product.left
- (array.find+ (function (_ idx [key' val'])
- (\ Hash<k> = 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)]))
- (product.right (list\fold (function (_ idx [insertion_idx node])
- (let [[bitmap base] node]
- (case (array.read idx h_array)
- #.None [insertion_idx node]
- (#.Some sub_node) (if (n.= except_idx idx)
- [insertion_idx node]
- [(inc insertion_idx)
- [(set_bit_position (->bit_position idx) bitmap)
- (array.write! insertion_idx (#.Left sub_node) base)]])
- )))
- [0 [clean_bitmap
- (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 its balance.
-(def: hierarchy_indices (List Index) (list.indices hierarchy_nodes_size))
-
-(def: (promote_base put' Hash<k> 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 (function (_ hierarchy_idx (^@ default [base_idx h_array]))
- (if (bit_position_is_set? (->bit_position hierarchy_idx)
- bitmap)
- [(inc base_idx)
- (case (array.read base_idx base)
- (#.Some (#.Left sub_node))
- (array.write! hierarchy_idx sub_node h_array)
-
- (#.Some (#.Right [key' val']))
- (array.write! hierarchy_idx
- (put' (level_up level) (\ Hash<k> hash key') key' val' Hash<k> empty)
- h_array)
-
- #.None
- (undefined))]
- default))
- [0
- (array.new hierarchy_nodes_size)]
- hierarchy_indices)))
-
-## 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) Bit))
- (`` (case node
- (#Base (~~ (static ..clean_bitmap)) _)
- #1
-
- _
- #0)))
-
-(def: (put' level hash key val Hash<k> node)
- (All [k v] (-> Level Hash_Code k v (Hash k) (Node k v) (Node k v)))
- (case node
- ## For #Hierarchy nodes, check whether one can add the element to
- ## a sub-node. If impossible, introduce a new singleton sub-node.
- (#Hierarchy _size hierarchy)
- (let [idx (level_index level hash)
- [_size' sub_node] (case (array.read idx hierarchy)
- (#.Some sub_node)
- [_size sub_node]
-
- _
- [(inc _size) empty])]
- (#Hierarchy _size'
- (update! idx (put' (level_up level) hash key val Hash<k> sub_node)
- hierarchy)))
-
- ## For #Base nodes, 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.read idx base)
- ## If it's being used by a node, add the KV to it.
- (#.Some (#.Left sub_node))
- (let [sub_node' (put' (level_up level) hash key val Hash<k> sub_node)]
- (#Base bitmap (update! idx (#.Left sub_node') base)))
-
- ## Otherwise, if it's being used by a KV, compare the keys.
- (#.Some (#.Right key' val'))
- (if (\ Hash<k> = key key')
- ## If the same key is found, replace the value.
- (#Base bitmap (update! idx (#.Right key val) base))
- ## Otherwise, compare the hashes of the keys.
- (#Base bitmap (update! idx
- (#.Left (let [hash' (\ Hash<k> hash key')]
- (if (n.= hash hash')
- ## If the hashes are
- ## the same, a new
- ## #Collisions node
- ## is added.
- (#Collisions hash (|> (array.new 2)
- (array.write! 0 [key' val'])
- (array.write! 1 [key val])))
- ## Otherwise, one can
- ## just keep using
- ## #Base nodes, so
- ## add both KV-pairs
- ## to the empty one.
- (let [next_level (level_up level)]
- (|> empty
- (put' next_level hash' key' val' Hash<k>)
- (put' next_level hash key val Hash<k>))))))
- base)))
-
- #.None
- (undefined)))
- ## However, if the BitPosition has not been used yet, check
- ## whether this #Base node is ready for a promotion.
- (let [base_count (bitmap_size bitmap)]
- (if (n.>= ..promotion_threshold base_count)
- ## If so, 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<k> level bitmap base)
- (array.write! (level_index level hash)
- (put' (level_up level) hash key val Hash<k> empty))))
- ## Otherwise, 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, compare the hashes.
- (#Collisions _hash _colls)
- (if (n.= hash _hash)
- ## If they're equal, that means the new KV contributes to the
- ## collisions.
- (case (collision_index Hash<k> key _colls)
- ## If the key was already present in the collisions-list, its
- ## 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, create a new #Base node that
- ## contains the old #Collisions node, plus the new KV-pair.
- (|> (#Base (bit_position level _hash)
- (|> (array.new 1)
- (array.write! 0 (#.Left node))))
- (put' level hash key val Hash<k>)))
- ))
-
-(def: (remove' level hash key Hash<k> 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.read 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<k> sub_node)]
- ## Then check if a removal was actually done.
- (if (is? 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 (n.<= 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.read idx base)
- ## 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<k> sub_node)]
- ## Verify that it was removed.
- (if (is? 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 did not 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<k> = 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)
-
- #.None
- (undefined)))
- ## 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<k> 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 (n.= 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<k> 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.read (level_index level hash) hierarchy)
- #.None #.None
- (#.Some sub_node) (get' (level_up level) hash key Hash<k> 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.read (base_index bit bitmap) base)
- (#.Some (#.Left sub_node))
- (get' (level_up level) hash key Hash<k> sub_node)
-
- (#.Some (#.Right [key' val']))
- (if (\ Hash<k> = key key')
- (#.Some val')
- #.None)
-
- #.None
- (undefined))
- #.None))
-
- ## For #Collisions nodes, do a linear scan of all the known KV-pairs.
- (#Collisions _hash _colls)
- (\ maybe.monad map product.right
- (array.find (|>> product.left (\ Hash<k> = key))
- _colls))
- ))
-
-(def: (size' node)
- (All [k v] (-> (Node k v) Nat))
- (case node
- (#Hierarchy _size hierarchy)
- (array\fold n.+ 0 (array\map size' hierarchy))
-
- (#Base _ base)
- (array\fold n.+ 0 (array\map (function (_ 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 (function (_ sub_node tail) (list\compose (entries' sub_node) tail))
- #.Nil
- hierarchy)
-
- (#Base bitmap base)
- (array\fold (function (_ branch tail)
- (case branch
- (#.Left sub_node)
- (list\compose (entries' sub_node) tail)
-
- (#.Right [key' val'])
- (#.Cons [key' val'] tail)))
- #.Nil
- base)
-
- (#Collisions hash colls)
- (array\fold (function (_ [key' val'] tail) (#.Cons [key' val'] tail))
- #.Nil
- colls)))
-
-(type: #export (Dictionary k v)
- {#.doc "A dictionary implemented as a Hash-Array Mapped Trie (HAMT)."}
- {#hash (Hash k)
- #root (Node k v)})
-
-(def: #export key_hash
- (All [k v] (-> (Dictionary k v) (Hash k)))
- (get@ #..hash))
-
-(def: #export (new Hash<k>)
- (All [k v] (-> (Hash k) (Dictionary k v)))
- {#hash Hash<k>
- #root empty})
-
-(def: #export (put key val dict)
- (All [k v] (-> k v (Dictionary k v) (Dictionary k v)))
- (let [[Hash<k> node] dict]
- [Hash<k> (put' root_level (\ Hash<k> hash key) key val Hash<k> node)]))
-
-(def: #export (remove key dict)
- (All [k v] (-> k (Dictionary k v) (Dictionary k v)))
- (let [[Hash<k> node] dict]
- [Hash<k> (remove' root_level (\ Hash<k> hash key) key Hash<k> node)]))
-
-(def: #export (get key dict)
- (All [k v] (-> k (Dictionary k v) (Maybe v)))
- (let [[Hash<k> node] dict]
- (get' root_level (\ Hash<k> hash key) key Hash<k> node)))
-
-(def: #export (key? dict key)
- (All [k v] (-> (Dictionary k v) k Bit))
- (case (get key dict)
- #.None #0
- (#.Some _) #1))
-
-(exception: #export key_already_exists)
-
-(def: #export (try_put key val dict)
- {#.doc "Only puts the KV-pair if the key is not already present."}
- (All [k v] (-> k v (Dictionary k v) (Try (Dictionary k v))))
- (case (get key dict)
- #.None (#try.Success (put key val dict))
- (#.Some _) (exception.throw ..key_already_exists [])))
-
-(def: #export (update key f dict)
- {#.doc "Transforms the value located at key (if available), using the given function."}
- (All [k v] (-> k (-> v v) (Dictionary k v) (Dictionary k v)))
- (case (get key dict)
- #.None
- dict
-
- (#.Some val)
- (put key (f val) dict)))
-
-(def: #export (upsert key default f dict)
- {#.doc (doc "Updates the value at the key; if it exists."
- "Otherwise, puts a value by applying the function to a default.")}
- (All [k v] (-> k v (-> v v) (Dictionary k v) (Dictionary k v)))
- (..put key
- (f (maybe.default default
- (..get key dict)))
- dict))
-
-(def: #export size
- (All [k v] (-> (Dictionary k v) Nat))
- (|>> product.right ..size'))
-
-(def: #export empty?
- (All [k v] (-> (Dictionary k v) Bit))
- (|>> size (n.= 0)))
-
-(def: #export (entries dict)
- (All [k v] (-> (Dictionary k v) (List [k v])))
- (entries' (product.right dict)))
-
-(def: #export (from_list Hash<k> kvs)
- (All [k v] (-> (Hash k) (List [k v]) (Dictionary k v)))
- (list\fold (function (_ [k v] dict)
- (put k v dict))
- (new Hash<k>)
- kvs))
-
-(template [<name> <elem_type> <side>]
- [(def: #export (<name> dict)
- (All [k v] (-> (Dictionary k v) (List <elem_type>)))
- (|> dict entries (list\map <side>)))]
-
- [keys k product.left]
- [values v product.right]
- )
-
-(def: #export (merge dict2 dict1)
- {#.doc (doc "Merges 2 dictionaries."
- "If any collisions with keys occur, the values of dict2 will overwrite those of dict1.")}
- (All [k v] (-> (Dictionary k v) (Dictionary k v) (Dictionary k v)))
- (list\fold (function (_ [key val] dict) (put key val dict))
- dict1
- (entries dict2)))
-
-(def: #export (merge_with f dict2 dict1)
- {#.doc (doc "Merges 2 dictionaries."
- "If any collisions with keys occur, a new value will be computed by applying 'f' to the values of dict2 and dict1.")}
- (All [k v] (-> (-> v v v) (Dictionary k v) (Dictionary k v) (Dictionary k v)))
- (list\fold (function (_ [key val2] dict)
- (case (get key dict)
- #.None
- (put key val2 dict)
-
- (#.Some val1)
- (put key (f val2 val1) dict)))
- dict1
- (entries dict2)))
-
-(def: #export (re_bind from_key to_key dict)
- (All [k v] (-> k k (Dictionary k v) (Dictionary k v)))
- (case (get from_key dict)
- #.None
- dict
-
- (#.Some val)
- (|> dict
- (remove from_key)
- (put to_key val))))
-
-(def: #export (select keys dict)
- {#.doc "Creates a sub-set of the given dict, with only the specified keys."}
- (All [k v] (-> (List k) (Dictionary k v) (Dictionary k v)))
- (let [[Hash<k> _] dict]
- (list\fold (function (_ key new_dict)
- (case (get key dict)
- #.None new_dict
- (#.Some val) (put key val new_dict)))
- (new Hash<k>)
- keys)))
-
-(implementation: #export (equivalence (^open ",\."))
- (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v))))
-
- (def: (= reference subject)
- (and (n.= (..size reference)
- (..size subject))
- (list.every? (function (_ [k rv])
- (case (..get k subject)
- (#.Some sv)
- (,\= rv sv)
-
- _
- #0))
- (..entries reference)))))
-
-(implementation: functor'
- (All [k] (Functor (Node k)))
-
- (def: (map f fa)
- (case fa
- (#Hierarchy size hierarchy)
- (#Hierarchy size (array\map (map f) hierarchy))
-
- (#Base bitmap base)
- (#Base bitmap (array\map (function (_ either)
- (case either
- (#.Left fa')
- (#.Left (map f fa'))
-
- (#.Right [k v])
- (#.Right [k (f v)])))
- base))
-
- (#Collisions hash collisions)
- (#Collisions hash (array\map (function (_ [k v])
- [k (f v)])
- collisions)))))
-
-(implementation: #export functor
- (All [k] (Functor (Dictionary k)))
-
- (def: (map f fa)
- (update@ #root (\ ..functor' map f) fa)))
diff --git a/stdlib/source/lux/data/collection/dictionary/ordered.lux b/stdlib/source/lux/data/collection/dictionary/ordered.lux
deleted file mode 100644
index 618c5ccf6..000000000
--- a/stdlib/source/lux/data/collection/dictionary/ordered.lux
+++ /dev/null
@@ -1,583 +0,0 @@
-(.module:
- [lux #*
- [abstract
- equivalence
- [monad (#+ Monad do)]
- ["." order (#+ Order)]]
- [data
- ["p" product]
- ["." maybe]
- [collection
- ["." list ("#\." monoid fold)]]]
- [macro
- ["." code]]
- [math
- [number
- ["n" nat]]]])
-
-(def: error_message
- "Invariant violation")
-
-(type: Color
- #Red
- #Black)
-
-(type: (Node k v)
- {#color Color
- #key k
- #value v
- #left (Maybe (Node k v))
- #right (Maybe (Node k v))})
-
-(template [<create> <color>]
- [(def: (<create> key value left right)
- (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v)))
- {#color <color>
- #key key
- #value value
- #left left
- #right right})]
-
- [red #Red]
- [black #Black]
- )
-
-(type: #export (Dictionary k v)
- {#&order (Order k)
- #root (Maybe (Node k v))})
-
-(def: #export (new order)
- (All [k v] (-> (Order k) (Dictionary k v)))
- {#&order order
- #root #.None})
-
-## TODO: Doing inneficient access of Order functions due to compiler bug.
-## TODO: Must improve it as soon as bug is fixed.
-(def: #export (get key dict)
- (All [k v] (-> k (Dictionary k v) (Maybe v)))
- (let [## (^open "_\.") (get@ #&order dict)
- ]
- (loop [node (get@ #root dict)]
- (case node
- #.None
- #.None
-
- (#.Some node)
- (let [node_key (get@ #key node)]
- (cond (\ dict = node_key key)
- ## (_\= node_key key)
- (#.Some (get@ #value node))
-
- (\ dict < node_key key)
- ## (_\< node_key key)
- (recur (get@ #left node))
-
- ## (_\> (get@ #key node) key)
- (recur (get@ #right node))))
- ))))
-
-## TODO: Doing inneficient access of Order functions due to compiler bug.
-## TODO: Must improve it as soon as bug is fixed.
-(def: #export (key? dict key)
- (All [k v] (-> (Dictionary k v) k Bit))
- (let [## (^open "_\.") (get@ #&order dict)
- ]
- (loop [node (get@ #root dict)]
- (case node
- #.None
- #0
-
- (#.Some node)
- (let [node_key (get@ #key node)]
- (or (\ dict = node_key key)
- ## (_\= node_key key)
- (if (\ dict < node_key key)
- ## (_\< node_key key)
- (recur (get@ #left node))
- (recur (get@ #right node)))))))))
-
-(template [<name> <side>]
- [(def: #export (<name> dict)
- (All [k v] (-> (Dictionary k v) (Maybe v)))
- (case (get@ #root dict)
- #.None
- #.None
-
- (#.Some node)
- (loop [node node]
- (case (get@ <side> node)
- #.None
- (#.Some (get@ #value node))
-
- (#.Some side)
- (recur side)))))]
-
- [min #left]
- [max #right]
- )
-
-(def: #export (size dict)
- (All [k v] (-> (Dictionary k v) Nat))
- (loop [node (get@ #root dict)]
- (case node
- #.None
- 0
-
- (#.Some node)
- (inc (n.+ (recur (get@ #left node))
- (recur (get@ #right node)))))))
-
-(def: #export empty?
- (All [k v] (-> (Dictionary k v) Bit))
- (|>> ..size (n.= 0)))
-
-(template [<name> <other_color> <self_color> <no_change>]
- [(def: (<name> self)
- (All [k v] (-> (Node k v) (Node k v)))
- (case (get@ #color self)
- <other_color>
- (set@ #color <self_color> self)
-
- <self_color>
- <no_change>
- ))]
-
- [blacken #Red #Black self]
- [redden #Black #Red (error! error_message)]
- )
-
-(def: (balance_left_add parent self)
- (All [k v] (-> (Node k v) (Node k v) (Node k v)))
- (with_expansions
- [<default_behavior> (as_is (black (get@ #key parent)
- (get@ #value parent)
- (#.Some self)
- (get@ #right parent)))]
- (case (get@ #color self)
- #Red
- (case (get@ #left self)
- (^multi (#.Some left)
- [(get@ #color left) #Red])
- (red (get@ #key self)
- (get@ #value self)
- (#.Some (blacken left))
- (#.Some (black (get@ #key parent)
- (get@ #value parent)
- (get@ #right self)
- (get@ #right parent))))
-
- _
- (case (get@ #right self)
- (^multi (#.Some right)
- [(get@ #color right) #Red])
- (red (get@ #key right)
- (get@ #value right)
- (#.Some (black (get@ #key self)
- (get@ #value self)
- (get@ #left self)
- (get@ #left right)))
- (#.Some (black (get@ #key parent)
- (get@ #value parent)
- (get@ #right right)
- (get@ #right parent))))
-
- _
- <default_behavior>))
-
- #Black
- <default_behavior>
- )))
-
-(def: (balance_right_add parent self)
- (All [k v] (-> (Node k v) (Node k v) (Node k v)))
- (with_expansions
- [<default_behavior> (as_is (black (get@ #key parent)
- (get@ #value parent)
- (get@ #left parent)
- (#.Some self)))]
- (case (get@ #color self)
- #Red
- (case (get@ #right self)
- (^multi (#.Some right)
- [(get@ #color right) #Red])
- (red (get@ #key self)
- (get@ #value self)
- (#.Some (black (get@ #key parent)
- (get@ #value parent)
- (get@ #left parent)
- (get@ #left self)))
- (#.Some (blacken right)))
-
- _
- (case (get@ #left self)
- (^multi (#.Some left)
- [(get@ #color left) #Red])
- (red (get@ #key left)
- (get@ #value left)
- (#.Some (black (get@ #key parent)
- (get@ #value parent)
- (get@ #left parent)
- (get@ #left left)))
- (#.Some (black (get@ #key self)
- (get@ #value self)
- (get@ #right left)
- (get@ #right self))))
-
- _
- <default_behavior>))
-
- #Black
- <default_behavior>
- )))
-
-(def: (add_left addition center)
- (All [k v] (-> (Node k v) (Node k v) (Node k v)))
- (case (get@ #color center)
- #Red
- (red (get@ #key center) (get@ #value center) (#.Some addition) (get@ #right center))
-
- #Black
- (balance_left_add center addition)
- ))
-
-(def: (add_right addition center)
- (All [k v] (-> (Node k v) (Node k v) (Node k v)))
- (case (get@ #color center)
- #Red
- (red (get@ #key center) (get@ #value center) (get@ #left center) (#.Some addition))
-
- #Black
- (balance_right_add center addition)
- ))
-
-(def: #export (put key value dict)
- (All [k v] (-> k v (Dictionary k v) (Dictionary k v)))
- (let [(^open "_\.") (get@ #&order dict)
- root' (loop [?root (get@ #root dict)]
- (case ?root
- #.None
- (#.Some (red key value #.None #.None))
-
- (#.Some root)
- (let [reference (get@ #key root)]
- (`` (cond (~~ (template [<comp> <tag> <add>]
- [(<comp> reference key)
- (let [side_root (get@ <tag> root)
- outcome (recur side_root)]
- (if (is? side_root outcome)
- ?root
- (#.Some (<add> (maybe.assume outcome)
- root))))]
-
- [_\< #left add_left]
- [(order.> (get@ #&order dict)) #right add_right]
- ))
-
- ## (_\= reference key)
- (#.Some (set@ #value value root))
- )))
- ))]
- (set@ #root root' dict)))
-
-(def: (left_balance key value ?left ?right)
- (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v)))
- (case ?left
- (^multi (#.Some left)
- [(get@ #color left) #Red]
- [(get@ #left left) (#.Some left>>left)]
- [(get@ #color left>>left) #Red])
- (red (get@ #key left)
- (get@ #value left)
- (#.Some (blacken left>>left))
- (#.Some (black key value (get@ #right left) ?right)))
-
- (^multi (#.Some left)
- [(get@ #color left) #Red]
- [(get@ #right left) (#.Some left>>right)]
- [(get@ #color left>>right) #Red])
- (red (get@ #key left>>right)
- (get@ #value left>>right)
- (#.Some (black (get@ #key left)
- (get@ #value left)
- (get@ #left left)
- (get@ #left left>>right)))
- (#.Some (black key value
- (get@ #right left>>right)
- ?right)))
-
- _
- (black key value ?left ?right)))
-
-(def: (right_balance key value ?left ?right)
- (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v)))
- (case ?right
- (^multi (#.Some right)
- [(get@ #color right) #Red]
- [(get@ #right right) (#.Some right>>right)]
- [(get@ #color right>>right) #Red])
- (red (get@ #key right)
- (get@ #value right)
- (#.Some (black key value ?left (get@ #left right)))
- (#.Some (blacken right>>right)))
-
- (^multi (#.Some right)
- [(get@ #color right) #Red]
- [(get@ #left right) (#.Some right>>left)]
- [(get@ #color right>>left) #Red])
- (red (get@ #key right>>left)
- (get@ #value right>>left)
- (#.Some (black key value ?left (get@ #left right>>left)))
- (#.Some (black (get@ #key right)
- (get@ #value right)
- (get@ #right right>>left)
- (get@ #right right))))
-
- _
- (black key value ?left ?right)))
-
-(def: (balance_left_remove key value ?left ?right)
- (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v)))
- (case ?left
- (^multi (#.Some left)
- [(get@ #color left) #Red])
- (red key value (#.Some (blacken left)) ?right)
-
- _
- (case ?right
- (^multi (#.Some right)
- [(get@ #color right) #Black])
- (right_balance key value ?left (#.Some (redden right)))
-
- (^multi (#.Some right)
- [(get@ #color right) #Red]
- [(get@ #left right) (#.Some right>>left)]
- [(get@ #color right>>left) #Black])
- (red (get@ #key right>>left)
- (get@ #value right>>left)
- (#.Some (black key value ?left (get@ #left right>>left)))
- (#.Some (right_balance (get@ #key right)
- (get@ #value right)
- (get@ #right right>>left)
- (\ maybe.functor map redden (get@ #right right)))))
-
- _
- (error! error_message))
- ))
-
-(def: (balance_right_remove key value ?left ?right)
- (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v)))
- (case ?right
- (^multi (#.Some right)
- [(get@ #color right) #Red])
- (red key value ?left (#.Some (blacken right)))
-
- _
- (case ?left
- (^multi (#.Some left)
- [(get@ #color left) #Black])
- (left_balance key value (#.Some (redden left)) ?right)
-
- (^multi (#.Some left)
- [(get@ #color left) #Red]
- [(get@ #right left) (#.Some left>>right)]
- [(get@ #color left>>right) #Black])
- (red (get@ #key left>>right)
- (get@ #value left>>right)
- (#.Some (left_balance (get@ #key left)
- (get@ #value left)
- (\ maybe.functor map redden (get@ #left left))
- (get@ #left left>>right)))
- (#.Some (black key value (get@ #right left>>right) ?right)))
-
- _
- (error! error_message)
- )))
-
-(def: (prepend ?left ?right)
- (All [k v] (-> (Maybe (Node k v)) (Maybe (Node k v)) (Maybe (Node k v))))
- (case [?left ?right]
- [#.None _]
- ?right
-
- [_ #.None]
- ?left
-
- [(#.Some left) (#.Some right)]
- (case [(get@ #color left) (get@ #color right)]
- [#Red #Red]
- (do maybe.monad
- [fused (prepend (get@ #right left) (get@ #right right))]
- (case (get@ #color fused)
- #Red
- (wrap (red (get@ #key fused)
- (get@ #value fused)
- (#.Some (red (get@ #key left)
- (get@ #value left)
- (get@ #left left)
- (get@ #left fused)))
- (#.Some (red (get@ #key right)
- (get@ #value right)
- (get@ #right fused)
- (get@ #right right)))))
-
- #Black
- (wrap (red (get@ #key left)
- (get@ #value left)
- (get@ #left left)
- (#.Some (red (get@ #key right)
- (get@ #value right)
- (#.Some fused)
- (get@ #right right)))))))
-
- [#Red #Black]
- (#.Some (red (get@ #key left)
- (get@ #value left)
- (get@ #left left)
- (prepend (get@ #right left)
- ?right)))
-
- [#Black #Red]
- (#.Some (red (get@ #key right)
- (get@ #value right)
- (prepend ?left
- (get@ #left right))
- (get@ #right right)))
-
- [#Black #Black]
- (do maybe.monad
- [fused (prepend (get@ #right left) (get@ #left right))]
- (case (get@ #color fused)
- #Red
- (wrap (red (get@ #key fused)
- (get@ #value fused)
- (#.Some (black (get@ #key left)
- (get@ #value left)
- (get@ #left left)
- (get@ #left fused)))
- (#.Some (black (get@ #key right)
- (get@ #value right)
- (get@ #right fused)
- (get@ #right right)))))
-
- #Black
- (wrap (balance_left_remove (get@ #key left)
- (get@ #value left)
- (get@ #left left)
- (#.Some (black (get@ #key right)
- (get@ #value right)
- (#.Some fused)
- (get@ #right right)))))
- ))
- )
-
- _
- (undefined)))
-
-(def: #export (remove key dict)
- (All [k v] (-> k (Dictionary k v) (Dictionary k v)))
- (let [(^open "_\.") (get@ #&order dict)
- [?root found?] (loop [?root (get@ #root dict)]
- (case ?root
- #.None
- [#.None #0]
-
- (#.Some root)
- (let [root_key (get@ #key root)
- root_val (get@ #value root)]
- (if (_\= root_key key)
- [(prepend (get@ #left root)
- (get@ #right root))
- #1]
- (let [go_left? (_\< root_key key)]
- (case (recur (if go_left?
- (get@ #left root)
- (get@ #right root)))
- [#.None #0]
- [#.None #0]
-
- [side_outcome _]
- (if go_left?
- (case (get@ #left root)
- (^multi (#.Some left)
- [(get@ #color left) #Black])
- [(#.Some (balance_left_remove root_key root_val side_outcome (get@ #right root)))
- #0]
-
- _
- [(#.Some (red root_key root_val side_outcome (get@ #right root)))
- #0])
- (case (get@ #right root)
- (^multi (#.Some right)
- [(get@ #color right) #Black])
- [(#.Some (balance_right_remove root_key root_val (get@ #left root) side_outcome))
- #0]
-
- _
- [(#.Some (red root_key root_val (get@ #left root) side_outcome))
- #0])
- )))
- ))
- ))]
- (case ?root
- #.None
- (if found?
- (set@ #root ?root dict)
- dict)
-
- (#.Some root)
- (set@ #root (#.Some (blacken root)) dict)
- )))
-
-(def: #export (update key transform dict)
- (All [k v] (-> k (-> v v) (Dictionary k v) (Dictionary k v)))
- (case (..get key dict)
- (#.Some old)
- (..put key (transform old) dict)
-
- #.None
- dict))
-
-(def: #export (from_list Order<l> list)
- (All [k v] (-> (Order k) (List [k v]) (Dictionary k v)))
- (list\fold (function (_ [key value] dict)
- (put key value dict))
- (new Order<l>)
- list))
-
-(template [<name> <type> <output>]
- [(def: #export (<name> dict)
- (All [k v] (-> (Dictionary k v) (List <type>)))
- (loop [node (get@ #root dict)]
- (case node
- #.None
- (list)
-
- (#.Some node')
- ($_ list\compose
- (recur (get@ #left node'))
- (list <output>)
- (recur (get@ #right node'))))))]
-
- [entries [k v] [(get@ #key node') (get@ #value node')]]
- [keys k (get@ #key node')]
- [values v (get@ #value node')]
- )
-
-(implementation: #export (equivalence (^open ",\."))
- (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v))))
-
- (def: (= reference sample)
- (let [(^open "/\.") (get@ #&order reference)]
- (loop [entriesR (entries reference)
- entriesS (entries sample)]
- (case [entriesR entriesS]
- [#.Nil #.Nil]
- #1
-
- [(#.Cons [keyR valueR] entriesR') (#.Cons [keyS valueS] entriesS')]
- (and (/\= keyR keyS)
- (,\= valueR valueS)
- (recur entriesR' entriesS'))
-
- _
- #0)))))
diff --git a/stdlib/source/lux/data/collection/dictionary/plist.lux b/stdlib/source/lux/data/collection/dictionary/plist.lux
deleted file mode 100644
index 320bf2f51..000000000
--- a/stdlib/source/lux/data/collection/dictionary/plist.lux
+++ /dev/null
@@ -1,97 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- ["." product]
- ["." text ("#\." equivalence)]
- [collection
- ["." list ("#\." functor)]]]
- [math
- [number
- ["n" nat]]]])
-
-(type: #export (PList a)
- (List [Text a]))
-
-(def: #export empty
- PList
- #.Nil)
-
-(def: #export size
- (All [a] (-> (PList a) Nat))
- list.size)
-
-(def: #export empty?
- (All [a] (-> (PList a) Bit))
- (|>> ..size (n.= 0)))
-
-(def: #export (get key properties)
- (All [a] (-> Text (PList a) (Maybe a)))
- (case properties
- #.Nil
- #.None
-
- (#.Cons [k' v'] properties')
- (if (text\= key k')
- (#.Some v')
- (get key properties'))))
-
-(template [<name> <type> <access>]
- [(def: #export <name>
- (All [a] (-> (PList a) (List <type>)))
- (list\map <access>))]
-
- [keys Text product.left]
- [values a product.right]
- )
-
-(def: #export (contains? key properties)
- (All [a] (-> Text (PList a) Bit))
- (case (..get key properties)
- (#.Some _)
- true
-
- #.None
- false))
-
-(def: #export (put key val properties)
- (All [a] (-> Text a (PList a) (PList a)))
- (case properties
- #.Nil
- (list [key val])
-
- (#.Cons [k' v'] properties')
- (if (text\= key k')
- (#.Cons [key val]
- properties')
- (#.Cons [k' v']
- (put key val properties')))))
-
-(def: #export (update key f properties)
- (All [a] (-> Text (-> a a) (PList a) (PList a)))
- (case properties
- #.Nil
- #.Nil
-
- (#.Cons [k' v'] properties')
- (if (text\= key k')
- (#.Cons [k' (f v')] properties')
- (#.Cons [k' v'] (update key f properties')))))
-
-(def: #export (remove key properties)
- (All [a] (-> Text (PList a) (PList a)))
- (case properties
- #.Nil
- properties
-
- (#.Cons [k' v'] properties')
- (if (text\= key k')
- properties'
- (#.Cons [k' v']
- (remove key properties')))))
-
-(def: #export equivalence
- (All [a] (-> (Equivalence a) (Equivalence (PList a))))
- (|>> (product.equivalence text.equivalence)
- list.equivalence))
diff --git a/stdlib/source/lux/data/collection/list.lux b/stdlib/source/lux/data/collection/list.lux
deleted file mode 100644
index 7bb2d4468..000000000
--- a/stdlib/source/lux/data/collection/list.lux
+++ /dev/null
@@ -1,615 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- [abstract
- [monoid (#+ Monoid)]
- [apply (#+ Apply)]
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]
- [fold (#+ Fold)]
- [predicate (#+ Predicate)]
- ["." functor (#+ Functor)]
- ["." monad (#+ do Monad)]
- ["." enum]]
- [data
- ["." bit]
- ["." product]]
- [math
- [number
- ["n" nat]]]])
-
-## (type: (List a)
-## #Nil
-## (#Cons a (List a)))
-
-(implementation: #export fold
- (Fold List)
-
- (def: (fold f init xs)
- (case xs
- #.Nil
- init
-
- (#.Cons x xs')
- (fold f (f x init) xs'))))
-
-(def: #export (folds f init inputs)
- (All [a b] (-> (-> a b b) b (List a) (List b)))
- (case inputs
- #.Nil
- (list init)
-
- (#.Cons [head tail])
- (#.Cons [init (folds f (f head init) tail)])))
-
-(def: #export (reverse xs)
- (All [a]
- (-> (List a) (List a)))
- (fold (function (_ head tail) (#.Cons head tail))
- #.Nil
- xs))
-
-(def: #export (filter keep? xs)
- (All [a]
- (-> (Predicate a) (List a) (List a)))
- (case xs
- #.Nil
- #.Nil
-
- (#.Cons x xs')
- (if (keep? x)
- (#.Cons x (filter keep? xs'))
- (filter keep? xs'))))
-
-(def: #export (partition satisfies? list)
- {#.doc "Divide the list into all elements that satisfy a predicate, and all elements that do not."}
- (All [a] (-> (Predicate a) (List a) [(List a) (List a)]))
- (case list
- #.Nil
- [#.Nil #.Nil]
-
- (#.Cons head tail)
- (let [[in out] (partition satisfies? tail)]
- (if (satisfies? head)
- [(#.Cons head in) out]
- [in (#.Cons head out)]))))
-
-(def: #export (as_pairs xs)
- {#.doc (doc "Cut the list into pairs of 2."
- "Caveat emptor: If the list has an uneven number of elements, the last one will be skipped.")}
- (All [a] (-> (List a) (List [a a])))
- (case xs
- (^ (list& x1 x2 xs'))
- (#.Cons [x1 x2] (as_pairs xs'))
-
- _
- #.Nil))
-
-(template [<name> <then> <else>]
- [(def: #export (<name> n xs)
- (All [a]
- (-> Nat (List a) (List a)))
- (if (n.> 0 n)
- (case xs
- #.Nil
- #.Nil
-
- (#.Cons x xs')
- <then>)
- <else>))]
-
- [take (#.Cons x (take (dec n) xs')) #.Nil]
- [drop (drop (dec n) xs') xs]
- )
-
-(template [<name> <then> <else>]
- [(def: #export (<name> predicate xs)
- (All [a]
- (-> (Predicate a) (List a) (List a)))
- (case xs
- #.Nil
- #.Nil
-
- (#.Cons x xs')
- (if (predicate x)
- <then>
- <else>)))]
-
- [take_while (#.Cons x (take_while predicate xs')) #.Nil]
- [drop_while (drop_while predicate xs') xs]
- )
-
-(def: #export (split n xs)
- (All [a]
- (-> Nat (List a) [(List a) (List a)]))
- (if (n.> 0 n)
- (case xs
- #.Nil
- [#.Nil #.Nil]
-
- (#.Cons x xs')
- (let [[tail rest] (split (dec n) xs')]
- [(#.Cons x tail) rest]))
- [#.Nil xs]))
-
-(def: (split_with' predicate ys xs)
- (All [a]
- (-> (Predicate a) (List a) (List a) [(List a) (List a)]))
- (case xs
- #.Nil
- [ys xs]
-
- (#.Cons x xs')
- (if (predicate x)
- (split_with' predicate (#.Cons x ys) xs')
- [ys xs])))
-
-(def: #export (split_with predicate xs)
- {#.doc "Segment the list by using a predicate to tell when to cut."}
- (All [a]
- (-> (Predicate a) (List a) [(List a) (List a)]))
- (let [[ys' xs'] (split_with' predicate #.Nil xs)]
- [(reverse ys') xs']))
-
-(def: #export (chunk n xs)
- {#.doc "Segment the list in chunks of size N."}
- (All [a] (-> Nat (List a) (List (List a))))
- (case xs
- #.Nil
- (list)
-
- _
- (let [[pre post] (split n xs)]
- (#.Cons pre (chunk n post)))))
-
-(def: #export (repeat n x)
- {#.doc "A list of the value x, repeated n times."}
- (All [a]
- (-> Nat a (List a)))
- (if (n.> 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')
- (#.Cons x (iterate' f x'))
-
- #.None
- (list)))
-
-(def: #export (iterate f x)
- {#.doc "Generates a list element by element until the function returns #.None."}
- (All [a]
- (-> (-> a (Maybe a)) a (List a)))
- (case (f x)
- (#.Some x')
- (#.Cons x (iterate' f x'))
-
- #.None
- (list x)))
-
-(def: #export (one check xs)
- (All [a b]
- (-> (-> a (Maybe b)) (List a) (Maybe b)))
- (case xs
- #.Nil
- #.None
-
- (#.Cons x xs')
- (case (check x)
- (#.Some output)
- (#.Some output)
-
- #.None
- (one check xs'))))
-
-(def: #export (all check xs)
- (All [a b]
- (-> (-> a (Maybe b)) (List a) (List b)))
- (for {## TODO: Stop relying on this ASAP.
- @.js
- (fold (function (_ head tail)
- (case (check head)
- (#.Some head)
- (#.Cons head tail)
-
- #.None
- tail))
- #.Nil
- (reverse xs))}
- (case xs
- #.Nil
- #.Nil
-
- (#.Cons x xs')
- (case (check x)
- (#.Some output)
- (#.Cons output (all check xs'))
-
- #.None
- (all check xs')))))
-
-(def: #export (find predicate xs)
- {#.doc "Returns the first value in the list for which the predicate is #1."}
- (All [a]
- (-> (Predicate a) (List a) (Maybe a)))
- (..one (function (_ value)
- (if (predicate value)
- (#.Some value)
- #.None))
- xs))
-
-(def: #export (interpose sep xs)
- {#.doc "Puts a value between every two elements in the list."}
- (All [a]
- (-> a (List a) (List a)))
- (case xs
- #.Nil
- xs
-
- (#.Cons x #.Nil)
- xs
-
- (#.Cons x xs')
- (list& x sep (interpose sep xs'))))
-
-(def: #export (size list)
- (All [a] (-> (List a) Nat))
- (fold (function (_ _ acc) (n.+ 1 acc)) 0 list))
-
-(template [<name> <init> <op>]
- [(def: #export (<name> predicate xs)
- (All [a]
- (-> (Predicate a) (List a) Bit))
- (loop [xs xs]
- (case xs
- #.Nil
- <init>
-
- (#.Cons x xs')
- (case (predicate x)
- <init>
- (recur xs')
-
- output
- output))))]
-
- [every? #1 and]
- [any? #0 or]
- )
-
-(def: #export (nth i xs)
- {#.doc "Fetches the element at the specified index."}
- (All [a]
- (-> Nat (List a) (Maybe a)))
- (case xs
- #.Nil
- #.None
-
- (#.Cons x xs')
- (if (n.= 0 i)
- (#.Some x)
- (nth (dec i) xs'))))
-
-(implementation: #export (equivalence Equivalence<a>)
- (All [a] (-> (Equivalence a) (Equivalence (List a))))
-
- (def: (= xs ys)
- (case [xs ys]
- [#.Nil #.Nil]
- #1
-
- [(#.Cons x xs') (#.Cons y ys')]
- (and (\ Equivalence<a> = x y)
- (= xs' ys'))
-
- [_ _]
- #0
- )))
-
-(implementation: #export (hash super)
- (All [a] (-> (Hash a) (Hash (List a))))
-
- (def: &equivalence
- (..equivalence (\ super &equivalence)))
-
- (def: hash
- (\ ..fold fold
- (function (_ member hash)
- (n.+ (\ super hash member) hash))
- 0)))
-
-(implementation: #export monoid
- (All [a] (Monoid (List a)))
-
- (def: identity #.Nil)
- (def: (compose xs ys)
- (case xs
- #.Nil
- ys
-
- (#.Cons x xs')
- (#.Cons x (compose xs' ys)))))
-
-(open: "." ..monoid)
-
-(implementation: #export functor
- (Functor List)
-
- (def: (map f ma)
- (case ma
- #.Nil
- #.Nil
-
- (#.Cons a ma')
- (#.Cons (f a) (map f ma')))))
-
-(open: "." ..functor)
-
-(implementation: #export apply
- (Apply List)
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (case ff
- #.Nil
- #.Nil
-
- (#.Cons f ff')
- (compose (map f fa) (apply ff' fa)))))
-
-(implementation: #export monad
- (Monad List)
-
- (def: &functor ..functor)
-
- (def: (wrap a)
- (#.Cons a #.Nil))
-
- (def: join (|>> reverse (fold compose identity))))
-
-(def: #export (sort < xs)
- (All [a] (-> (-> a a Bit) (List a) (List a)))
- (case xs
- #.Nil
- (list)
-
- (#.Cons x xs')
- (let [[pre post] (fold (function (_ x' [pre post])
- (if (< x x')
- [(#.Cons x' pre) post]
- [pre (#.Cons x' post)]))
- [(list) (list)]
- xs')]
- ($_ compose (sort < pre) (list x) (sort < post)))))
-
-(def: #export (empty? xs)
- (All [a] (Predicate (List a)))
- (case xs
- #.Nil
- true
-
- _
- false))
-
-(def: #export (member? eq xs x)
- (All [a] (-> (Equivalence a) (List a) a Bit))
- (case xs
- #.Nil
- #0
-
- (#.Cons x' xs')
- (or (\ eq = x x')
- (member? eq xs' x))))
-
-(template [<name> <output> <side> <doc>]
- [(def: #export (<name> xs)
- {#.doc <doc>}
- (All [a] (-> (List a) (Maybe <output>)))
- (case xs
- #.Nil
- #.None
-
- (#.Cons x xs')
- (#.Some <side>)))]
-
- [head a x "Returns the first element of a list."]
- [tail (List a) xs' "For a list of size N, returns the N-1 elements after the first one."]
- )
-
-(def: #export (indices size)
- {#.doc "Produces all the valid indices for a given size."}
- (All [a] (-> Nat (List Nat)))
- (if (n.= 0 size)
- (list)
- (|> size dec (enum.range n.enum 0))))
-
-(def: (identifier$ name)
- (-> Text Code)
- [["" 0 0] (#.Identifier "" name)])
-
-(def: (nat@encode value)
- (-> Nat Text)
- (loop [input value
- output ""]
- (let [digit (case (n.% 10 input)
- 0 "0"
- 1 "1"
- 2 "2"
- 3 "3"
- 4 "4"
- 5 "5"
- 6 "6"
- 7 "7"
- 8 "8"
- 9 "9"
- _ (undefined))
- output' ("lux text concat" digit output)
- input' (n./ 10 input)]
- (if (n.= 0 input')
- output'
- (recur input' output')))))
-
-(macro: #export (zip tokens state)
- {#.doc (doc "Create list zippers with the specified number of input lists."
- (def: #export zip/2 (zip 2))
- (def: #export zip/3 (zip 3))
- ((zip 3) xs ys zs))}
- (case tokens
- (^ (list [_ (#.Nat num_lists)]))
- (if (n.> 0 num_lists)
- (let [(^open ".") ..functor
- indices (..indices num_lists)
- type_vars (: (List Code) (map (|>> nat@encode identifier$) indices))
- zip_type (` (All [(~+ type_vars)]
- (-> (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var)))))
- type_vars))
- (List [(~+ type_vars)]))))
- vars+lists (|> indices
- (map inc)
- (map (function (_ idx)
- (let [base (nat@encode idx)]
- [(identifier$ base)
- (identifier$ ("lux text concat" base "'"))]))))
- pattern (` [(~+ (map (function (_ [v vs]) (` (#.Cons (~ v) (~ vs))))
- vars+lists))])
- g!step (identifier$ "0step0")
- g!blank (identifier$ "0,0")
- list_vars (map product.right vars+lists)
- code (` (: (~ zip_type)
- (function ((~ 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 "Cannot zip 0 lists."))
-
- _
- (#.Left "Wrong syntax for zip")))
-
-(def: #export zip/2 (zip 2))
-(def: #export zip/3 (zip 3))
-
-(macro: #export (zip_with tokens state)
- {#.doc (doc "Create list zippers with the specified number of input lists."
- (def: #export zip_with/2 (zip_with 2))
- (def: #export zip_with/3 (zip_with 3))
- ((zip_with 2) + xs ys))}
- (case tokens
- (^ (list [_ (#.Nat num_lists)]))
- (if (n.> 0 num_lists)
- (let [(^open ".") ..functor
- indices (..indices num_lists)
- g!return_type (identifier$ "0return_type0")
- g!func (identifier$ "0func0")
- type_vars (: (List Code) (map (|>> nat@encode identifier$) indices))
- zip_type (` (All [(~+ type_vars) (~ g!return_type)]
- (-> (-> (~+ type_vars) (~ g!return_type))
- (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var)))))
- type_vars))
- (List (~ g!return_type)))))
- vars+lists (|> indices
- (map inc)
- (map (function (_ idx)
- (let [base (nat@encode idx)]
- [(identifier$ base)
- (identifier$ ("lux text concat" base "'"))]))))
- pattern (` [(~+ (map (function (_ [v vs]) (` (#.Cons (~ v) (~ vs))))
- vars+lists))])
- g!step (identifier$ "0step0")
- g!blank (identifier$ "0,0")
- list_vars (map product.right vars+lists)
- code (` (: (~ zip_type)
- (function ((~ 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 "Cannot zip_with 0 lists."))
-
- _
- (#.Left "Wrong syntax for zip_with")))
-
-(def: #export zip_with/2 (zip_with 2))
-(def: #export zip_with/3 (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)
- {#.doc (doc "For a list of size N, returns the first N-1 elements."
- "Empty lists will result in a #.None value being returned instead.")}
- (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))
-
-(implementation: #export (with monad)
- (All [M] (-> (Monad M) (Monad (All [a] (M (List a))))))
-
- (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor))
-
- (def: wrap (|>> (\ ..monad wrap) (\ monad wrap)))
-
- (def: (join MlMla)
- (do {! monad}
- [lMla MlMla
- ## TODO: Remove this version ASAP and use one below.
- lla (for {@.old
- (: (($ 0) (List (List ($ 1))))
- (monad.seq ! lMla))}
- (monad.seq ! lMla))]
- (wrap (concat lla)))))
-
-(def: #export (lift monad)
- (All [M a] (-> (Monad M) (-> (M a) (M (List a)))))
- (\ monad map (\ ..monad wrap)))
-
-(def: #export (enumeration xs)
- {#.doc "Pairs every element in the list with its index, starting at 0."}
- (All [a] (-> (List a) (List [Nat a])))
- (loop [idx 0
- xs xs]
- (case xs
- #.Nil
- #.Nil
-
- (#.Cons x xs')
- (#.Cons [idx x] (recur (inc idx) xs')))))
diff --git a/stdlib/source/lux/data/collection/queue.lux b/stdlib/source/lux/data/collection/queue.lux
deleted file mode 100644
index 32ed05c64..000000000
--- a/stdlib/source/lux/data/collection/queue.lux
+++ /dev/null
@@ -1,92 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [functor (#+ Functor)]]
- [data
- [collection
- ["." list ("#\." monoid functor)]]]
- [math
- [number
- ["n" nat]]]])
-
-(type: #export (Queue a)
- {#front (List a)
- #rear (List a)})
-
-(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\compose 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]
- (n.+ (list.size front)
- (list.size rear))))
-
-(def: #export empty?
- (All [a] (-> (Queue a) Bit))
- (|>> (get@ #front) list.empty?))
-
-(def: #export (member? equivalence queue member)
- (All [a] (-> (Equivalence a) (Queue a) a Bit))
- (let [(^slots [#front #rear]) queue]
- (or (list.member? equivalence front member)
- (list.member? equivalence rear member))))
-
-(def: #export (pop queue)
- (All [a] (-> (Queue a) (Queue a)))
- (case (get@ #front queue)
- ## Empty...
- (^ (list))
- queue
-
- ## Front has dried up...
- (^ (list _))
- (|> queue
- (set@ #front (list.reverse (get@ #rear queue)))
- (set@ #rear (list)))
-
- ## Consume front!
- (^ (list& _ front'))
- (|> queue
- (set@ #front front'))))
-
-(def: #export (push val queue)
- (All [a] (-> a (Queue a) (Queue a)))
- (case (get@ #front queue)
- #.Nil
- (set@ #front (list val) queue)
-
- _
- (update@ #rear (|>> (#.Cons val)) queue)))
-
-(implementation: #export (equivalence super)
- (All [a] (-> (Equivalence a) (Equivalence (Queue a))))
-
- (def: (= reference subject)
- (\ (list.equivalence super) =
- (..to_list reference)
- (..to_list subject))))
-
-(implementation: #export functor
- (Functor Queue)
-
- (def: (map f fa)
- {#front (|> fa (get@ #front) (list\map f))
- #rear (|> fa (get@ #rear) (list\map f))}))
diff --git a/stdlib/source/lux/data/collection/queue/priority.lux b/stdlib/source/lux/data/collection/queue/priority.lux
deleted file mode 100644
index b7f971dd2..000000000
--- a/stdlib/source/lux/data/collection/queue/priority.lux
+++ /dev/null
@@ -1,120 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do Monad)]]
- [data
- ["." maybe]
- [collection
- ["." tree #_
- ["#" finger (#+ Tree)]]]]
- [math
- [number
- ["n" nat ("#\." interval)]]]
- [type (#+ :by_example)
- [abstract (#+ abstract: :abstraction :representation)]]])
-
-(type: #export Priority
- Nat)
-
-(def: #export max Priority n\top)
-(def: #export min Priority n\bottom)
-
-(def: builder
- (tree.builder n.maximum))
-
-(def: :@:
- (:by_example [@]
- (tree.Builder @ Priority)
- ..builder
-
- @))
-
-(abstract: #export (Queue a)
- (Maybe (Tree :@: Priority a))
-
- (def: #export empty
- Queue
- (:abstraction #.None))
-
- (def: #export (peek queue)
- (All [a] (-> (Queue a) (Maybe a)))
- (do maybe.monad
- [tree (:representation queue)]
- (tree.search (n.= (tree.tag tree))
- tree)))
-
- (def: #export (size queue)
- (All [a] (-> (Queue a) Nat))
- (case (:representation queue)
- #.None
- 0
-
- (#.Some tree)
- (loop [node tree]
- (case (tree.root node)
- (0 #0 _)
- 1
-
- (0 #1 [left right])
- (n.+ (recur left) (recur right))))))
-
- (def: #export (member? equivalence queue member)
- (All [a] (-> (Equivalence a) (Queue a) a Bit))
- (case (:representation queue)
- #.None
- false
-
- (#.Some tree)
- (loop [node tree]
- (case (tree.root node)
- (0 #0 reference)
- (\ equivalence = reference member)
-
- (0 #1 [left right])
- (or (recur left)
- (recur right))))))
-
- (def: #export (pop queue)
- (All [a] (-> (Queue a) (Queue a)))
- (:abstraction
- (do maybe.monad
- [tree (:representation queue)
- #let [highest_priority (tree.tag tree)]]
- (loop [node tree]
- (case (tree.root node)
- (0 #0 reference)
- (if (n.= highest_priority (tree.tag node))
- #.None
- (#.Some node))
-
- (0 #1 left right)
- (if (n.= highest_priority (tree.tag left))
- (case (recur left)
- #.None
- (#.Some right)
-
- (#.Some =left)
- (#.Some (\ ..builder branch =left right)))
- (case (recur right)
- #.None
- (#.Some left)
-
- (#.Some =right)
- (#.Some (\ ..builder branch left =right)))))))))
-
- (def: #export (push priority value queue)
- (All [a] (-> Priority a (Queue a) (Queue a)))
- (let [addition (\ ..builder leaf priority value)]
- (:abstraction
- (case (:representation queue)
- #.None
- (#.Some addition)
-
- (#.Some tree)
- (#.Some (\ ..builder branch tree addition))))))
- )
-
-(def: #export empty?
- (All [a] (-> (Queue a) Bit))
- (|>> ..size (n.= 0)))
diff --git a/stdlib/source/lux/data/collection/row.lux b/stdlib/source/lux/data/collection/row.lux
deleted file mode 100644
index abadcfd7a..000000000
--- a/stdlib/source/lux/data/collection/row.lux
+++ /dev/null
@@ -1,489 +0,0 @@
-## https://hypirion.com/musings/understanding-persistent-vector-pt-1
-## https://hypirion.com/musings/understanding-persistent-vector-pt-2
-## https://hypirion.com/musings/understanding-persistent-vector-pt-3
-(.module:
- [lux #*
- ["@" target]
- [abstract
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- [monad (#+ Monad do)]
- [equivalence (#+ Equivalence)]
- [monoid (#+ Monoid)]
- [fold (#+ Fold)]
- [predicate (#+ Predicate)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["p" parser
- ["s" code (#+ Parser)]]]
- [data
- ["." maybe]
- ["." product]
- [collection
- ["." list ("#\." fold functor monoid)]
- ["." array (#+ Array) ("#\." functor fold)]]]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number
- ["." i64]
- ["n" nat]]]])
-
-(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)
-
-(template [<name> <op>]
- [(def: <name>
- (-> Level Level)
- (<op> branching_exponent))]
-
- [level_up n.+]
- [level_down n.-]
- )
-
-(def: full_node_size
- Nat
- (i64.left_shift branching_exponent 1))
-
-(def: branch_idx_mask
- Nat
- (dec full_node_size))
-
-(def: branch_idx
- (-> Index Index)
- (i64.and branch_idx_mask))
-
-(def: (new_hierarchy _)
- (All [a] (-> Any (Hierarchy a)))
- (array.new full_node_size))
-
-(def: (tail_off row_size)
- (-> Nat Nat)
- (if (n.< full_node_size row_size)
- 0
- (|> (dec row_size)
- (i64.right_shift branching_exponent)
- (i64.left_shift branching_exponent))))
-
-(def: (new_path level tail)
- (All [a] (-> Level (Base a) (Node a)))
- (if (n.= 0 level)
- (#Base tail)
- (|> (new_hierarchy [])
- (array.write! 0 (new_path (level_down level) tail))
- #Hierarchy)))
-
-(def: (new_tail singleton)
- (All [a] (-> a (Base a)))
- (|> (array.new 1)
- (array.write! 0 singleton)))
-
-(def: (push_tail size level tail parent)
- (All [a] (-> Nat Level (Base a) (Hierarchy a) (Hierarchy a)))
- (let [sub_idx (branch_idx (i64.right_shift level (dec size)))
- ## If we're currently on a bottom node
- sub_node (if (n.= branching_exponent level)
- ## Just add the tail to it
- (#Base tail)
- ## Otherwise, check whether there's a vacant spot
- (case (array.read 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.write! sub_idx sub_node))))
-
-(def: (expand_tail val tail)
- (All [a] (-> a (Base a) (Base a)))
- (let [tail_size (array.size tail)]
- (|> (array.new (inc tail_size))
- (array.copy! tail_size 0 tail 0)
- (array.write! tail_size val))))
-
-(def: (put' level idx val hierarchy)
- (All [a] (-> Level Index a (Hierarchy a) (Hierarchy a)))
- (let [sub_idx (branch_idx (i64.right_shift level idx))]
- (case (array.read sub_idx hierarchy)
- (#.Some (#Hierarchy sub_node))
- (|> (array.clone hierarchy)
- (array.write! sub_idx (#Hierarchy (put' (level_down level) idx val sub_node))))
-
- (^multi (#.Some (#Base base))
- (n.= 0 (level_down level)))
- (|> (array.clone hierarchy)
- (array.write! sub_idx (|> (array.clone base)
- (array.write! (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 (i64.right_shift level (n.- 2 size)))]
- (cond (n.= 0 sub_idx)
- #.None
-
- (n.> branching_exponent level)
- (do maybe.monad
- [base|hierarchy (array.read sub_idx hierarchy)
- sub (case base|hierarchy
- (#Hierarchy sub)
- (pop_tail size (level_down level) sub)
-
- (#Base _)
- (undefined))]
- (|> (array.clone hierarchy)
- (array.write! sub_idx (#Hierarchy sub))
- #.Some))
-
- ## Else...
- (|> (array.clone hierarchy)
- (array.delete! 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 (function (_ sub acc) (list\compose (to_list' sub) acc))
- #.Nil))))
-
-(type: #export (Row a)
- {#level Level
- #size Nat
- #root (Hierarchy a)
- #tail (Base a)})
-
-(def: #export empty
- Row
- {#level (level_up root_level)
- #size 0
- #root (array.new full_node_size)
- #tail (array.new 0)})
-
-(def: #export (size row)
- (All [a] (-> (Row a) Nat))
- (get@ #size row))
-
-(def: #export (add val row)
- (All [a] (-> a (Row a) (Row a)))
- ## Check if there is room in the tail.
- (let [row_size (get@ #size row)]
- (if (|> row_size (n.- (tail_off row_size)) (n.< full_node_size))
- ## If so, append to it.
- (|> row
- (update@ #size inc)
- (update@ #tail (expand_tail val)))
- ## Otherwise, push tail into the tree
- ## --------------------------------------------------------
- ## Will the root experience an overflow with this addition?
- (|> (if (n.> (i64.left_shift (get@ #level row) 1)
- (i64.right_shift branching_exponent row_size))
- ## If so, a brand-new root must be established, that is
- ## 1-level taller.
- (|> row
- (set@ #root (|> (for {@.old
- (: (Hierarchy ($ 0))
- (new_hierarchy []))}
- (new_hierarchy []))
- (array.write! 0 (#Hierarchy (get@ #root row)))
- (array.write! 1 (new_path (get@ #level row) (get@ #tail row)))))
- (update@ #level level_up))
- ## Otherwise, just push the current tail onto the root.
- (|> row
- (update@ #root (push_tail row_size (get@ #level row) (get@ #tail row)))))
- ## Finally, update the size of the row and grow a new
- ## tail with the new element as it's sole member.
- (update@ #size inc)
- (set@ #tail (new_tail val)))
- )))
-
-(exception: incorrect_row_structure)
-
-(exception: #export [a] (index_out_of_bounds {row (Row a)} {index Nat})
- (exception.report ["Size" (\ n.decimal encode (get@ #size row))]
- ["Index" (\ n.decimal encode index)]))
-
-(exception: base_was_not_found)
-
-(def: #export (within_bounds? row idx)
- (All [a] (-> (Row a) Nat Bit))
- (n.< (get@ #size row) idx))
-
-(def: (base_for idx row)
- (All [a] (-> Index (Row a) (Try (Base a))))
- (if (within_bounds? row idx)
- (if (n.>= (tail_off (get@ #size row)) idx)
- (#try.Success (get@ #tail row))
- (loop [level (get@ #level row)
- hierarchy (get@ #root row)]
- (case [(n.> branching_exponent level)
- (array.read (branch_idx (i64.right_shift level idx)) hierarchy)]
- [#1 (#.Some (#Hierarchy sub))]
- (recur (level_down level) sub)
-
- [#0 (#.Some (#Base base))]
- (#try.Success base)
-
- [_ #.None]
- (exception.throw ..base_was_not_found [])
-
- _
- (exception.throw ..incorrect_row_structure []))))
- (exception.throw ..index_out_of_bounds [row idx])))
-
-(def: #export (nth idx row)
- (All [a] (-> Nat (Row a) (Try a)))
- (do try.monad
- [base (base_for idx row)]
- (case (array.read (branch_idx idx) base)
- (#.Some value)
- (#try.Success value)
-
- #.None
- (exception.throw ..incorrect_row_structure []))))
-
-(def: #export (put idx val row)
- (All [a] (-> Nat a (Row a) (Try (Row a))))
- (let [row_size (get@ #size row)]
- (if (within_bounds? row idx)
- (#try.Success (if (n.>= (tail_off row_size) idx)
- (update@ #tail (for {@.old
- (: (-> (Base ($ 0)) (Base ($ 0)))
- (|>> array.clone (array.write! (branch_idx idx) val)))}
- (|>> array.clone (array.write! (branch_idx idx) val)))
- row)
- (update@ #root (put' (get@ #level row) idx val)
- row)))
- (exception.throw ..index_out_of_bounds [row idx]))))
-
-(def: #export (update idx f row)
- (All [a] (-> Nat (-> a a) (Row a) (Try (Row a))))
- (do try.monad
- [val (..nth idx row)]
- (..put idx (f val) row)))
-
-(def: #export (pop row)
- (All [a] (-> (Row a) (Row a)))
- (case (get@ #size row)
- 0
- empty
-
- 1
- empty
-
- row_size
- (if (|> row_size (n.- (tail_off row_size)) (n.> 1))
- (let [old_tail (get@ #tail row)
- new_tail_size (dec (array.size old_tail))]
- (|> row
- (update@ #size dec)
- (set@ #tail (|> (array.new new_tail_size)
- (array.copy! new_tail_size 0 old_tail 0)))))
- (maybe.assume
- (do maybe.monad
- [new_tail (base_for (n.- 2 row_size) row)
- #let [[level' root'] (let [init_level (get@ #level row)]
- (loop [level init_level
- root (maybe.default (new_hierarchy [])
- (pop_tail row_size init_level (get@ #root row)))]
- (if (n.> branching_exponent level)
- (case [(array.read 1 root) (array.read 0 root)]
- [#.None (#.Some (#Hierarchy sub_node))]
- (recur (level_down level) sub_node)
-
- ## [#.None (#.Some (#Base _))]
- ## (undefined)
-
- _
- [level root])
- [level root])))]]
- (wrap (|> row
- (update@ #size dec)
- (set@ #level level')
- (set@ #root root')
- (set@ #tail new_tail))))))
- ))
-
-(def: #export (to_list row)
- (All [a] (-> (Row a) (List a)))
- (list\compose (to_list' (#Hierarchy (get@ #root row)))
- (to_list' (#Base (get@ #tail row)))))
-
-(def: #export from_list
- (All [a] (-> (List a) (Row a)))
- (list\fold ..add ..empty))
-
-(def: #export (member? a/Equivalence row val)
- (All [a] (-> (Equivalence a) (Row a) a Bit))
- (list.member? a/Equivalence (to_list row) val))
-
-(def: #export empty?
- (All [a] (-> (Row a) Bit))
- (|>> (get@ #size) (n.= 0)))
-
-(syntax: #export (row {elems (p.some s.any)})
- {#.doc (doc "Row literals."
- (row +10 +20 +30 +40))}
- (wrap (list (` (..from_list (list (~+ elems)))))))
-
-(implementation: (node_equivalence Equivalence<a>)
- (All [a] (-> (Equivalence a) (Equivalence (Node a))))
-
- (def: (= v1 v2)
- (case [v1 v2]
- [(#Base b1) (#Base b2)]
- (\ (array.equivalence Equivalence<a>) = b1 b2)
-
- [(#Hierarchy h1) (#Hierarchy h2)]
- (\ (array.equivalence (node_equivalence Equivalence<a>)) = h1 h2)
-
- _
- #0)))
-
-(implementation: #export (equivalence Equivalence<a>)
- (All [a] (-> (Equivalence a) (Equivalence (Row a))))
-
- (def: (= v1 v2)
- (and (n.= (get@ #size v1) (get@ #size v2))
- (let [(^open "node\.") (node_equivalence Equivalence<a>)]
- (and (node\= (#Base (get@ #tail v1))
- (#Base (get@ #tail v2)))
- (node\= (#Hierarchy (get@ #root v1))
- (#Hierarchy (get@ #root v2))))))))
-
-(implementation: node_fold
- (Fold Node)
-
- (def: (fold f init xs)
- (case xs
- (#Base base)
- (array\fold f init base)
-
- (#Hierarchy hierarchy)
- (array\fold (function (_ node init') (fold f init' node))
- init
- hierarchy))))
-
-(implementation: #export fold
- (Fold Row)
-
- (def: (fold f init xs)
- (let [(^open ".") node_fold]
- (fold f
- (fold f
- init
- (#Hierarchy (get@ #root xs)))
- (#Base (get@ #tail xs))))))
-
-(implementation: #export monoid
- (All [a] (Monoid (Row a)))
-
- (def: identity ..empty)
-
- (def: (compose xs ys)
- (list\fold add xs (..to_list ys))))
-
-(implementation: node_functor
- (Functor Node)
-
- (def: (map f xs)
- (case xs
- (#Base base)
- (#Base (array\map f base))
-
- (#Hierarchy hierarchy)
- (#Hierarchy (array\map (map f) hierarchy)))))
-
-(implementation: #export functor
- (Functor Row)
-
- (def: (map f xs)
- {#level (get@ #level xs)
- #size (get@ #size xs)
- #root (|> xs (get@ #root) (array\map (\ node_functor map f)))
- #tail (|> xs (get@ #tail) (array\map f))}))
-
-(implementation: #export apply
- (Apply Row)
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (let [(^open ".") ..functor
- (^open ".") ..fold
- (^open ".") ..monoid
- results (map (function (_ f) (map f fa))
- ff)]
- (fold compose identity results))))
-
-(implementation: #export monad
- (Monad Row)
-
- (def: &functor ..functor)
-
- (def: wrap (|>> row))
-
- (def: join
- (let [(^open ".") ..fold
- (^open ".") ..monoid]
- (fold (function (_ post pre) (compose pre post)) identity))))
-
-(def: #export reverse
- (All [a] (-> (Row a) (Row a)))
- (|>> ..to_list list.reverse (list\fold add ..empty)))
-
-(template [<name> <array> <init> <op>]
- [(def: #export <name>
- (All [a]
- (-> (Predicate a) (Row a) Bit))
- (let [help (: (All [a]
- (-> (Predicate a) (Node a) Bit))
- (function (help predicate node)
- (case node
- (#Base base)
- (<array> predicate base)
-
- (#Hierarchy hierarchy)
- (<array> (help predicate) hierarchy))))]
- (function (<name> predicate row)
- (let [(^slots [#root #tail]) row]
- (<op> (help predicate (#Hierarchy root))
- (help predicate (#Base tail)))))))]
-
- [every? array.every? #1 and]
- [any? array.any? #0 or]
- )
diff --git a/stdlib/source/lux/data/collection/sequence.lux b/stdlib/source/lux/data/collection/sequence.lux
deleted file mode 100644
index c3d2a5e33..000000000
--- a/stdlib/source/lux/data/collection/sequence.lux
+++ /dev/null
@@ -1,150 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [functor (#+ Functor)]
- [comonad (#+ CoMonad)]]
- [control
- ["//" continuation (#+ Cont)]
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]]
- [data
- ["." bit]
- [collection
- ["." list ("#\." monad)]]]
- [math
- [number
- ["n" nat]]]])
-
-(type: #export (Sequence a)
- {#.doc "An infinite sequence of values."}
- (Cont [a (Sequence a)]))
-
-(def: #export (iterate f x)
- {#.doc "Create a sequence by applying a function to a value, and to its result, on and on..."}
- (All [a]
- (-> (-> a a) a (Sequence a)))
- (//.pending [x (iterate f (f x))]))
-
-(def: #export (repeat x)
- {#.doc "Repeat a value forever."}
- (All [a]
- (-> a (Sequence a)))
- (//.pending [x (repeat x)]))
-
-(def: #export (cycle [start next])
- {#.doc (doc "Go over the elements of a list forever."
- "The list should not be empty.")}
- (All [a]
- (-> [a (List a)] (Sequence a)))
- (loop [head start
- tail next]
- (//.pending [head (case tail
- #.Nil
- (recur start next)
-
- (#.Cons head' tail')
- (recur head' tail'))])))
-
-(template [<name> <return>]
- [(def: #export (<name> sequence)
- (All [a] (-> (Sequence a) <return>))
- (let [[head tail] (//.run sequence)]
- <name>))]
-
- [head a]
- [tail (Sequence a)]
- )
-
-(def: #export (nth idx sequence)
- (All [a] (-> Nat (Sequence a) a))
- (let [[head tail] (//.run sequence)]
- (case idx
- 0 head
- _ (nth (dec idx) tail))))
-
-(template [<taker> <dropper> <splitter> <pred_type> <pred_test> <pred_step>]
- [(def: #export (<taker> pred xs)
- (All [a]
- (-> <pred_type> (Sequence a) (List a)))
- (let [[x xs'] (//.run xs)]
- (if <pred_test>
- (list& x (<taker> <pred_step> xs'))
- (list))))
-
- (def: #export (<dropper> pred xs)
- (All [a]
- (-> <pred_type> (Sequence a) (Sequence a)))
- (let [[x xs'] (//.run xs)]
- (if <pred_test>
- (<dropper> <pred_step> xs')
- xs)))
-
- (def: #export (<splitter> pred xs)
- (All [a]
- (-> <pred_type> (Sequence a) [(List a) (Sequence a)]))
- (let [[x xs'] (//.run xs)]
- (if <pred_test>
- (let [[tail next] (<splitter> <pred_step> xs')]
- [(#.Cons [x tail]) next])
- [(list) xs])))]
-
- [take_while drop_while split_while (-> a Bit) (pred x) pred]
- [take drop split Nat (n.> 0 pred) (dec pred)]
- )
-
-(def: #export (unfold step init)
- {#.doc "A stateful way of infinitely calculating the values of a sequence."}
- (All [a b]
- (-> (-> a [a b]) a (Sequence b)))
- (let [[next x] (step init)]
- (//.pending [x (unfold step next)])))
-
-(def: #export (filter predicate sequence)
- (All [a] (-> (-> a Bit) (Sequence a) (Sequence a)))
- (let [[head tail] (//.run sequence)]
- (if (predicate head)
- (//.pending [head (filter predicate tail)])
- (filter predicate tail))))
-
-(def: #export (partition left? xs)
- {#.doc (doc "Split a sequence in two based on a predicate."
- "The left side contains all entries for which the predicate is #1."
- "The right side contains all entries for which the predicate is #0.")}
- (All [a] (-> (-> a Bit) (Sequence a) [(Sequence a) (Sequence a)]))
- [(filter left? xs) (filter (bit.complement left?) xs)])
-
-(implementation: #export functor
- (Functor Sequence)
-
- (def: (map f fa)
- (let [[head tail] (//.run fa)]
- (//.pending [(f head) (map f tail)]))))
-
-(implementation: #export comonad
- (CoMonad Sequence)
-
- (def: &functor ..functor)
-
- (def: unwrap head)
-
- (def: (split wa)
- (let [[head tail] (//.run wa)]
- (//.pending [wa (split tail)]))))
-
-(syntax: #export (^sequence& {patterns (<code>.form (<>.many <code>.any))}
- body
- {branches (<>.some <code>.any)})
- {#.doc (doc "Allows destructuring of sequences in pattern-matching expressions."
- "Caveat emptor: Only use it for destructuring, and not for testing values within the sequences."
- (let [(^sequence& x y z _tail) (some_sequence_func +1 +2 +3)]
- (func x y z)))}
- (with_gensyms [g!sequence]
- (let [body+ (` (let [(~+ (list\join (list\map (function (_ pattern)
- (list (` [(~ pattern) (~ g!sequence)])
- (` ((~! //.run) (~ g!sequence)))))
- patterns)))]
- (~ body)))]
- (wrap (list& g!sequence body+ branches)))))
diff --git a/stdlib/source/lux/data/collection/set.lux b/stdlib/source/lux/data/collection/set.lux
deleted file mode 100644
index 4c1fabde0..000000000
--- a/stdlib/source/lux/data/collection/set.lux
+++ /dev/null
@@ -1,104 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]
- [predicate (#+ Predicate)]
- [monoid (#+ Monoid)]]
- [data
- [collection
- ["." list ("#\." fold)]]]
- [math
- [number
- ["n" nat]]]]
- ["." // #_
- ["#" dictionary (#+ Dictionary)]])
-
-(type: #export (Set a)
- (Dictionary a Any))
-
-(def: #export member_hash
- (All [a] (-> (Set a) (Hash a)))
- //.key_hash)
-
-(def: #export new
- (All [a] (-> (Hash a) (Set a)))
- //.new)
-
-(def: #export size
- (All [a] (-> (Set a) Nat))
- //.size)
-
-(def: #export (add elem set)
- (All [a] (-> a (Set a) (Set a)))
- (|> set (//.put elem [])))
-
-(def: #export remove
- (All [a] (-> a (Set a) (Set a)))
- //.remove)
-
-(def: #export member?
- (All [a] (-> (Set a) a Bit))
- //.key?)
-
-(def: #export to_list
- (All [a] (-> (Set a) (List a)))
- //.keys)
-
-(def: #export union
- (All [a] (-> (Set a) (Set a) (Set a)))
- //.merge)
-
-(def: #export (difference sub base)
- (All [a] (-> (Set a) (Set a) (Set a)))
- (list\fold ..remove base (..to_list sub)))
-
-(def: #export (intersection filter base)
- (All [a] (-> (Set a) (Set a) (Set a)))
- (//.select (//.keys filter)
- base))
-
-(implementation: #export equivalence
- (All [a] (Equivalence (Set a)))
-
- (def: (= (^@ reference [hash _]) sample)
- (and (n.= (..size reference)
- (..size sample))
- (list.every? (..member? reference)
- (..to_list sample)))))
-
-(implementation: #export hash
- (All [a] (Hash (Set a)))
-
- (def: &equivalence ..equivalence)
-
- (def: (hash set)
- (|> set
- ..to_list
- (\ (list.hash (..member_hash set)) hash))))
-
-(implementation: #export (monoid hash)
- (All [a] (-> (Hash a) (Monoid (Set a))))
-
- (def: identity (..new hash))
- (def: compose ..union))
-
-(def: #export empty?
- (All [a] (-> (Set a) Bit))
- (|>> ..size (n.= 0)))
-
-(def: #export (from_list hash elements)
- (All [a] (-> (Hash a) (List a) (Set a)))
- (list\fold ..add (..new hash) elements))
-
-(def: #export (sub? super sub)
- (All [a] (-> (Set a) (Set a) Bit))
- (list.every? (..member? super) (..to_list sub)))
-
-(def: #export (super? sub super)
- (All [a] (-> (Set a) (Set a) Bit))
- (..sub? super sub))
-
-(def: #export predicate
- (All [a] (-> (Set a) (Predicate a)))
- ..member?)
diff --git a/stdlib/source/lux/data/collection/set/multi.lux b/stdlib/source/lux/data/collection/set/multi.lux
deleted file mode 100644
index 9e494608e..000000000
--- a/stdlib/source/lux/data/collection/set/multi.lux
+++ /dev/null
@@ -1,157 +0,0 @@
-## https://en.wikipedia.org/wiki/Multiset
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]]
- [control
- ["." function]]
- [math
- [number
- ["n" nat]]]
- [type
- [abstract (#+ abstract: :abstraction :representation ^:representation)]]]
- ["." //
- [//
- ["." list ("#\." fold monoid)]
- ["." dictionary (#+ Dictionary)]
- [//
- ["." maybe]]]])
-
-(abstract: #export (Set a)
- (Dictionary a Nat)
-
- (def: #export new
- (All [a] (-> (Hash a) (Set a)))
- (|>> dictionary.new :abstraction))
-
- (def: #export size
- (All [a] (-> (Set a) Nat))
- (|>> :representation dictionary.values (list\fold n.+ 0)))
-
- (def: #export (add multiplicity elem set)
- (All [a] (-> Nat a (Set a) (Set a)))
- (case multiplicity
- 0 set
- _ (|> set
- :representation
- (dictionary.upsert elem 0 (n.+ multiplicity))
- :abstraction)))
-
- (def: #export (remove multiplicity elem set)
- (All [a] (-> Nat a (Set a) (Set a)))
- (case multiplicity
- 0 set
- _ (case (dictionary.get elem (:representation set))
- (#.Some current)
- (:abstraction
- (if (n.> multiplicity current)
- (dictionary.update elem (n.- multiplicity) (:representation set))
- (dictionary.remove elem (:representation set))))
-
- #.None
- set)))
-
- (def: #export (multiplicity set elem)
- (All [a] (-> (Set a) a Nat))
- (|> set :representation (dictionary.get elem) (maybe.default 0)))
-
- (def: #export to_list
- (All [a] (-> (Set a) (List a)))
- (|>> :representation
- dictionary.entries
- (list\fold (function (_ [elem multiplicity] output)
- (list\compose (list.repeat multiplicity elem) output))
- #.Nil)))
-
- (template [<name> <compose>]
- [(def: #export (<name> parameter subject)
- (All [a] (-> (Set a) (Set a) (Set a)))
- (:abstraction (dictionary.merge_with <compose> (:representation parameter) (:representation subject))))]
-
- [union n.max]
- [sum n.+]
- )
-
- (def: #export (intersection parameter (^:representation subject))
- (All [a] (-> (Set a) (Set a) (Set a)))
- (list\fold (function (_ [elem multiplicity] output)
- (..add (n.min (..multiplicity parameter elem)
- multiplicity)
- elem
- output))
- (..new (dictionary.key_hash subject))
- (dictionary.entries subject)))
-
- (def: #export (difference parameter subject)
- (All [a] (-> (Set a) (Set a) (Set a)))
- (|> parameter
- :representation
- dictionary.entries
- (list\fold (function (_ [elem multiplicity] output)
- (..remove multiplicity elem output))
- subject)))
-
- (def: #export (sub? reference subject)
- (All [a] (-> (Set a) (Set a) Bit))
- (|> subject
- :representation
- dictionary.entries
- (list.every? (function (_ [elem multiplicity])
- (|> elem
- (..multiplicity reference)
- (n.>= multiplicity))))))
-
- (def: #export (support set)
- (All [a] (-> (Set a) (//.Set a)))
- (let [(^@ set [hash _]) (:representation set)]
- (|> set
- dictionary.keys
- (//.from_list hash))))
-
- (implementation: #export equivalence
- (All [a] (Equivalence (Set a)))
-
- (def: (= (^:representation reference) sample)
- (and (n.= (dictionary.size reference)
- (dictionary.size (:representation sample)))
- (|> reference
- dictionary.entries
- (list.every? (function (_ [elem multiplicity])
- (|> elem
- (..multiplicity sample)
- (n.= multiplicity))))))))
-
- (implementation: #export hash
- (All [a] (Hash (Set a)))
-
- (def: &equivalence ..equivalence)
-
- (def: (hash (^:representation set))
- (let [[hash _] set]
- (list\fold (function (_ [elem multiplicity] acc)
- (|> elem (\ hash hash) (n.* multiplicity) (n.+ acc)))
- 0
- (dictionary.entries set)))))
- )
-
-(def: #export (member? set elem)
- (All [a] (-> (Set a) a Bit))
- (|> elem (..multiplicity set) (n.> 0)))
-
-(def: #export empty?
- (All [a] (-> (Set a) Bit))
- (|>> ..size (n.= 0)))
-
-(def: #export (from_list hash subject)
- (All [a] (-> (Hash a) (List a) (Set a)))
- (list\fold (..add 1) (..new hash) subject))
-
-(def: #export (from_set subject)
- (All [a] (-> (//.Set a) (Set a)))
- (..from_list (//.member_hash subject)
- (//.to_list subject)))
-
-(def: #export super?
- (All [a] (-> (Set a) (Set a) Bit))
- (function.flip sub?))
diff --git a/stdlib/source/lux/data/collection/set/ordered.lux b/stdlib/source/lux/data/collection/set/ordered.lux
deleted file mode 100644
index 1b57ac87d..000000000
--- a/stdlib/source/lux/data/collection/set/ordered.lux
+++ /dev/null
@@ -1,84 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]]
- [data
- [collection
- ["." list ("#\." fold)]
- [dictionary
- ["/" ordered]]]]
- [type
- abstract]])
-
-(abstract: #export (Set a)
- (/.Dictionary a a)
-
- (def: #export new
- (All [a] (-> (Order a) (Set a)))
- (|>> /.new :abstraction))
-
- (def: #export (member? set elem)
- (All [a] (-> (Set a) a Bit))
- (/.key? (:representation set) elem))
-
- (template [<type> <name> <alias>]
- [(def: #export <name>
- (All [a] (-> (Set a) <type>))
- (|>> :representation <alias>))]
-
- [(Maybe a) min /.min]
- [(Maybe a) max /.max]
- [Nat size /.size]
- [Bit empty? /.empty?]
- )
-
- (def: #export (add elem set)
- (All [a] (-> a (Set a) (Set a)))
- (|> set :representation (/.put elem elem) :abstraction))
-
- (def: #export (remove elem set)
- (All [a] (-> a (Set a) (Set a)))
- (|> set :representation (/.remove elem) :abstraction))
-
- (def: #export to_list
- (All [a] (-> (Set a) (List a)))
- (|>> :representation /.keys))
-
- (def: #export (from_list &order list)
- (All [a] (-> (Order a) (List a) (Set a)))
- (list\fold add (..new &order) list))
-
- (def: #export (union left right)
- (All [a] (-> (Set a) (Set a) (Set a)))
- (list\fold ..add right (..to_list left)))
-
- (def: #export (intersection left right)
- (All [a] (-> (Set a) (Set a) (Set a)))
- (|> (..to_list right)
- (list.filter (..member? left))
- (..from_list (get@ #/.&order (:representation right)))))
-
- (def: #export (difference param subject)
- (All [a] (-> (Set a) (Set a) (Set a)))
- (|> (..to_list subject)
- (list.filter (|>> (..member? param) not))
- (..from_list (get@ #/.&order (:representation subject)))))
-
- (implementation: #export equivalence
- (All [a] (Equivalence (Set a)))
-
- (def: (= reference sample)
- (\ (list.equivalence (\ (:representation reference) &equivalence))
- = (..to_list reference) (..to_list sample))))
- )
-
-(def: #export (sub? super sub)
- (All [a] (-> (Set a) (Set a) Bit))
- (|> sub
- ..to_list
- (list.every? (..member? super))))
-
-(def: #export (super? sub super)
- (All [a] (-> (Set a) (Set a) Bit))
- (sub? super sub))
diff --git a/stdlib/source/lux/data/collection/stack.lux b/stdlib/source/lux/data/collection/stack.lux
deleted file mode 100644
index 68d514331..000000000
--- a/stdlib/source/lux/data/collection/stack.lux
+++ /dev/null
@@ -1,65 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [functor (#+ Functor)]]
- [data
- [collection
- ["//" list]]]
- [type
- abstract]])
-
-(abstract: #export (Stack a)
- (List a)
-
- (def: #export empty
- Stack
- (:abstraction (list)))
-
- (def: #export size
- (All [a] (-> (Stack a) Nat))
- (|>> :representation //.size))
-
- (def: #export empty?
- (All [a] (-> (Stack a) Bit))
- (|>> :representation //.empty?))
-
- (def: #export (peek stack)
- (All [a] (-> (Stack a) (Maybe a)))
- (case (:representation stack)
- #.Nil
- #.None
-
- (#.Cons value _)
- (#.Some value)))
-
- (def: #export (pop stack)
- (All [a] (-> (Stack a) (Maybe [a (Stack a)])))
- (case (:representation stack)
- #.Nil
- #.None
-
- (#.Cons top stack')
- (#.Some [top (:abstraction stack')])))
-
- (def: #export (push value stack)
- (All [a] (-> a (Stack a) (Stack a)))
- (:abstraction (#.Cons value (:representation stack))))
-
- (implementation: #export (equivalence super)
- (All [a]
- (-> (Equivalence a)
- (Equivalence (Stack a))))
-
- (def: (= reference subject)
- (\ (//.equivalence super) = (:representation reference) (:representation subject))))
-
- (implementation: #export functor
- (Functor Stack)
-
- (def: (map f value)
- (|> value
- :representation
- (\ //.functor map f)
- :abstraction)))
- )
diff --git a/stdlib/source/lux/data/collection/tree.lux b/stdlib/source/lux/data/collection/tree.lux
deleted file mode 100644
index 5aa6f9c36..000000000
--- a/stdlib/source/lux/data/collection/tree.lux
+++ /dev/null
@@ -1,84 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [functor (#+ Functor)]
- [equivalence (#+ Equivalence)]
- [fold (#+ Fold)]
- [monad (#+ do)]]
- [control
- ["<>" parser
- ["<c>" code (#+ Parser)]]]
- [data
- [collection
- ["." list ("#\." monad fold)]]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]]])
-
-(type: #export (Tree a)
- {#value a
- #children (List (Tree a))})
-
-(def: #export (flatten tree)
- (All [a] (-> (Tree a) (List a)))
- (#.Cons (get@ #value tree)
- (list\join (list\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})
-
-(type: #rec Tree-Code
- [Code (List Tree-Code)])
-
-(def: tree^
- (Parser Tree-Code)
- (|> (|>> <>.some
- <c>.record
- (<>.and <c>.any))
- <>.rec
- <>.some
- <c>.record
- (<>.default (list))
- (<>.and <c>.any)))
-
-(syntax: #export (tree {root tree^})
- {#.doc (doc "Tree literals."
- (: (Tree Nat)
- (tree 10
- {20 {}
- 30 {}
- 40 {}})))}
- (wrap (list (` (~ (loop [[value children] root]
- (` {#value (~ value)
- #children (list (~+ (list\map recur children)))})))))))
-
-(implementation: #export (equivalence super)
- (All [a] (-> (Equivalence a) (Equivalence (Tree a))))
-
- (def: (= tx ty)
- (and (\ super = (get@ #value tx) (get@ #value ty))
- (\ (list.equivalence (equivalence super)) = (get@ #children tx) (get@ #children ty)))))
-
-(implementation: #export functor
- (Functor Tree)
-
- (def: (map f fa)
- {#value (f (get@ #value fa))
- #children (list\map (map f)
- (get@ #children fa))}))
-
-(implementation: #export fold
- (Fold Tree)
-
- (def: (fold f init tree)
- (list\fold (function (_ tree' init') (fold f init' tree'))
- (f (get@ #value tree)
- init)
- (get@ #children tree))))
diff --git a/stdlib/source/lux/data/collection/tree/finger.lux b/stdlib/source/lux/data/collection/tree/finger.lux
deleted file mode 100644
index d28e69a3c..000000000
--- a/stdlib/source/lux/data/collection/tree/finger.lux
+++ /dev/null
@@ -1,107 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [predicate (#+ Predicate)]
- ["." monoid (#+ Monoid)]]
- [data
- [collection
- ["." list ("#\." monoid)]]]
- [type
- [abstract (#+ abstract: :abstraction :representation)]]])
-
-(abstract: #export (Tree @ t v)
- {#monoid (Monoid t)
- #tag t
- #root (| v
- [(Tree @ t v) (Tree @ t v)])}
-
- (interface: #export (Builder @ t)
- (: (All [v]
- (-> t v (Tree @ t v)))
- leaf)
- (: (All [v]
- (-> (Tree @ t v)
- (Tree @ t v)
- (Tree @ t v)))
- branch))
-
- (template [<name> <tag> <output>]
- [(def: #export <name>
- (All [@ t v] (-> (Tree @ t v) <output>))
- (|>> :representation (get@ <tag>)))]
-
- [tag #tag t]
- [root #root (Either v [(Tree @ t v) (Tree @ t v)])]
- )
-
- (implementation: #export (builder monoid)
- (All [t] (Ex [@] (-> (Monoid t) (Builder @ t))))
-
- (def: (leaf tag value)
- (:abstraction
- {#monoid monoid
- #tag tag
- #root (0 #0 value)}))
-
- (def: (branch left right)
- (:abstraction
- {#monoid monoid
- #tag (\ monoid compose (..tag left) (..tag right))
- #root (0 #1 [left right])})))
-
- (def: #export (value tree)
- (All [@ t v] (-> (Tree @ t v) v))
- (case (get@ #root (:representation tree))
- (0 #0 value)
- value
-
- (0 #1 [left right])
- (value left)))
-
- (def: #export (tags tree)
- (All [@ t v] (-> (Tree @ t v) (List t)))
- (case (get@ #root (:representation tree))
- (0 #0 value)
- (list (get@ #tag (:representation tree)))
-
- (0 #1 [left right])
- (list\compose (tags left)
- (tags right))))
-
- (def: #export (values tree)
- (All [@ t v] (-> (Tree @ t v) (List v)))
- (case (get@ #root (:representation tree))
- (0 #0 value)
- (list value)
-
- (0 #1 [left right])
- (list\compose (values left)
- (values right))))
-
- (def: #export (search predicate tree)
- (All [@ t v] (-> (Predicate t) (Tree @ t v) (Maybe v)))
- (let [[monoid tag root] (:representation tree)]
- (if (predicate tag)
- (let [(^open "tag//.") monoid]
- (loop [_tag tag//identity
- _node root]
- (case _node
- (0 #0 value)
- (#.Some value)
-
- (0 #1 [left right])
- (let [shifted_tag (tag//compose _tag (..tag left))]
- (if (predicate shifted_tag)
- (recur _tag (get@ #root (:representation left)))
- (recur shifted_tag (get@ #root (:representation right))))))))
- #.None)))
- )
-
-(def: #export (found? predicate tree)
- (All [@ t v] (-> (Predicate t) (Tree @ t v) Bit))
- (case (..search predicate tree)
- (#.Some _)
- true
-
- #.None
- false))
diff --git a/stdlib/source/lux/data/collection/tree/zipper.lux b/stdlib/source/lux/data/collection/tree/zipper.lux
deleted file mode 100644
index be2f7b4bd..000000000
--- a/stdlib/source/lux/data/collection/tree/zipper.lux
+++ /dev/null
@@ -1,317 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- [abstract
- [functor (#+ Functor)]
- [comonad (#+ CoMonad)]
- [monad (#+ do)]
- [equivalence (#+ Equivalence)]]
- [data
- ["." product]
- ["." maybe ("#\." monad)]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold monoid)]]]]
- ["." // (#+ Tree) ("#\." functor)])
-
-(type: (Family Zipper a)
- {#parent (Zipper a)
- #lefts (List (Tree a))
- #rights (List (Tree a))})
-
-(type: #export (Zipper a)
- {#.doc "Tree zippers, for easy navigation and editing of trees."}
- {#family (Maybe (Family Zipper a))
- #node (Tree a)})
-
-(implementation: #export (equivalence super)
- (All [a]
- (-> (Equivalence a)
- (Equivalence (Zipper a))))
-
- (def: (= reference sample)
- (let [== ($_ product.equivalence
- (maybe.equivalence
- ($_ product.equivalence
- =
- (list.equivalence (//.equivalence super))
- (list.equivalence (//.equivalence super))))
- (//.equivalence super))]
- (== reference sample))))
-
-(def: #export (zip tree)
- (All [a] (-> (Tree a) (Zipper a)))
- {#family #.None
- #node tree})
-
-(def: #export unzip
- (All [a] (-> (Zipper a) (Tree a)))
- (get@ #node))
-
-(def: #export value
- (All [a] (-> (Zipper a) a))
- (get@ [#node #//.value]))
-
-(def: #export set
- (All [a] (-> a (Zipper a) (Zipper a)))
- (set@ [#node #//.value]))
-
-(def: #export update
- (All [a] (-> (-> a a) (Zipper a) (Zipper a)))
- (update@ [#node #//.value]))
-
-(def: children
- (All [a] (-> (Zipper a) (List (Tree a))))
- (get@ [#node #//.children]))
-
-(def: #export leaf?
- (All [a] (-> (Zipper a) Bit))
- (|>> ..children list.empty?))
-
-(def: #export branch?
- (All [a] (-> (Zipper a) Bit))
- (|>> ..leaf? not))
-
-(def: #export (start? zipper)
- (All [a] (-> (Zipper a) Bit))
- (case (get@ #family zipper)
- #.None
- true
-
- _
- false))
-
-(def: #export (down zipper)
- (All [a] (-> (Zipper a) (Maybe (Zipper a))))
- (case (..children zipper)
- #.Nil
- #.None
-
- (#.Cons head tail)
- (#.Some {#family (#.Some {#parent (set@ [#node #//.children] (list) zipper)
- #lefts #.Nil
- #rights tail})
- #node head})))
-
-(def: #export (up zipper)
- (All [a] (-> (Zipper a) (Maybe (Zipper a))))
- (do maybe.monad
- [family (get@ #family zipper)]
- (wrap (let [(^slots [#parent #lefts #rights]) family]
- (for {@.old
- (update@ #node (: (-> (Tree ($ 0)) (Tree ($ 0)))
- (set@ #//.children (list\compose (list.reverse lefts)
- (#.Cons (get@ #node zipper)
- rights))))
- parent)}
- (set@ [#node #//.children]
- (list\compose (list.reverse lefts)
- (#.Cons (get@ #node zipper)
- rights))
- parent))))))
-
-(template [<one> <all> <side> <op-side>]
- [(def: #export (<one> zipper)
- (All [a] (-> (Zipper a) (Maybe (Zipper a))))
- (case (get@ #family zipper)
- (#.Some family)
- (case (get@ <side> family)
- (#.Cons next side')
- (#.Some (for {@.old
- {#family (#.Some (|> family
- (set@ <side> side')
- (update@ <op-side> (|>> (#.Cons (get@ #node zipper))))))
- #node next}}
- (let [move (: (All [a] (-> (List (Tree a)) (Zipper a) (Family Zipper a) (Family Zipper a)))
- (function (_ side' zipper)
- (|>> (set@ <side> side')
- (update@ <op-side> (|>> (#.Cons (get@ #node zipper)))))))]
- {#family (#.Some (move side' zipper family))
- #node next})))
-
- #.Nil
- #.None)
-
- #.None
- #.None))
-
- (def: #export (<all> zipper)
- (All [a] (-> (Zipper a) (Maybe (Zipper a))))
- (case (get@ #family zipper)
- #.None
- #.None
-
- (#.Some family)
- (case (list.reverse (get@ <side> family))
- #.Nil
- #.None
-
- (#.Cons last prevs)
- (#.Some (for {@.old {#family (#.Some (|> family
- (set@ <side> #.Nil)
- (update@ <op-side> (|>> (#.Cons (get@ #node zipper))
- (list\compose prevs)))))
- #node last}}
- (let [move (: (All [a] (-> (List (Tree a)) (Zipper a) (Family Zipper a) (Family Zipper a)))
- (function (_ prevs zipper)
- (|>> (set@ <side> #.Nil)
- (update@ <op-side> (|>> (#.Cons (get@ #node zipper))
- (list\compose prevs))))))]
- {#family (#.Some (move prevs zipper family))
- #node last}))))))]
-
- [right rightmost #rights #lefts]
- [left leftmost #lefts #rights]
- )
-
-(def: #export (next zipper)
- (All [a] (-> (Zipper a) (Maybe (Zipper a))))
- (case (..down zipper)
- (#.Some forward)
- (#.Some forward)
-
- #.None
- (loop [@ zipper]
- (case (..right @)
- (#.Some forward)
- (#.Some forward)
-
- #.None
- (do maybe.monad
- [@ (..up @)]
- (recur @))))))
-
-(def: (bottom zipper)
- (All [a] (-> (Zipper a) (Zipper a)))
- (case (..right zipper)
- (#.Some forward)
- (bottom forward)
-
- #.None
- (case (..down zipper)
- (#.Some forward)
- (bottom forward)
-
- #.None
- zipper)))
-
-(def: #export (previous zipper)
- (All [a] (-> (Zipper a) (Maybe (Zipper a))))
- (case (..left zipper)
- #.None
- (..up zipper)
-
- (#.Some backward)
- (#.Some (case (..down backward)
- (#.Some then)
- (..bottom then)
-
- #.None
- backward))))
-
-(template [<name> <move>]
- [(def: #export (<name> zipper)
- (All [a] (-> (Zipper a) (Maybe (Zipper a))))
- (case (<move> zipper)
- #.None
- #.None
-
- (#.Some @)
- (loop [@ @]
- (case (<move> @)
- #.None
- (#.Some @)
-
- (#.Some @)
- (recur @)))))]
-
- [end ..next]
- [start ..previous]
- )
-
-(def: #export (end? zipper)
- (All [a] (-> (Zipper a) Bit))
- (case (..end zipper)
- #.None
- true
-
- (#.Some _)
- false))
-
-(def: #export (interpose value zipper)
- (All [a] (-> a (Zipper a) (Zipper a)))
- (update@ [#node #//.children]
- (|>> (//.branch value) list)
- zipper))
-
-(def: #export (adopt value zipper)
- (All [a] (-> a (Zipper a) (Zipper a)))
- (update@ [#node #//.children]
- (|>> (#.Cons (//.leaf value)))
- zipper))
-
-(def: #export (remove zipper)
- (All [a] (-> (Zipper a) (Maybe (Zipper a))))
- (do maybe.monad
- [family (get@ #family zipper)]
- (case (get@ #lefts family)
- #.Nil
- (wrap (set@ [#node #//.children]
- (get@ #rights family)
- (get@ #parent family)))
-
- (#.Cons next side)
- (wrap (|> zipper
- (set@ #family (|> family
- (set@ #lefts side)
- #.Some))
- (set@ #node next))))))
-
-(template [<name> <side>]
- [(def: #export (<name> value zipper)
- (All [a] (-> a (Zipper a) (Maybe (Zipper a))))
- (case (get@ #family zipper)
- #.None
- #.None
-
- (#.Some family)
- (#.Some (set@ #family
- (#.Some (update@ <side> (|>> (#.Cons (//.leaf value))) family))
- zipper))))]
-
- [insert-left #lefts]
- [insert-right #rights]
- )
-
-(implementation: #export functor
- (Functor Zipper)
-
- (def: (map f (^slots [#family #node]))
- {#family (maybe\map (function (_ (^slots [#parent #lefts #rights]))
- {#parent (map f parent)
- #lefts (list\map (//\map f) lefts)
- #rights (list\map (//\map f) rights)})
- family)
- #node (//\map f node)}))
-
-(implementation: #export comonad
- (CoMonad Zipper)
-
- (def: &functor ..functor)
-
- (def: unwrap (get@ [#node #//.value]))
-
- (def: (split (^slots [#family #node]))
- (let [tree-splitter (: (All [a] (-> (Tree a) (Tree (Zipper a))))
- (function (tree-splitter tree)
- {#//.value (..zip tree)
- #//.children (|> tree
- (get@ #//.children)
- (list\map tree-splitter))}))]
- {#family (maybe\map (function (_ (^slots [#parent #lefts #rights]))
- {#parent (split parent)
- #lefts (list\map tree-splitter lefts)
- #rights (list\map tree-splitter rights)})
- family)
- #node (tree-splitter node)})))
diff --git a/stdlib/source/lux/data/color.lux b/stdlib/source/lux/data/color.lux
deleted file mode 100644
index 921137d9a..000000000
--- a/stdlib/source/lux/data/color.lux
+++ /dev/null
@@ -1,424 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [monoid (#+ Monoid)]
- ["." hash (#+ Hash)]]
- [data
- [collection
- ["." list ("#\." functor)]]]
- ["." math
- [number
- ["n" nat]
- ["f" frac]
- ["." int]
- ["." rev ("#\." interval)]
- ["." i64]]]
- [type
- abstract]])
-
-(def: rgb 256)
-(def: top (dec rgb))
-
-(def: rgb_factor (|> top .int int.frac))
-
-(def: down
- (-> Nat Frac)
- (|>> .int int.frac (f./ rgb_factor)))
-
-(def: up
- (-> Frac Nat)
- (|>> (f.* rgb_factor) f.int .nat))
-
-(type: #export RGB
- {#red Nat
- #green Nat
- #blue Nat})
-
-(type: #export HSL
- [Frac Frac Frac])
-
-(type: #export CMYK
- {#cyan Frac
- #magenta Frac
- #yellow Frac
- #key Frac})
-
-(type: #export HSB
- [Frac Frac Frac])
-
-(abstract: #export Color
- RGB
-
- (def: #export (from_rgb [red green blue])
- (-> RGB Color)
- (:abstraction {#red (n.% ..rgb red)
- #green (n.% ..rgb green)
- #blue (n.% ..rgb blue)}))
-
- (def: #export to_rgb
- (-> Color RGB)
- (|>> :representation))
-
- (implementation: #export equivalence
- (Equivalence Color)
-
- (def: (= reference sample)
- (let [[rR gR bR] (:representation reference)
- [rS gS bS] (:representation sample)]
- (and (n.= rR rS)
- (n.= gR gS)
- (n.= bR bS)))))
-
- (implementation: #export hash
- (Hash Color)
-
- (def: &equivalence ..equivalence)
-
- (def: (hash value)
- (let [[r g b] (:representation value)]
- ($_ i64.or
- (i64.left_shift 16 r)
- (i64.left_shift 8 g)
- b))))
-
- (def: #export black
- (..from_rgb {#red 0
- #green 0
- #blue 0}))
-
- (def: #export white
- (..from_rgb {#red ..top
- #green ..top
- #blue ..top}))
-
- (implementation: #export addition
- (Monoid Color)
-
- (def: identity ..black)
-
- (def: (compose left right)
- (let [[lR lG lB] (:representation left)
- [rR rG rB] (:representation right)]
- (:abstraction {#red (n.max lR rR)
- #green (n.max lG rG)
- #blue (n.max lB rB)}))))
-
- (def: (complement' value)
- (-> Nat Nat)
- (|> ..top (n.- value)))
-
- (def: #export (complement color)
- (-> Color Color)
- (let [[red green blue] (:representation color)]
- (:abstraction {#red (complement' red)
- #green (complement' green)
- #blue (complement' blue)})))
-
- (implementation: #export subtraction
- (Monoid Color)
-
- (def: identity ..white)
-
- (def: (compose left right)
- (let [[lR lG lB] (:representation (..complement left))
- [rR rG rB] (:representation right)]
- (:abstraction {#red (n.min lR rR)
- #green (n.min lG rG)
- #blue (n.min lB rB)}))))
- )
-
-(def: #export (to_hsl color)
- (-> Color HSL)
- (let [[red green blue] (to_rgb color)
- red (..down red)
- green (..down green)
- blue (..down blue)
- max ($_ f.max red green blue)
- min ($_ f.min red green blue)
- luminance (|> (f.+ max min) (f./ +2.0))]
- (if (f.= max min)
- ## Achromatic
- [+0.0
- +0.0
- luminance]
- ## Chromatic
- (let [diff (|> max (f.- min))
- saturation (|> diff
- (f./ (if (f.> +0.5 luminance)
- (|> +2.0 (f.- max) (f.- min))
- (|> max (f.+ min)))))
- hue' (cond (f.= red max)
- (|> green (f.- blue) (f./ diff)
- (f.+ (if (f.< blue green) +6.0 +0.0)))
-
- (f.= green max)
- (|> blue (f.- red) (f./ diff)
- (f.+ +2.0))
-
- ## (f.= blue max)
- (|> red (f.- green) (f./ diff)
- (f.+ +4.0)))]
- [(|> hue' (f./ +6.0))
- saturation
- luminance]))))
-
-(def: (hue_to_rgb p q t)
- (-> Frac Frac Frac Frac)
- (let [t (cond (f.< +0.0 t) (f.+ +1.0 t)
- (f.> +1.0 t) (f.- +1.0 t)
- ## else
- t)
- f2/3 (f./ +3.0 +2.0)]
- (cond (f.< (f./ +6.0 +1.0) t)
- (|> q (f.- p) (f.* +6.0) (f.* t) (f.+ p))
-
- (f.< (f./ +2.0 +1.0) t)
- q
-
- (f.< f2/3 t)
- (|> q (f.- p) (f.* (|> f2/3 (f.- t))) (f.* +6.0) (f.+ p))
-
- ## else
- p)))
-
-(def: #export (from_hsl [hue saturation luminance])
- (-> HSL Color)
- (if (f.= +0.0 saturation)
- ## Achromatic
- (let [intensity (..up luminance)]
- (from_rgb {#red intensity
- #green intensity
- #blue intensity}))
- ## Chromatic
- (let [q (if (f.< +0.5 luminance)
- (|> saturation (f.+ +1.0) (f.* luminance))
- (|> luminance (f.+ saturation) (f.- (f.* saturation luminance))))
- p (|> luminance (f.* +2.0) (f.- q))
- third (|> +1.0 (f./ +3.0))]
- (from_rgb {#red (..up (|> hue (f.+ third) (hue_to_rgb p q)))
- #green (..up (|> hue (hue_to_rgb p q)))
- #blue (..up (|> hue (f.- third) (hue_to_rgb p q)))}))))
-
-(def: #export (to_hsb color)
- (-> Color HSB)
- (let [[red green blue] (to_rgb color)
- red (..down red)
- green (..down green)
- blue (..down blue)
- max ($_ f.max red green blue)
- min ($_ f.min red green blue)
- brightness max
- diff (|> max (f.- min))
- saturation (if (f.= +0.0 max)
- +0.0
- (|> diff (f./ max)))]
- (if (f.= max min)
- ## Achromatic
- [+0.0 saturation brightness]
- ## Chromatic
- (let [hue (cond (f.= red max)
- (|> green (f.- blue) (f./ diff)
- (f.+ (if (f.< blue green) +6.0 +0.0)))
-
- (f.= green max)
- (|> blue (f.- red) (f./ diff)
- (f.+ +2.0))
-
- ## (f.= blue max)
- (|> red (f.- green) (f./ diff)
- (f.+ +4.0)))]
- [(|> hue (f./ +6.0))
- saturation
- brightness]))))
-
-(def: #export (from_hsb [hue saturation brightness])
- (-> HSB Color)
- (let [hue (|> hue (f.* +6.0))
- i (math.floor hue)
- f (|> hue (f.- i))
- p (|> +1.0 (f.- saturation) (f.* brightness))
- q (|> +1.0 (f.- (f.* f saturation)) (f.* brightness))
- t (|> +1.0 (f.- (|> +1.0 (f.- f) (f.* saturation))) (f.* brightness))
- v brightness
- mod (|> i (f.% +6.0) f.int .nat)
- red (case mod 0 v 1 q 2 p 3 p 4 t 5 v _ (undefined))
- green (case mod 0 t 1 v 2 v 3 q 4 p 5 p _ (undefined))
- blue (case mod 0 p 1 p 2 t 3 v 4 v 5 q _ (undefined))]
- (from_rgb {#red (..up red)
- #green (..up green)
- #blue (..up blue)})))
-
-(def: #export (to_cmyk color)
- (-> Color CMYK)
- (let [[red green blue] (to_rgb color)
- red (..down red)
- green (..down green)
- blue (..down blue)
- key (|> +1.0 (f.- ($_ f.max red green blue)))
- f (if (f.< +1.0 key)
- (|> +1.0 (f./ (|> +1.0 (f.- key))))
- +0.0)
- cyan (|> +1.0 (f.- red) (f.- key) (f.* f))
- magenta (|> +1.0 (f.- green) (f.- key) (f.* f))
- yellow (|> +1.0 (f.- blue) (f.- key) (f.* f))]
- {#cyan cyan
- #magenta magenta
- #yellow yellow
- #key key}))
-
-(def: #export (from_cmyk [cyan magenta yellow key])
- (-> CMYK Color)
- (if (f.= +1.0 key)
- (from_rgb {#red 0
- #green 0
- #blue 0})
- (let [red (|> (|> +1.0 (f.- cyan))
- (f.* (|> +1.0 (f.- key))))
- green (|> (|> +1.0 (f.- magenta))
- (f.* (|> +1.0 (f.- key))))
- blue (|> (|> +1.0 (f.- yellow))
- (f.* (|> +1.0 (f.- key))))]
- (from_rgb {#red (..up red)
- #green (..up green)
- #blue (..up blue)}))))
-
-(def: (normalize ratio)
- (-> Frac Frac)
- (cond (f.> +1.0 ratio)
- (f.% +1.0 ratio)
-
- (f.< +0.0 ratio)
- (|> ratio (f.% +1.0) (f.+ +1.0))
-
- ## else
- ratio))
-
-(def: #export (interpolate ratio end start)
- (-> Frac Color Color Color)
- (let [dS (..normalize ratio)
- dE (|> +1.0 (f.- dS))
- interpolate' (: (-> Nat Nat Nat)
- (function (_ end start)
- (|> (|> start .int int.frac (f.* dS))
- (f.+ (|> end .int int.frac (f.* dE)))
- f.int
- .nat)))
- [redS greenS blueS] (to_rgb start)
- [redE greenE blueE] (to_rgb end)]
- (from_rgb {#red (interpolate' redE redS)
- #green (interpolate' greenE greenS)
- #blue (interpolate' blueE blueS)})))
-
-(template [<name> <target>]
- [(def: #export (<name> ratio color)
- (-> Frac Color Color)
- (..interpolate ratio <target> color))]
-
- [darker black]
- [brighter white]
- )
-
-(template [<name> <op>]
- [(def: #export (<name> ratio color)
- (-> Frac Color Color)
- (let [[hue saturation luminance] (to_hsl color)]
- (from_hsl [hue
- (|> saturation
- (f.* (|> +1.0 (<op> (..normalize ratio))))
- (f.min +1.0))
- luminance])))]
-
- [saturate f.+]
- [de_saturate f.-]
- )
-
-(def: #export (gray_scale color)
- (-> Color Color)
- (let [[_ _ luminance] (to_hsl color)]
- (from_hsl [+0.0
- +0.0
- luminance])))
-
-(template [<name> <1> <2>]
- [(def: #export (<name> color)
- (-> Color [Color Color Color])
- (let [[hue saturation luminance] (to_hsl color)]
- [color
- (from_hsl [(|> hue (f.+ <1>) ..normalize)
- saturation
- luminance])
- (from_hsl [(|> hue (f.+ <2>) ..normalize)
- saturation
- luminance])]))]
-
- [triad (|> +1.0 (f./ +3.0)) (|> +2.0 (f./ +3.0))]
- [clash (|> +1.0 (f./ +4.0)) (|> +3.0 (f./ +4.0))]
- [split_complement (|> +1.0 (f./ +5.0)) (|> +3.0 (f./ +5.0))]
- )
-
-(template [<name> <1> <2> <3>]
- [(def: #export (<name> color)
- (-> Color [Color Color Color Color])
- (let [[hue saturation luminance] (to_hsb color)]
- [color
- (from_hsb [(|> hue (f.+ <1>) ..normalize)
- saturation
- luminance])
- (from_hsb [(|> hue (f.+ <2>) ..normalize)
- saturation
- luminance])
- (from_hsb [(|> hue (f.+ <3>) ..normalize)
- saturation
- luminance])]))]
-
- [square (|> +1.0 (f./ +4.0)) (|> +2.0 (f./ +4.0)) (|> +3.0 (f./ +4.0))]
- [tetradic (|> +2.0 (f./ +12.0)) (|> +6.0 (f./ +12.0)) (|> +8.0 (f./ +12.0))]
- )
-
-(type: #export Spread
- Frac)
-
-(type: #export Palette
- (-> Spread Nat Color (List Color)))
-
-(def: #export (analogous spread variations color)
- (-> Spread Nat Color (List Color))
- (let [[hue saturation brightness] (to_hsb color)
- spread (..normalize spread)]
- (list\map (function (_ idx)
- (from_hsb [(|> idx inc .int int.frac (f.* spread) (f.+ hue) ..normalize)
- saturation
- brightness]))
- (list.indices variations))))
-
-(def: #export (monochromatic spread variations color)
- (-> Spread Nat Color (List Color))
- (let [[hue saturation brightness] (to_hsb color)
- spread (..normalize spread)]
- (|> (list.indices variations)
- (list\map (|>> inc .int int.frac
- (f.* spread)
- (f.+ brightness)
- ..normalize
- [hue saturation]
- from_hsb)))))
-
-(type: #export Alpha
- Rev)
-
-(def: #export transparent
- Alpha
- rev\bottom)
-
-(def: #export translucent
- Alpha
- .5)
-
-(def: #export opaque
- Alpha
- rev\top)
-
-(type: #export Pigment
- {#color Color
- #alpha Alpha})
diff --git a/stdlib/source/lux/data/color/named.lux b/stdlib/source/lux/data/color/named.lux
deleted file mode 100644
index 54c9a4563..000000000
--- a/stdlib/source/lux/data/color/named.lux
+++ /dev/null
@@ -1,155 +0,0 @@
-(.module:
- [lux #*
- [math
- [number (#+ hex)]]]
- ["." // (#+ Color)])
-
-(template [<red> <green> <blue> <name>]
- [(def: #export <name>
- Color
- (//.from_rgb {#//.red (hex <red>)
- #//.green (hex <green>)
- #//.blue (hex <blue>)}))]
-
- ["F0" "F8" "FF" alice_blue]
- ["FA" "EB" "D7" antique_white]
- ["00" "FF" "FF" aqua]
- ["7F" "FF" "D4" aquamarine]
- ["F0" "FF" "FF" azure]
- ["F5" "F5" "DC" beige]
- ["FF" "E4" "C4" bisque]
- ["00" "00" "00" black]
- ["FF" "EB" "CD" blanched_almond]
- ["00" "00" "FF" blue]
- ["8A" "2B" "E2" blue_violet]
- ["A5" "2A" "2A" brown]
- ["DE" "B8" "87" burly_wood]
- ["5F" "9E" "A0" cadet_blue]
- ["7F" "FF" "00" chartreuse]
- ["D2" "69" "1E" chocolate]
- ["FF" "7F" "50" coral]
- ["64" "95" "ED" cornflower_blue]
- ["FF" "F8" "DC" cornsilk]
- ["DC" "14" "3C" crimson]
- ["00" "FF" "FF" cyan]
- ["00" "00" "8B" dark_blue]
- ["00" "8B" "8B" dark_cyan]
- ["B8" "86" "0B" dark_goldenrod]
- ["A9" "A9" "A9" dark_gray]
- ["00" "64" "00" dark_green]
- ["BD" "B7" "6B" dark_khaki]
- ["8B" "00" "8B" dark_magenta]
- ["55" "6B" "2F" dark_olive_green]
- ["FF" "8C" "00" dark_orange]
- ["99" "32" "CC" dark_orchid]
- ["8B" "00" "00" dark_red]
- ["E9" "96" "7A" dark_salmon]
- ["8F" "BC" "8F" dark_sea_green]
- ["48" "3D" "8B" dark_slate_blue]
- ["2F" "4F" "4F" dark_slate_gray]
- ["00" "CE" "D1" dark_turquoise]
- ["94" "00" "D3" dark_violet]
- ["FF" "14" "93" deep_pink]
- ["00" "BF" "FF" deep_sky_blue]
- ["69" "69" "69" dim_gray]
- ["1E" "90" "FF" dodger_blue]
- ["B2" "22" "22" fire_brick]
- ["FF" "FA" "F0" floral_white]
- ["22" "8B" "22" forest_green]
- ["FF" "00" "FF" fuchsia]
- ["DC" "DC" "DC" gainsboro]
- ["F8" "F8" "FF" ghost_white]
- ["FF" "D7" "00" gold]
- ["DA" "A5" "20" goldenrod]
- ["80" "80" "80" gray]
- ["00" "80" "00" green]
- ["AD" "FF" "2F" green_yellow]
- ["F0" "FF" "F0" honey_dew]
- ["FF" "69" "B4" hot_pink]
- ["CD" "5C" "5C" indian_red]
- ["4B" "00" "82" indigo]
- ["FF" "FF" "F0" ivory]
- ["F0" "E6" "8C" khaki]
- ["E6" "E6" "FA" lavender]
- ["FF" "F0" "F5" lavender_blush]
- ["7C" "FC" "00" lawn_green]
- ["FF" "FA" "CD" lemon_chiffon]
- ["AD" "D8" "E6" light_blue]
- ["F0" "80" "80" light_coral]
- ["E0" "FF" "FF" light_cyan]
- ["FA" "FA" "D2" light_goldenrod_yellow]
- ["D3" "D3" "D3" light_gray]
- ["90" "EE" "90" light_green]
- ["FF" "B6" "C1" light_pink]
- ["FF" "A0" "7A" light_salmon]
- ["20" "B2" "AA" light_sea_green]
- ["87" "CE" "FA" light_sky_blue]
- ["77" "88" "99" light_slate_gray]
- ["B0" "C4" "DE" light_steel_blue]
- ["FF" "FF" "E0" light_yellow]
- ["00" "FF" "00" lime]
- ["32" "CD" "32" lime_green]
- ["FA" "F0" "E6" linen]
- ["FF" "00" "FF" magenta]
- ["80" "00" "00" maroon]
- ["66" "CD" "AA" medium_aquamarine]
- ["00" "00" "CD" medium_blue]
- ["BA" "55" "D3" medium_orchid]
- ["93" "70" "DB" medium_purple]
- ["3C" "B3" "71" medium_sea_green]
- ["7B" "68" "EE" medium_slate_blue]
- ["00" "FA" "9A" medium_spring_green]
- ["48" "D1" "CC" medium_turquoise]
- ["C7" "15" "85" medium_violet_red]
- ["19" "19" "70" midnight_blue]
- ["F5" "FF" "FA" mint_cream]
- ["FF" "E4" "E1" misty_rose]
- ["FF" "E4" "B5" moccasin]
- ["FF" "DE" "AD" navajo_white]
- ["00" "00" "80" navy]
- ["FD" "F5" "E6" old_lace]
- ["80" "80" "00" olive]
- ["6B" "8E" "23" olive_drab]
- ["FF" "A5" "00" orange]
- ["FF" "45" "00" orange_red]
- ["DA" "70" "D6" orchid]
- ["EE" "E8" "AA" pale_goldenrod]
- ["98" "FB" "98" pale_green]
- ["AF" "EE" "EE" pale_turquoise]
- ["DB" "70" "93" pale_violet_red]
- ["FF" "EF" "D5" papaya_whip]
- ["FF" "DA" "B9" peach_puff]
- ["CD" "85" "3F" peru]
- ["FF" "C0" "CB" pink]
- ["DD" "A0" "DD" plum]
- ["B0" "E0" "E6" powder_blue]
- ["80" "00" "80" purple]
- ["66" "33" "99" rebecca_purple]
- ["FF" "00" "00" red]
- ["BC" "8F" "8F" rosy_brown]
- ["41" "69" "E1" royal_blue]
- ["8B" "45" "13" saddle_brown]
- ["FA" "80" "72" salmon]
- ["F4" "A4" "60" sandy_brown]
- ["2E" "8B" "57" sea_green]
- ["FF" "F5" "EE" sea_shell]
- ["A0" "52" "2D" sienna]
- ["C0" "C0" "C0" silver]
- ["87" "CE" "EB" sky_blue]
- ["6A" "5A" "CD" slate_blue]
- ["70" "80" "90" slate_gray]
- ["FF" "FA" "FA" snow]
- ["00" "FF" "7F" spring_green]
- ["46" "82" "B4" steel_blue]
- ["D2" "B4" "8C" tan]
- ["00" "80" "80" teal]
- ["D8" "BF" "D8" thistle]
- ["FF" "63" "47" tomato]
- ["40" "E0" "D0" turquoise]
- ["EE" "82" "EE" violet]
- ["F5" "DE" "B3" wheat]
- ["FF" "FF" "FF" white]
- ["F5" "F5" "F5" white_smoke]
- ["FF" "FF" "00" yellow]
- ["9A" "CD" "32" yellow_green]
- )
diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux
deleted file mode 100644
index 25b7b69e5..000000000
--- a/stdlib/source/lux/data/format/binary.lux
+++ /dev/null
@@ -1,291 +0,0 @@
-(.module:
- [lux (#- and or nat int rev list type)
- [type (#+ :share)]
- [abstract
- [monoid (#+ Monoid)]
- [monad (#+ Monad do)]
- [equivalence (#+ Equivalence)]]
- [control
- [pipe (#+ case>)]
- ["." function]
- ["." try (#+ Try)]
- ["<>" parser ("#\." monad)
- ["/" binary (#+ Offset Size Parser)]]]
- [data
- ["." product]
- ["." binary (#+ Binary)]
- [text
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." list]
- ["." row (#+ Row) ("#\." functor)]
- ["." set (#+ Set)]]]
- [math
- [number
- ["." i64]
- ["n" nat]
- ["." frac]]]])
-
-(def: mask
- (-> Size (I64 Any))
- (|>> (n.* i64.bits_per_byte) i64.mask))
-
-(type: #export Mutation
- (-> [Offset Binary] [Offset Binary]))
-
-(type: #export Specification
- [Size Mutation])
-
-(def: #export no_op
- Specification
- [0 function.identity])
-
-(def: #export (instance [size mutation])
- (-> Specification Binary)
- (|> size binary.create [0] mutation product.right))
-
-(implementation: #export monoid
- (Monoid Specification)
-
- (def: identity
- ..no_op)
-
- (def: (compose [sizeL mutL] [sizeR mutR])
- [(n.+ sizeL sizeR)
- (|>> mutL mutR)]))
-
-(type: #export (Writer a)
- (-> a Specification))
-
-(def: #export (run writer value)
- (All [a] (-> (Writer a) a Binary))
- (..instance (writer value)))
-
-(template [<name> <size> <write>]
- [(def: #export <name>
- (Writer (I64 Any))
- (function (_ value)
- [<size>
- (function (_ [offset binary])
- [(n.+ <size> offset)
- (|> binary
- (<write> offset value)
- try.assume)])]))]
-
- [bits/8 /.size/8 binary.write/8]
- [bits/16 /.size/16 binary.write/16]
- [bits/32 /.size/32 binary.write/32]
- [bits/64 /.size/64 binary.write/64]
- )
-
-(def: #export (or left right)
- (All [l r] (-> (Writer l) (Writer r) (Writer (| l r))))
- (function (_ altV)
- (case altV
- (^template [<number> <tag> <writer>]
- [(<tag> caseV)
- (let [[caseS caseT] (<writer> caseV)]
- [(.inc caseS)
- (function (_ [offset binary])
- (|> binary
- (binary.write/8 offset <number>)
- try.assume
- [(.inc offset)]
- caseT))])])
- ([0 #.Left left]
- [1 #.Right right])
- )))
-
-(def: #export (and pre post)
- (All [a b] (-> (Writer a) (Writer b) (Writer [a b])))
- (function (_ [preV postV])
- (\ ..monoid compose (pre preV) (post postV))))
-
-(def: #export (rec body)
- (All [a] (-> (-> (Writer a) (Writer a)) (Writer a)))
- (function (recur value)
- (body recur value)))
-
-(def: #export any
- (Writer Any)
- (function.constant ..no_op))
-
-(def: #export bit
- (Writer Bit)
- (|>> (case> #0 0 #1 1) ..bits/8))
-
-(template [<name> <type>]
- [(def: #export <name> (Writer <type>) ..bits/64)]
-
- [nat Nat]
- [int Int]
- [rev Rev]
- )
-
-(def: #export frac
- (Writer Frac)
- (|>> frac.to_bits ..bits/64))
-
-(def: #export (segment size)
- (-> Nat (Writer Binary))
- (function (_ value)
- [size
- (function (_ [offset binary])
- [(n.+ size offset)
- (try.assume
- (binary.copy (n.min size (binary.size value))
- 0
- value
- offset
- binary))])]))
-
-(template [<name> <bits> <size> <write>]
- [(def: #export <name>
- (Writer Binary)
- (let [mask (..mask <size>)]
- (function (_ value)
- (let [size (|> value binary.size (i64.and mask))
- size' (n.+ <size> size)]
- [size'
- (function (_ [offset binary])
- [(n.+ size' offset)
- (try.assume
- (do try.monad
- [_ (<write> offset size binary)]
- (binary.copy size 0 value (n.+ <size> offset) binary)))])]))))]
-
- [binary/8 ..bits/8 /.size/8 binary.write/8]
- [binary/16 ..bits/16 /.size/16 binary.write/16]
- [binary/32 ..bits/32 /.size/32 binary.write/32]
- [binary/64 ..bits/64 /.size/64 binary.write/64]
- )
-
-(template [<name> <binary>]
- [(def: #export <name>
- (Writer Text)
- (|>> (\ utf8.codec encode) <binary>))]
-
- [utf8/8 ..binary/8]
- [utf8/16 ..binary/16]
- [utf8/32 ..binary/32]
- [utf8/64 ..binary/64]
- )
-
-(def: #export text ..utf8/64)
-
-(template [<name> <size> <write>]
- [(def: #export (<name> valueW)
- (All [v] (-> (Writer v) (Writer (Row v))))
- (function (_ value)
- (let [original_count (row.size value)
- capped_count (i64.and (..mask <size>)
- original_count)
- value (if (n.= original_count capped_count)
- value
- (|> value row.to_list (list.take capped_count) row.from_list))
- (^open "specification\.") ..monoid
- [size mutation] (|> value
- (row\map valueW)
- (\ row.fold fold
- (function (_ post pre)
- (specification\compose pre post))
- specification\identity))]
- [(n.+ <size> size)
- (function (_ [offset binary])
- (try.assume
- (do try.monad
- [_ (<write> offset capped_count binary)]
- (wrap (mutation [(n.+ <size> offset) binary])))))])))]
-
- [row/8 /.size/8 binary.write/8]
- [row/16 /.size/16 binary.write/16]
- [row/32 /.size/32 binary.write/32]
- [row/64 /.size/64 binary.write/64]
- )
-
-(def: #export maybe
- (All [a] (-> (Writer a) (Writer (Maybe a))))
- (..or ..any))
-
-(def: #export (list value)
- (All [a] (-> (Writer a) (Writer (List a))))
- (..rec
- (|>> (..and value)
- (..or ..any))))
-
-(def: #export (set value)
- (All [a] (-> (Writer a) (Writer (Set a))))
- (|>> set.to_list (..list value)))
-
-(def: #export name
- (Writer Name)
- (..and ..text ..text))
-
-(def: #export type
- (Writer Type)
- (..rec
- (function (_ recur)
- (let [pair (..and recur recur)
- indexed ..nat
- quantified (..and (..list recur) recur)]
- (function (_ altV)
- (case altV
- (^template [<number> <tag> <writer>]
- [(<tag> caseV)
- (let [[caseS caseT] (<writer> caseV)]
- [(.inc caseS)
- (function (_ [offset binary])
- (|> binary
- (binary.write/8 offset <number>)
- try.assume
- [(.inc offset)]
- caseT))])])
- ([0 #.Primitive (..and ..text (..list recur))]
- [1 #.Sum pair]
- [2 #.Product pair]
- [3 #.Function pair]
- [4 #.Parameter indexed]
- [5 #.Var indexed]
- [6 #.Ex indexed]
- [7 #.UnivQ quantified]
- [8 #.ExQ quantified]
- [9 #.Apply pair]
- [10 #.Named (..and ..name recur)])
- ))))))
-
-(def: #export location
- (Writer Location)
- ($_ ..and ..text ..nat ..nat))
-
-(def: #export code
- (Writer Code)
- (..rec
- (function (_ recur)
- (let [sequence (..list recur)]
- (..and ..location
- (function (_ altV)
- (case altV
- (^template [<number> <tag> <writer>]
- [(<tag> caseV)
- (let [[caseS caseT] (<writer> caseV)]
- [(.inc caseS)
- (function (_ [offset binary])
- (|> binary
- (binary.write/8 offset <number>)
- try.assume
- [(.inc offset)]
- caseT))])])
- ([0 #.Bit ..bit]
- [1 #.Nat ..nat]
- [2 #.Int ..int]
- [3 #.Rev ..rev]
- [4 #.Frac ..frac]
- [5 #.Text ..text]
- [6 #.Identifier ..name]
- [7 #.Tag ..name]
- [8 #.Form sequence]
- [9 #.Tuple sequence]
- [10 #.Record (..list (..and recur recur))])
- )))))))
diff --git a/stdlib/source/lux/data/format/css.lux b/stdlib/source/lux/data/format/css.lux
deleted file mode 100644
index d172c7742..000000000
--- a/stdlib/source/lux/data/format/css.lux
+++ /dev/null
@@ -1,125 +0,0 @@
-(.module:
- [lux (#- and)
- [data
- ["." maybe]
- [number
- ["." nat]]
- ["." text
- ["%" format (#+ format)]
- ["." encoding (#+ Encoding)]]
- [collection
- ["." list ("#\." functor)]]]
- [type
- abstract]
- [world
- [net (#+ URL)]]]
- ["." / #_
- ["#." selector (#+ Selector Combinator)]
- ["#." value (#+ Value Animation Percentage)]
- ["#." font (#+ Font)]
- ["#." style (#+ Style)]
- ["#." query (#+ Query)]])
-
-(abstract: #export Common Any)
-(abstract: #export Special Any)
-
-(abstract: #export (CSS brand)
- Text
-
- (def: #export css (-> (CSS Any) Text) (|>> :representation))
-
- (def: #export empty (CSS Common) (:abstraction ""))
-
- (def: #export (rule selector style)
- (-> (Selector Any) Style (CSS Common))
- (:abstraction (format (/selector.selector selector) "{" (/style.inline style) "}")))
-
- (def: #export char-set
- (-> Encoding (CSS Special))
- (|>> encoding.name
- %.text
- (text.enclose ["@charset " ";"])
- :abstraction))
-
- (def: #export (font font)
- (-> Font (CSS Special))
- (let [with-unicode (case (get@ #/font.unicode-range font)
- (#.Some unicode-range)
- (let [unicode-range' (format "U+" (\ nat.hex encode (get@ #/font.start unicode-range))
- "-" (\ nat.hex encode (get@ #/font.end unicode-range)))]
- (list ["unicode-range" unicode-range']))
-
- #.None
- (list))]
- (|> (list& ["font-family" (get@ #/font.family font)]
- ["src" (format "url(" (get@ #/font.source font) ")")]
- ["font-stretch" (|> font (get@ #/font.stretch) (maybe.default /value.normal-stretch) /value.value)]
- ["font-style" (|> font (get@ #/font.style) (maybe.default /value.normal-style) /value.value)]
- ["font-weight" (|> font (get@ #/font.weight) (maybe.default /value.normal-weight) /value.value)]
- with-unicode)
- (list\map (function (_ [property value])
- (format property ": " value ";")))
- (text.join-with /style.separator)
- (text.enclose ["{" "}"])
- (format "@font-face")
- :abstraction)))
-
- (def: #export (import url query)
- (-> URL (Maybe Query) (CSS Special))
- (:abstraction (format (format "@import url(" (%.text url) ")")
- (case query
- (#.Some query)
- (format " " (/query.query query))
-
- #.None
- "")
- ";")))
-
- (def: css-separator text.new-line)
-
- (type: #export Frame
- {#when Percentage
- #what Style})
-
- (def: #export (key-frames animation frames)
- (-> (Value Animation) (List Frame) (CSS Special))
- (:abstraction (format "@keyframes " (/value.value animation) " {"
- (|> frames
- (list\map (function (_ frame)
- (format (/value.percentage (get@ #when frame)) " {"
- (/style.inline (get@ #what frame))
- "}")))
- (text.join-with ..css-separator))
- "}")))
-
- (template: (!compose <pre> <post>)
- (:abstraction (format (:representation <pre>) ..css-separator
- (:representation <post>))))
-
- (def: #export (and pre post)
- (-> (CSS Any) (CSS Any) (CSS Any))
- (!compose pre post))
-
- (def: #export (alter combinator selector css)
- (-> Combinator (Selector Any) (CSS Common) (CSS Common))
- (|> css
- :representation
- (text.split-all-with ..css-separator)
- (list\map (|>> (format (/selector.selector (|> selector (combinator (/selector.tag "")))))))
- (text.join-with ..css-separator)
- :abstraction))
-
- (def: #export (dependent combinator selector style inner)
- (-> Combinator (Selector Any) Style (CSS Common) (CSS Common))
- (!compose (..rule selector style)
- (..alter combinator selector inner)))
-
- (template [<name> <combinator>]
- [(def: #export <name>
- (-> (Selector Any) Style (CSS Common) (CSS Common))
- (..dependent <combinator>))]
-
- [with-descendants /selector.in]
- [with-children /selector.sub]
- )
- )
diff --git a/stdlib/source/lux/data/format/css/font.lux b/stdlib/source/lux/data/format/css/font.lux
deleted file mode 100644
index b809f45e6..000000000
--- a/stdlib/source/lux/data/format/css/font.lux
+++ /dev/null
@@ -1,25 +0,0 @@
-(.module:
- [lux #*
- [type
- abstract]
- [control
- [parser
- ["s" code]]]
- ["." macro
- [syntax (#+ syntax:)]]
- [world
- [net (#+ URL)]]]
- ["." // #_
- ["#." value (#+ Value Font-Stretch Font-Style Font-Weight)]])
-
-(type: #export Unicode-Range
- {#start Nat
- #end Nat})
-
-(type: #export Font
- {#family Text
- #source URL
- #stretch (Maybe (Value Font-Stretch))
- #style (Maybe (Value Font-Style))
- #weight (Maybe (Value Font-Weight))
- #unicode-range (Maybe Unicode-Range)})
diff --git a/stdlib/source/lux/data/format/css/property.lux b/stdlib/source/lux/data/format/css/property.lux
deleted file mode 100644
index bbfdd1930..000000000
--- a/stdlib/source/lux/data/format/css/property.lux
+++ /dev/null
@@ -1,502 +0,0 @@
-(.module:
- [lux (#- All Cursor)
- [control
- [parser
- ["s" code]]]
- [type
- abstract]
- [macro
- ["." template]
- ["." code]
- [syntax (#+ syntax:)]]]
- [//
- [value (#+ All
- Number
- Length Thickness Time
- Color
- Location Fit
- Slice
- Alignment Animation-Direction
- Animation Animation-Fill
- Column-Fill Column-Span
- Iteration Count
- Play
- Timing Visibility Attachment
- Blend Span Image
- Angle Repeat Border
- Collapse Box-Decoration-Break Caption
- Float Clear
- Content
- Cursor
- Shadow Clip
- Text-Direction
- Display Empty
- Filter
- Flex-Direction Flex-Wrap
- Font Font-Kerning Font-Size Font-Variant
- Grid Grid-Content Grid-Flow Grid-Span Grid-Template
- Hanging-Punctuation Hyphens Isolation
- List-Style-Position List-Style-Type
- Overflow Page-Break Pointer-Events
- Position
- Quotes
- Resize Scroll-Behavior Table-Layout
- Text-Align Text-Align-Last
- Text-Decoration-Line Text-Decoration-Style
- Text-Justification Text-Overflow Text-Transform
- Transform Transform-Origin Transform-Style
- Transition
- Bidi User-Select
- Vertical-Align
- White-Space Word-Break Word-Wrap Writing-Mode
- Z-Index)]])
-
-(syntax: (text-identifier {identifier s.text})
- (wrap (list (code.local-identifier identifier))))
-
-(abstract: #export (Property brand)
- Text
-
- (def: #export name
- (-> (Property Any) Text)
- (|>> :representation))
-
- (template [<brand> <alias>+ <property>+]
- [(`` (template [<alias> <property>]
- [(def: #export <alias>
- (Property <brand>)
- (:abstraction <property>))]
-
- (~~ (template.splice <alias>+))))
-
- (with-expansions [<rows> (template.splice <property>+)]
- (template [<property>]
- [(`` (def: #export (~~ (text-identifier <property>))
- (Property <brand>)
- (:abstraction <property>)))]
-
- <rows>))]
-
- [All
- []
- [["all"]]]
-
- [Length
- []
- [["border-image-outset"]
- ["border-image-width"]
- ["bottom"]
- ["column-gap"]
- ["column-width"]
- ["flex-basis"]
- ["grid-column-gap"]
- ["grid-gap"]
- ["grid-row-gap"]
- ["height"]
- ["left"]
- ["letter-spacing"]
- ["line-height"]
- ["margin"]
- ["margin-bottom"]
- ["margin-left"]
- ["margin-right"]
- ["margin-top"]
- ["max-height"]
- ["max-width"]
- ["min-height"]
- ["min-width"]
- ["outline-offset"]
- ["padding"]
- ["padding-bottom"]
- ["padding-left"]
- ["padding-right"]
- ["padding-top"]
- ["perspective"]
- ["right"]
- ["text-indent"]
- ["top"]
- ["width"]
- ["word-spacing"]]]
-
- [Time
- []
- [["animation-delay"]
- ["animation-duration"]
- ["transition-delay"]
- ["transition-duration"]]]
-
- [Slice
- []
- [["border-image-slice"]]]
-
- [Color
- [[text-color "color"]]
- [["background-color"]
- ["border-color"]
- ["border-bottom-color"]
- ["border-left-color"]
- ["border-right-color"]
- ["border-top-color"]
- ["caret-color"]
- ["column-rule-color"]
- ["outline-color"]
- ["text-decoration-color"]]]
-
- [Alignment
- []
- [["align-content"]
- ["align-items"]
- ["align-self"]
- ["justify-content"]]]
-
- [Animation
- []
- [["animation-name"]]]
-
- [Animation-Direction
- []
- [["animation-direction"]]]
-
- [Animation-Fill
- []
- [["animation-fill-mode"]]]
-
- [Column-Fill
- []
- [["column-fill"]]]
-
- [Column-Span
- []
- [["column-span"]]]
-
- [Iteration
- []
- [["animation-iteration-count"]]]
-
- [Count
- []
- [["column-count"]
- ["flex-grow"]
- ["flex-shrink"]
- ["order"]
- ["tab-size"]]]
-
- [Play
- []
- [["animation-play-state"]]]
-
- [Timing
- []
- [["animation-timing-function"]
- ["transition-timing-function"]]]
-
- [Visibility
- []
- [["backface-visibility"]
- ["visibility"]]]
-
- [Attachment
- []
- [["background-attachment"]]]
-
- [Blend
- []
- [["background-blend-mode"]
- ["mix-blend-mode"]]]
-
- [Image
- []
- [["background-image"]
- ["border-image-source"]
- ["list-style-image"]]]
-
- [Span
- []
- [["background-clip"]
- ["background-origin"]
- ["box-sizing"]]]
-
- [Location
- []
- [["background-position"]
- ["object-position"]
- ["perspective-origin"]]]
-
- [Repeat
- []
- [["background-repeat"]
- ["border-image-repeat"]]]
-
- [Fit
- []
- [["background-size"]
- ["border-radius"]
- ["border-bottom-left-radius"]
- ["border-bottom-right-radius"]
- ["border-top-left-radius"]
- ["border-top-right-radius"]
- ["border-spacing"]
- ["object-fit"]]]
-
- [Border
- []
- [["border-style"]
- ["border-bottom-style"]
- ["border-left-style"]
- ["border-right-style"]
- ["border-top-style"]
- ["column-rule-style"]
- ["outline-style"]]]
-
- [Thickness
- []
- [["border-width"]
- ["border-bottom-width"]
- ["border-left-width"]
- ["border-right-width"]
- ["border-top-width"]
- ["column-rule-width"]
- ["outline-width"]]]
-
- [Collapse
- []
- [["border-collapse"]]]
-
- [Box-Decoration-Break
- []
- [["box-decoration-break"]]]
-
- [Caption
- []
- [["caption-side"]]]
-
- [Clear
- []
- [["clear"]]]
-
- [Shadow
- []
- [["box-shadow"]
- ["text-shadow"]]]
-
- [Clip
- []
- [["clip"]]]
-
- [Content
- []
- [["counter-reset"]
- ["counter-increment"]]]
-
- [Cursor
- []
- [["cursor"]]]
-
- [Text-Direction
- [[text-direction "direction"]]
- []]
-
- [Display
- []
- [["display"]]]
-
- [Empty
- []
- [["empty-cells"]]]
-
- [Filter
- []
- [["filter"]]]
-
- [Flex-Direction
- []
- [["flex-direction"]]]
-
- [Flex-Wrap
- []
- [["flex-wrap"]]]
-
- [Float
- []
- [["float"]]]
-
- [Font
- []
- [["font-family"]]]
-
- [Font-Kerning
- []
- [["font-kerning"]]]
-
- [Font-Size
- []
- [["font-size"]]]
-
- [Number
- []
- [["font-size-adjust"]
- ["opacity"]]]
-
- [Font-Variant
- []
- [["font-variant"]]]
-
- [Grid
- []
- [["grid-area"]]]
-
- [Grid-Content
- []
- [["grid-auto-columns"]
- ["grid-auto-rows"]
- ["grid-template-columns"]
- ["grid-template-rows"]]]
-
- [Grid-Flow
- []
- [["grid-auto-flow"]]]
-
- [Grid-Span
- []
- [["grid-column-end"]
- ["grid-column-start"]
- ["grid-row-end"]
- ["grid-row-start"]]]
-
- [Grid-Template
- []
- [["grid-template-areas"]]]
-
- [Hanging-Punctuation
- []
- [["hanging-punctuation"]]]
-
- [Hyphens
- []
- [["hyphens"]]]
-
- [Isolation
- []
- [["isolation"]]]
-
- [List-Style-Position
- []
- [["list-style-position"]]]
-
- [List-Style-Type
- []
- [["list-style-type"]]]
-
- [Overflow
- []
- [["overflow"]
- ["overflow-x"]
- ["overflow-y"]]]
-
- [Page-Break
- []
- [["page-break-after"]
- ["page-break-before"]
- ["page-break-inside"]]]
-
- [Pointer-Events
- []
- [["pointer-events"]]]
-
- [Position
- []
- [["position"]]]
-
- [Quotes
- []
- [["quotes"]]]
-
- [Resize
- []
- [["resize"]]]
-
- [Scroll-Behavior
- []
- [["scroll-behavior"]]]
-
- [Table-Layout
- []
- [["table-layout"]]]
-
- [Text-Align
- []
- [["text-align"]]]
-
- [Text-Align-Last
- []
- [["text-align-last"]]]
-
- [Text-Decoration-Line
- []
- [["text-decoration-line"]]]
-
- [Text-Decoration-Style
- []
- [["text-decoration-style"]]]
-
- [Text-Justification
- []
- [["text-justify"]]]
-
- [Text-Overflow
- []
- [["text-overflow"]]]
-
- [Text-Transform
- []
- [["text-transform"]]]
-
- [Transform
- []
- [["transform"]]]
-
- [Transform-Origin
- []
- [["transform-origin"]]]
-
- [Transform-Style
- []
- [["transform-style"]]]
-
- [Transition
- []
- [["transition-property"]]]
-
- [Bidi
- []
- [["unicode-bidi"]]]
-
- [User-Select
- []
- [["user-select"]]]
-
- [Vertical-Align
- []
- [["vertical-align"]]]
-
- [White-Space
- []
- [["white-space"]]]
-
- [Word-Break
- []
- [["word-break"]]]
-
- [Word-Wrap
- []
- [["word-wrap"]]]
-
- [Writing-Mode
- []
- [["writing-mode"]]]
-
- [Z-Index
- []
- [["z-index"]]]
- )
- )
diff --git a/stdlib/source/lux/data/format/css/query.lux b/stdlib/source/lux/data/format/css/query.lux
deleted file mode 100644
index 6b1e57554..000000000
--- a/stdlib/source/lux/data/format/css/query.lux
+++ /dev/null
@@ -1,134 +0,0 @@
-(.module:
- [lux (#- and or not)
- [control
- [parser
- ["s" code]]]
- [data
- [text
- ["%" format (#+ format)]]]
- [macro
- ["." template]
- ["." code]
- [syntax (#+ syntax:)]]
- [type
- abstract]]
- ["." // #_
- ["#." value (#+ Value Length Count Resolution Ratio
- Orientation Scan Boolean Update
- Block-Overflow Inline-Overflow
- Display-Mode Color-Gamut Inverted-Colors
- Pointer Hover
- Light Scripting Motion Color-Scheme)]])
-
-(syntax: (text-identifier {identifier s.text})
- (wrap (list (code.local-identifier identifier))))
-
-(abstract: #export Media
- Text
-
- (def: #export media
- (-> Media Text)
- (|>> :representation))
-
- (template [<media>]
- [(`` (def: #export (~~ (text-identifier <media>))
- Media
- (:abstraction <media>)))]
-
- ["all"]
- ["print"]
- ["screen"]
- ["speech"]
- ))
-
-(abstract: #export Feature
- Text
-
- (def: #export feature
- (-> Feature Text)
- (|>> :representation))
-
- (template [<feature> <brand>]
- [(`` (def: #export ((~~ (text-identifier <feature>)) input)
- (-> (Value <brand>) Feature)
- (:abstraction (format "(" <feature> ": " (//value.value input) ")"))))]
-
- ["min-color" Count]
- ["color" Count]
- ["max-color" Count]
-
- ["min-color-index" Count]
- ["color-index" Count]
- ["max-color-index" Count]
-
- ["min-monochrome" Count]
- ["monochrome" Count]
- ["max-monochrome" Count]
-
- ["min-height" Length]
- ["height" Length]
- ["max-height" Length]
-
- ["min-width" Length]
- ["width" Length]
- ["max-width" Length]
-
- ["min-resolution" Resolution]
- ["resolution" Resolution]
- ["max-resolution" Resolution]
-
- ["aspect-ratio" Ratio]
- ["max-aspect-ratio" Ratio]
- ["min-aspect-ratio" Ratio]
-
- ["display-mode" Display-Mode]
- ["color-gamut" Color-Gamut]
- ["grid" Boolean]
- ["orientation" Orientation]
- ["overflow-block" Block-Overflow]
- ["overflow-inline" Inline-Overflow]
- ["scan" Scan]
- ["update" Update]
- ["inverted-colors" Inverted-Colors]
- ["pointer" Pointer]
- ["any-pointer" Pointer]
- ["hover" Hover]
- ["any-hover" Hover]
- ["light-level" Light]
- ["scripting" Scripting]
- ["prefers-reduced-motion" Motion]
- ["prefers-color-scheme" Color-Scheme]
- )
- )
-
-(abstract: #export Query
- Text
-
- (def: #export query
- (-> Query Text)
- (|>> :representation))
-
- (template [<name> <operator>]
- [(def: #export <name>
- (-> Media Query)
- (|>> ..media (format <operator>) :abstraction))]
-
- [except "not "]
- [only "only "]
- )
-
- (def: #export not
- (-> Feature Query)
- (|>> ..feature (format "not ") :abstraction))
-
- (template [<name> <operator>]
- [(def: #export (<name> left right)
- (-> Query Query Query)
- (:abstraction (format (:representation left)
- <operator>
- (:representation right))))]
-
- [and " and "]
- [or " or "]
- )
- )
diff --git a/stdlib/source/lux/data/format/css/selector.lux b/stdlib/source/lux/data/format/css/selector.lux
deleted file mode 100644
index 1c0f4b566..000000000
--- a/stdlib/source/lux/data/format/css/selector.lux
+++ /dev/null
@@ -1,204 +0,0 @@
-(.module:
- [lux (#- or and for is? not)
- [data
- ["." text
- ["%" format (#+ format)]]
- [number
- ["i" int]]]
- [type
- abstract]
- [macro
- ["." template]]
- ["." locale (#+ Locale)]])
-
-(type: #export Label Text)
-
-(type: #export Tag Label)
-(type: #export ID Label)
-(type: #export Class Label)
-(type: #export Attribute Label)
-
-(abstract: #export (Generic brand) Any)
-
-(template [<generic> <brand>]
- [(abstract: <brand> Any)
- (type: #export <generic> (Generic <brand>))]
-
- [Can-Chain Can-Chain']
- [Cannot-Chain Cannot-Chain']
- )
-
-(abstract: #export Unique Any)
-(abstract: #export Specific Any)
-(abstract: #export Composite Any)
-
-(abstract: #export (Selector kind)
- Text
-
- (def: #export selector
- (-> (Selector Any) Text)
- (|>> :representation))
-
- (def: #export any
- (Selector Cannot-Chain)
- (:abstraction "*"))
-
- (def: #export tag
- (-> Tag (Selector Cannot-Chain))
- (|>> :abstraction))
-
- (template [<name> <type> <prefix> <kind>]
- [(def: #export <name>
- (-> <type> (Selector <kind>))
- (|>> (format <prefix>) :abstraction))]
-
- [id ID "#" Unique]
- [class Class "." Can-Chain]
- )
-
- (template [<right> <left> <combo> <combinator>+]
- [(`` (template [<combinator> <name>]
- [(def: #export (<name> right left)
- (-> (Selector <right>) (Selector <left>) (Selector <combo>))
- (:abstraction (format (:representation left)
- <combinator>
- (:representation right))))]
-
- (~~ (template.splice <combinator>+))))]
-
- [Can-Chain (Generic Any) Can-Chain
- [["" and]]]
- [Unique (Generic Any) Composite
- [["" for]]]
- [Specific (Generic Any) Composite
- [["" at]]]
- [Any Any Composite
- [["," or]
- [" " in]
- [">" sub]
- ["+" next]
- ["~" later]]]
- )
-
- (type: #export Combinator
- (-> (Selector Any) (Selector Any) (Selector Composite)))
-
- (def: #export (with? attribute)
- (-> Attribute (Selector Can-Chain))
- (:abstraction (format "[" attribute "]")))
-
- (template [<check> <name>]
- [(def: #export (<name> attribute value)
- (-> Attribute Text (Selector Can-Chain))
- (:abstraction (format "[" attribute <check> value "]")))]
-
- ["=" is?]
- ["~=" has?]
- ["|=" has-start?]
- ["^=" starts?]
- ["$=" ends?]
- ["*=" contains?]
- )
-
- (template [<kind> <pseudo>+]
- [(`` (template [<name> <pseudo>]
- [(def: #export <name>
- (Selector Can-Chain)
- (:abstraction <pseudo>))]
-
- (~~ (template.splice <pseudo>+))))]
-
- [Can-Chain
- [[active ":active"]
- [checked ":checked"]
- [default ":default"]
- [disabled ":disabled"]
- [empty ":empty"]
- [enabled ":enabled"]
- [first-child ":first-child"]
- [first-of-type ":first-of-type"]
- [focused ":focus"]
- [hovered ":hover"]
- [in-range ":in-range"]
- [indeterminate ":indeterminate"]
- [invalid ":invalid"]
- [last-child ":last-child"]
- [last-of-type ":last-of-type"]
- [link ":link"]
- [only-of-type ":only-of-type"]
- [only-child ":only-child"]
- [optional ":optional"]
- [out-of-range ":out-of-range"]
- [read-only ":read-only"]
- [read-write ":read-write"]
- [required ":required"]
- [root ":root"]
- [target ":target"]
- [valid ":valid"]
- [visited ":visited"]]]
-
- [Specific
- [[after "::after"]
- [before "::before"]
- [first-letter "::first-letter"]
- [first-line "::first-line"]
- [placeholder "::placeholder"]
- [selection "::selection"]]]
- )
-
- (def: #export (language locale)
- (-> Locale (Selector Can-Chain))
- (|> locale
- locale.code
- (text.enclose ["(" ")"])
- (format ":lang")
- :abstraction))
-
- (def: #export not
- (-> (Selector Any) (Selector Can-Chain))
- (|>> :representation
- (text.enclose ["(" ")"])
- (format ":not")
- :abstraction))
-
- (abstract: #export Index
- Text
-
- (def: #export index
- (-> Nat Index)
- (|>> %.nat :abstraction))
-
- (template [<name> <index>]
- [(def: #export <name> Index (:abstraction <index>))]
-
- [odd "odd"]
- [even "even"]
- )
-
- (type: #export Formula
- {#constant Int
- #variable Int})
-
- (def: #export (formula input)
- (-> Formula Index)
- (let [(^slots [#constant #variable]) input]
- (:abstraction (format (if (i.< +0 variable)
- (%.int variable)
- (%.nat (.nat variable)))
- (%.int constant)))))
-
- (template [<name> <pseudo>]
- [(def: #export (<name> index)
- (-> Index (Selector Can-Chain))
- (|> (:representation index)
- (text.enclose ["(" ")"])
- (format <pseudo>)
- (:abstraction Selector)))]
-
- [nth-child ":nth-child"]
- [nth-last-child ":nth-last-child"]
- [nth-last-of-type ":nth-last-of-type"]
- [nth-of-type ":nth-of-type"]
- )
- )
- )
diff --git a/stdlib/source/lux/data/format/css/style.lux b/stdlib/source/lux/data/format/css/style.lux
deleted file mode 100644
index 487ad5e9d..000000000
--- a/stdlib/source/lux/data/format/css/style.lux
+++ /dev/null
@@ -1,35 +0,0 @@
-(.module:
- [lux #*
- [data
- [text
- ["%" format (#+ format)]]]
- [type
- abstract]]
- ["." // #_
- ["#." value (#+ Value)]
- ["#." property (#+ Property)]])
-
-(abstract: #export Style
- Text
-
- {#.doc "The style associated with a CSS selector."}
-
- (def: #export empty
- Style
- (:abstraction ""))
-
- (def: #export separator
- " ")
-
- (def: #export (with [property value])
- (All [brand]
- (-> [(Property brand) (Value brand)]
- (-> Style Style)))
- (|>> :representation
- (format (//property.name property) ": " (//value.value value) ";" ..separator)
- :abstraction))
-
- (def: #export inline
- (-> Style Text)
- (|>> :representation))
- )
diff --git a/stdlib/source/lux/data/format/css/value.lux b/stdlib/source/lux/data/format/css/value.lux
deleted file mode 100644
index 3691bb2e4..000000000
--- a/stdlib/source/lux/data/format/css/value.lux
+++ /dev/null
@@ -1,1328 +0,0 @@
-(.module:
- [lux (#- All Cursor and static false true)
- [control
- [parser
- ["s" code]]]
- [data
- ["." color]
- ["." product]
- ["." maybe]
- [number
- ["n" nat]
- ["i" int]
- ["r" rev]
- ["f" frac]]
- ["." text
- ["%" format (#+ Format format)]]
- [collection
- ["." list ("#\." functor)]]]
- [type
- abstract]
- [macro
- ["." template]
- ["." code]
- [syntax (#+ syntax:)]]
- [world
- [net (#+ URL)]]]
- [//
- [selector (#+ Label)]])
-
-(syntax: (text-identifier {identifier s.text})
- (wrap (list (code.local-identifier identifier))))
-
-(template: (enumeration: <abstraction> <representation> <out> <sample>+ <definition>+)
- (abstract: #export <abstraction>
- <representation>
-
- (def: #export <out>
- (-> <abstraction> <representation>)
- (|>> :representation))
-
- (`` (template [<name> <value>]
- [(def: #export <name> <abstraction> (:abstraction <value>))]
-
- (~~ (template.splice <sample>+))
- ))
-
- (template.splice <definition>+)))
-
-(template: (multi: <multi> <type> <separator>)
- (def: #export (<multi> pre post)
- (-> (Value <type>) (Value <type>) (Value <type>))
- (:abstraction (format (:representation pre)
- <separator>
- (:representation post)))))
-
-(def: (%number value)
- (Format Frac)
- (let [raw (%.frac value)]
- (if (f.< +0.0 value)
- raw
- (|> raw (text.split 1) maybe.assume product.right))))
-
-(abstract: #export (Value brand)
- Text
-
- (def: #export value
- (-> (Value Any) Text)
- (|>> :representation))
-
- (template [<name> <value>]
- [(def: #export <name> Value (:abstraction <value>))]
-
- [initial "initial"]
- [inherit "inherit"]
- [unset "unset"]
- )
-
- (template [<brand> <alias>+ <value>+]
- [(abstract: #export <brand> Any)
-
- (`` (template [<name> <value>]
- [(def: #export <name>
- (Value <brand>)
- (:abstraction <value>))]
-
- (~~ (template.splice <alias>+))))
-
- (with-expansions [<rows> (template.splice <value>+)]
- (template [<value>]
- [(`` (def: #export (~~ (text-identifier <value>))
- (Value <brand>)
- (:abstraction <value>)))]
-
- <rows>))]
-
- [All
- []
- []]
-
- [Number
- []
- []]
-
- [Length
- []
- []]
-
- [Time
- []
- []]
-
- [Thickness
- []
- [["medium"]
- ["thin"]
- ["thick"]]]
-
- [Slice
- [[full-slice "fill"]]
- []]
-
- [Alignment
- [[auto-alignment "auto"]]
- [["stretch"]
- ["center"]
- ["flex-start"]
- ["flex-end"]
- ["baseline"]
- ["space-between"]
- ["space-around"]]]
-
- [Animation
- []
- []]
-
- [Animation-Direction
- [[normal-direction "normal"]]
- [["reverse"]
- ["alternate"]
- ["alternate-reverse"]]]
-
- [Animation-Fill
- [[fill-forwards "forwards"]
- [fill-backwards "backwards"]
- [fill-both "both"]]
- []]
-
- [Column-Fill
- []
- [["balance"]
- ["auto"]]]
-
- [Column-Span
- []
- [["all"]]]
-
- [Iteration
- []
- [["infinite"]]]
-
- [Count
- []
- []]
-
- [Play
- []
- [["paused"]
- ["running"]]]
-
- [Timing
- []
- [["linear"]
- ["ease"]
- ["ease-in"]
- ["ease-out"]
- ["ease-in-out"]
- ["step-start"]
- ["step-end"]]]
-
- [Visibility
- [[invisible "hidden"]
- [collapse-visibility "collapse"]]
- [["visible"]]]
-
- [Attachment
- [[scroll-attachment "scroll"]
- [fixed-attachment "fixed"]
- [local-attachment "local"]]
- []]
-
- [Blend
- [[normal-blend "normal"]]
- [["multiply"]
- ["screen"]
- ["overlay"]
- ["darken"]
- ["lighten"]
- ["color-dodge"]
- ["color-burn"]
- ["difference"]
- ["exclusion"]
- ["hue"]
- ["saturation"]
- ["color"]
- ["luminosity"]]]
-
- [Span
- []
- [["border-box"]
- ["padding-box"]
- ["content-box"]]]
-
- [Image
- [[no-image "none"]]
- []]
-
- [Repeat
- [[stretch-repeat "stretch"]]
- [["repeat"]
- ["repeat-x"]
- ["repeat-y"]
- ["no-repeat"]
- ["space"]
- ["round"]]]
-
- [Location
- [[left-top "left top"]
- [left-center "left center"]
- [left-bottom "left bottom"]
- [right-top "right top"]
- [right-center "right center"]
- [right-bottom "right bottom"]
- [center-top "center top"]
- [center-center "center center"]
- [center-bottom "center bottom"]]
- []]
-
- [Fit
- [[no-fit "none"]]
- [["fill"]
- ["cover"]
- ["contain"]
- ["scale-down"]]]
-
- [Border
- []
- [["hidden"]
- ["dotted"]
- ["dashed"]
- ["solid"]
- ["double"]
- ["groove"]
- ["ridge"]
- ["inset"]
- ["outset"]]]
-
- [Collapse
- []
- [["separate"]
- ["collapse"]]]
-
- [Box-Decoration-Break
- []
- [["slice"]
- ["clone"]]]
-
- [Caption
- []
- [["top"]
- ["bottom"]]]
-
- [Float
- [[float-left "left"]
- [float-right "right"]]
- []]
-
- [Clear
- [[clear-left "left"]
- [clear-right "right"]
- [clear-both "both"]]
- []]
-
- [Counter
- []
- []]
-
- [Content
- []
- [["open-quote"]
- ["close-quote"]
- ["no-open-quote"]
- ["no-close-quote"]]]
-
- [Cursor
- [[horizontal-text "text"]
- [no-cursor "none"]]
- [["alias"]
- ["all-scroll"]
- ["cell"]
- ["context-menu"]
- ["col-resize"]
- ["copy"]
- ["crosshair"]
- ["default"]
- ["e-resize"]
- ["ew-resize"]
- ["grab"]
- ["grabbing"]
- ["help"]
- ["move"]
- ["n-resize"]
- ["ne-resize"]
- ["nesw-resize"]
- ["ns-resize"]
- ["nw-resize"]
- ["nwse-resize"]
- ["no-drop"]
- ["not-allowed"]
- ["pointer"]
- ["progress"]
- ["row-resize"]
- ["s-resize"]
- ["se-resize"]
- ["sw-resize"]
- ["vertical-text"]
- ["w-resize"]
- ["wait"]
- ["zoom-in"]
- ["zoom-out"]]]
-
- [Shadow
- []
- []]
-
- [Clip
- []
- []]
-
- [Text-Direction
- [[left-to-right "ltr"]
- [right-to-left "rtl"]]
- []]
-
- [Display
- [[grid-display "grid"]
- [no-display "none"]]
- [["inline"]
- ["block"]
- ["contents"]
- ["flex"]
- ["inline-block"]
- ["inline-flex"]
- ["inline-grid"]
- ["inline-table"]
- ["list-item"]
- ["run-in"]
- ["table"]
- ["table-caption"]
- ["table-column-group"]
- ["table-header-group"]
- ["table-footer-group"]
- ["table-row-group"]
- ["table-cell"]
- ["table-column"]
- ["table-row"]]]
-
- [Empty
- []
- [["show"]
- ["hide"]]]
-
- [Filter
- []
- []]
-
- [Flex-Direction
- []
- [["row"]
- ["row-reverse"]
- ["column"]
- ["column-reverse"]]]
-
- [Flex-Wrap
- [[no-wrap "nowrap"]]
- [["wrap"]
- ["wrap-reverse"]]]
-
- [Font-Kerning
- [[auto-kerning "auto"]
- [normal-kerning "normal"]
- [no-kerning "none"]]
- []]
-
- [Font-Size
- [[medium-size "medium"]
- [xx-small-size "xx-small"]
- [x-small-size "x-small"]
- [small-size "small"]
- [large-size "large"]
- [x-large-size "x-large"]
- [xx-large-size "xx-large"]
- [smaller-size "smaller"]
- [larger-size "larger"]]
- []]
-
- [Font-Stretch
- [[normal-stretch "normal"]]
- [["condensed"]
- ["ultra-condensed"]
- ["extra-condensed"]
- ["semi-condensed"]
- ["expanded"]
- ["semi-expanded"]
- ["extra-expanded"]
- ["ultra-expanded"]]]
-
- [Font-Style
- [[normal-style "normal"]]
- [["italic"]
- ["oblique"]]]
-
- [Font-Weight
- [[normal-weight "normal"]
- [weight-100 "100"]
- [weight-200 "200"]
- [weight-300 "300"]
- [weight-400 "400"]
- [weight-500 "500"]
- [weight-600 "600"]
- [weight-700 "700"]
- [weight-800 "800"]
- [weight-900 "900"]]
- [["bold"]]]
-
- [Font-Variant
- [[normal-font "normal"]]
- [["small-caps"]]]
-
- [Grid
- []
- []]
-
- [Grid-Content
- [[auto-content "auto"]]
- [["max-content"]
- ["min-content"]]]
-
- [Grid-Flow
- [[row-flow "row"]
- [column-flow "column"]
- [dense-flow "dense"]
- [row-dense-flow "row dense"]
- [column-dense-flow "column dense"]]
- []]
-
- [Grid-Span
- [[auto-span "auto"]]
- []]
-
- [Grid-Template
- []
- []]
-
- [Hanging-Punctuation
- [[no-hanging-punctuation "none"]]
- [["first"]
- ["last"]
- ["allow-end"]
- ["force-end"]]]
-
- [Hyphens
- [[no-hyphens "none"]
- [manual-hyphens "manual"]
- [auto-hyphens "auto"]]
- []]
-
- [Orientation
- []
- [["portrait"]
- ["landscape"]]]
-
- [Resolution
- []
- []]
-
- [Scan
- []
- [["interlace"]
- ["progressive"]]]
-
- [Boolean
- [[false "0"]
- [true "1"]]
- []]
-
- [Update
- [[no-update "none"]
- [slow-update "slow"]
- [fast-update "fast"]]
- []]
-
- [Block-Overflow
- [[no-block-overflow "none"]
- [scroll-block-overflow "scroll"]
- [optional-paged-block-overflow "optional-paged"]
- [paged-block-overflow "paged"]]
- []]
-
- [Inline-Overflow
- [[no-inline-overflow "none"]
- [scroll-inline-overflow "scroll"]]
- []]
-
- [Display-Mode
- []
- [["fullscreen"]
- ["standalone"]
- ["minimal-ui"]
- ["browser"]]]
-
- [Color-Gamut
- []
- [["srgb"]
- ["p3"]
- ["rec2020"]]]
-
- [Inverted-Colors
- [[no-inverted-colors "none"]
- [inverted-colors "inverted"]]
- []]
-
- [Pointer
- [[no-pointer "none"]
- [coarse-pointer "coarse"]
- [fine-pointer "fine"]]
- []]
-
- [Hover
- [[no-hover "none"]]
- [["hover"]]]
-
- [Light
- [[dim-light "dim"]
- [normal-light "normal"]
- [washed-light "washed"]]
- []]
-
- [Ratio
- []
- []]
-
- [Scripting
- [[no-scripting "none"]
- [initial-scripting-only "initial-only"]
- [scripting-enabled "enabled"]]
- []]
-
- [Motion
- [[no-motion-preference "no-preference"]
- [reduced-motion "reduce"]]
- []]
-
- [Color-Scheme
- [[no-color-scheme-preference "no-preference"]
- [light-color-scheme "light"]
- [dark-color-scheme "dark"]]
- []]
-
- [Isolation
- [[auto-isolation "auto"]]
- [["isolate"]]]
-
- [List-Style-Position
- []
- [["inside"]
- ["outside"]]]
-
- [List-Style-Type
- [[no-list-style "none"]]
- [["disc"]
- ["armenian"]
- ["circle"]
- ["cjk-ideographic"]
- ["decimal"]
- ["decimal-leading-zero"]
- ["georgian"]
- ["hebrew"]
- ["hiragana"]
- ["hiragana-iroha"]
- ["katakana"]
- ["katakana-iroha"]
- ["lower-alpha"]
- ["lower-greek"]
- ["lower-latin"]
- ["lower-roman"]
- ["square"]
- ["upper-alpha"]
- ["upper-greek"]
- ["upper-latin"]
- ["upper-roman"]]]
-
- [Color
- []
- []]
-
- [Overflow
- [[visible-overflow "visible"]
- [hidden-overflow "hidden"]
- [scroll-overflow "scroll"]
- [auto-overflow "auto"]]
- []]
-
- [Page-Break
- [[auto-page-break "auto"]
- [always-page-break "always"]
- [avoid-page-break "avoid"]
- [left-page-break "left"]
- [right-page-break "right"]]
- []]
-
- [Pointer-Events
- [[auto-pointer-events "auto"]
- [no-pointer-events "none"]]
- []]
-
- [Position
- []
- [["static"]
- ["absolute"]
- ["fixed"]
- ["relative"]
- ["sticky"]]]
-
- [Quotes
- [[no-quotes "none"]]
- []]
-
- [Resize
- [[resize-none "none"]
- [resize-both "both"]
- [resize-horizontal "horizontal"]
- [resize-vertical "vertical"]]
- []]
-
- [Scroll-Behavior
- [[auto-scroll-behavior "auto"]
- [smooth-scroll-behavior "smooth"]]
- []]
-
- [Table-Layout
- [[auto-table-layout "auto"]
- [fixed-table-layout "fixed"]]
- []]
-
- [Text-Align
- [[left-text-align "left"]
- [right-text-align "right"]
- [center-text-align "center"]
- [justify-text-align "justify"]]
- []]
-
- [Text-Align-Last
- [[auto-text-align-last "auto"]
- [left-text-align-last "left"]
- [right-text-align-last "right"]
- [center-text-align-last "center"]
- [justify-text-align-last "justify"]
- [start-text-align-last "start"]
- [end-text-align-last "end"]]
- []]
-
- [Text-Decoration-Line
- [[no-text-decoration-line "none"]
- [underline-text-decoration-line "underline"]
- [overline-text-decoration-line "overline"]
- [line-through-text-decoration-line "line-through"]]
- []]
-
- [Text-Decoration-Style
- [[solid-text-decoration-style "solid"]
- [double-text-decoration-style "double"]
- [dotted-text-decoration-style "dotted"]
- [dashed-text-decoration-style "dashed"]
- [wavy-text-decoration-style "wavy"]]
- []]
-
- [Text-Justification
- [[auto-text-justification "auto"]
- [inter-word-text-justification "inter-word"]
- [inter-character-text-justification "inter-character"]
- [no-text-justification "none"]]
- []]
-
- [Text-Overflow
- [[clip-text-overflow "clip"]
- [ellipsis-text-overflow "ellipsis"]]
- []]
-
- [Text-Transform
- [[no-text-transform "none"]]
- [["capitalize"]
- ["uppercase"]
- ["lowercase"]]]
-
- [Transform
- [[no-transform "none"]]
- []]
-
- [Transform-Origin
- []
- []]
-
- [Transform-Style
- []
- [["flat"]
- ["preserve-3d"]]]
-
- [Transition
- [[transition-none "none"]
- [transition-all "all"]]
- []]
-
- [Bidi
- [[bidi-normal "normal"]
- [bidi-embed "embed"]
- [bidi-isolate "isolate"]
- [bidi-isolate-override "isolate-override"]
- [bidi-plaintext "plaintext"]]
- [["bidi-override"]]]
-
- [User-Select
- [[user-select-auto "auto"]
- [user-select-none "none"]
- [user-select-text "text"]
- [user-select-all "all"]]
- []]
-
- [Vertical-Align
- [[vertical-align-baseline "baseline"]
- [vertical-align-sub "sub"]
- [vertical-align-super "super"]
- [vertical-align-top "top"]
- [vertical-align-text-top "text-top"]
- [vertical-align-middle "middle"]
- [vertical-align-bottom "bottom"]
- [vertical-align-text-bottom "text-bottom"]]
- []]
-
- [White-Space
- [[normal-white-space "normal"]
- [no-wrap-white-space "nowrap"]
- [pre-white-space "pre"]
- [pre-line-white-space "pre-line"]
- [pre-wrap-white-space "pre-wrap"]]
- []]
-
- [Word-Break
- [[normal-word-break "normal"]]
- [["break-all"]
- ["keep-all"]
- ["break-word"]]]
-
- [Word-Wrap
- [[normal-word-wrap "normal"]
- [break-word-word-wrap "break-word"]]
- []]
-
- [Writing-Mode
- [[top-to-bottom-writing-mode "horizontal-tb"]
- [left-to-right-writing-mode "vertical-rl"]
- [right-to-left-writing-mode "vertical-lr"]]
- []]
-
- [Z-Index
- []
- []]
- )
-
- (def: value-separator ",")
-
- (def: (apply name inputs)
- (-> Text (List Text) Value)
- (|> inputs
- (text.join-with ..value-separator)
- (text.enclose ["(" ")"])
- (format name)
- :abstraction))
-
- (enumeration: Step Text
- step
- [[start "start"]
- [end "end"]]
- [])
-
- (def: #export (steps intervals step)
- (-> Nat Step (Value Timing))
- (..apply "steps" (list (%.nat intervals) (..step step))))
-
- (def: #export (cubic-bezier p0 p1 p2 p3)
- (-> Frac Frac Frac Frac (Value Timing))
- (|> (list p0 p1 p2 p3)
- (list\map %number)
- (..apply "cubic-bezier")))
-
- (template [<name> <brand>]
- [(def: #export <name>
- (-> Nat (Value <brand>))
- (|>> %.nat :abstraction))]
-
- [iteration Iteration]
- [count Count]
- [slice-number/1 Slice]
- [span-line Grid-Span]
- )
-
- (def: #export animation
- (-> Label (Value Animation))
- (|>> :abstraction))
-
- (def: #export (rgb color)
- (-> color.Color (Value Color))
- (let [[red green blue] (color.to-rgb color)]
- (..apply "rgb" (list (%.nat red)
- (%.nat green)
- (%.nat blue)))))
-
- (def: #export (rgba pigment)
- (-> color.Pigment (Value Color))
- (let [(^slots [#color.color #color.alpha]) pigment
- [red green blue] (color.to-rgb color)]
- (..apply "rgba" (list (%.nat red)
- (%.nat green)
- (%.nat blue)
- (if (r.= (\ r.interval top) alpha)
- "1.0"
- (format "0" (%.rev alpha)))))))
-
- (template [<name> <suffix>]
- [(def: #export (<name> value)
- (-> Frac (Value Length))
- (:abstraction (format (%number value) <suffix>)))]
-
- [em "em"]
- [ex "ex"]
- [rem "rem"]
- [ch "ch"]
- [vw "vw"]
- [vh "vh"]
- [vmin "vmin"]
- [vmax "vmax"]
- [% "%"]
- [cm "cm"]
- [mm "mm"]
- [in "in"]
- [px "px"]
- [pt "pt"]
- [pc "pc"]
- [fr "fr"]
- )
-
- (def: (%int value)
- (Format Int)
- (if (i.< +0 value)
- (%.int value)
- (%.nat (.nat value))))
-
- (template [<name> <suffix>]
- [(def: #export (<name> value)
- (-> Int (Value Time))
- (:abstraction (format (if (i.< +0 value)
- (%.int value)
- (%.nat (.nat value)))
- <suffix>)))]
-
-
- [seconds "s"]
- [milli-seconds "ms"]
- )
-
- (def: #export thickness
- (-> (Value Length) (Value Thickness))
- (|>> :transmutation))
-
- (def: slice-separator " ")
-
- (def: #export (slice-number/2 horizontal vertical)
- (-> Nat Nat (Value Slice))
- (:abstraction (format (%.nat horizontal) ..slice-separator
- (%.nat vertical))))
-
- (abstract: #export Stop
- Text
-
- (def: #export stop
- (-> (Value Color) Stop)
- (|>> (:representation Value) (:abstraction Stop)))
-
- (def: stop-separator " ")
-
- (def: #export (single-stop length color)
- (-> (Value Length) (Value Color) Stop)
- (:abstraction (format (:representation Value color) ..stop-separator
- (:representation Value length))))
-
- (def: #export (double-stop start end color)
- (-> (Value Length) (Value Length) (Value Color) Stop)
- (:abstraction (format (:representation Value color) ..stop-separator
- (:representation Value start) ..stop-separator
- (:representation Value end))))
-
- (abstract: #export Hint
- Text
-
- (def: #export hint
- (-> (Value Length) Hint)
- (|>> (:representation Value) (:abstraction Hint)))
-
- (def: (with-hint [hint stop])
- (-> [(Maybe Hint) Stop] Text)
- (case hint
- #.None
- (:representation Stop stop)
-
- (#.Some hint)
- (format (:representation Hint hint) ..value-separator (:representation Stop stop))))))
-
- (type: #export (List/1 a)
- [a (List a)])
-
- (abstract: #export Angle
- Text
-
- (def: #export angle
- (-> Angle Text)
- (|>> :representation))
-
- (def: #export (turn value)
- (-> Rev Angle)
- (:abstraction (format (%.rev value) "turn")))
-
- (def: degree-limit Nat 360)
-
- (def: #export (degree value)
- (-> Nat Angle)
- (:abstraction (format (%.nat (n.% ..degree-limit value)) "deg")))
-
- (template [<degree> <name>]
- [(def: #export <name> Angle (..degree <degree>))]
-
- [000 to-top]
- [090 to-right]
- [180 to-bottom]
- [270 to-left]
- )
-
- (template [<name> <function>]
- [(def: #export (<name> angle start next)
- (-> Angle Stop (List/1 [(Maybe Hint) Stop]) (Value Image))
- (let [[now after] next]
- (..apply <function> (list& (:representation Angle angle)
- (with-hint now)
- (list\map with-hint after)))))]
-
- [linear-gradient "linear-gradient"]
- [repeating-linear-gradient "repeating-linear-gradient"]
- )
- )
-
- (abstract: #export Percentage
- Text
-
- (def: #export percentage
- (-> Percentage Text)
- (|>> :representation))
-
- (def: percentage-limit Nat (.inc 100))
-
- (def: #export (%% value)
- (-> Nat Percentage)
- (:abstraction (format (%.nat (n.% percentage-limit value)) "%")))
-
- (def: #export slice-percent/1
- (-> Percentage (Value Slice))
- (|>> :representation (:abstraction Value)))
-
- (def: #export (slice-percent/2 horizontal vertical)
- (-> Percentage Percentage (Value Slice))
- (:abstraction Value (format (:representation horizontal) ..slice-separator
- (:representation vertical))))
-
- (template [<input> <pre> <function>+]
- [(`` (template [<name> <function>]
- [(def: #export <name>
- (-> <input> (Value Filter))
- (|>> <pre> (list) (..apply <function>)))]
-
- (~~ (template.splice <function>+))))]
-
- [Nat (<| (:representation Value) ..px n.frac)
- [[blur "blur"]]]
- [Nat (<| ..angle ..degree)
- [[hue-rotate "hue-rotate"]]]
- [Percentage (:representation Percentage)
- [[brightness "brightness"]
- [contrast "contrast"]
- [grayscale "grayscale"]
- [invert "invert"]
- [opacity "opacity"]
- [saturate "saturate"]
- [sepia "sepia"]]]
- )
- )
-
- (def: #export svg-filter
- (-> URL (Value Filter))
- (|>> (list) (..apply "url")))
-
- (def: default-shadow-length (px +0.0))
-
- (def: #export (drop-shadow horizontal vertical blur spread color)
- (-> (Value Length) (Value Length)
- (Maybe (Value Length)) (Maybe (Value Length))
- (Value Color)
- (Value Filter))
- (|> (list (:representation horizontal)
- (:representation vertical)
- (|> blur (maybe.default ..default-shadow-length) :representation)
- (|> spread (maybe.default ..default-shadow-length) :representation)
- (:representation color))
- (text.join-with " ")
- (list)
- (..apply "drop-shadow")))
-
- (def: length-separator " ")
-
- (template [<name> <type>]
- [(def: #export (<name> horizontal vertical)
- (-> (Value Length) (Value Length) (Value <type>))
- (:abstraction (format (:representation horizontal)
- ..length-separator
- (:representation vertical))))]
-
- [location Location]
- [fit Fit]
- )
-
- (def: #export (fit/1 length)
- (-> (Value Length) (Value Fit))
- (..fit length length))
-
- (def: #export image
- (-> URL (Value Image))
- (|>> %.text
- (list)
- (..apply "url")))
-
- (enumeration: Shape Text
- shape
- [[ellipse-shape "ellipse"]
- [circle-shape "circle"]]
- [])
-
- (enumeration: Extent Text
- extent
- [[closest-side "closest-side"]
- [closest-corner "closest-corner"]
- [farthest-side "farthest-side"]
- [farthest-corner "farthest-corner"]]
- [])
-
- (template [<name> <function>]
- [(def: #export (<name> shape extent location start next)
- (-> Shape (Maybe Extent) (Value Location)
- Stop (List/1 [(Maybe Hint) Stop])
- (Value Image))
- (let [after-extent (format "at " (:representation location))
- with-extent (case extent
- (#.Some extent)
- (format (..extent extent) " " after-extent)
-
- #.None
- after-extent)
- where (format (..shape shape) " " with-extent)
- [now after] next]
- (..apply <function> (list& (..shape shape)
- (with-hint now)
- (list\map with-hint after)))))]
-
- [radial-gradient "radial-gradient"]
- [repeating-radial-gradient "repeating-radial-gradient"]
- )
-
- (def: #export (shadow horizontal vertical blur spread color inset?)
- (-> (Value Length) (Value Length)
- (Maybe (Value Length)) (Maybe (Value Length))
- (Value Color) Bit
- (Value Shadow))
- (let [with-inset (if inset?
- (list "inset")
- (list))]
- (|> (list& (:representation horizontal)
- (:representation vertical)
- (|> blur (maybe.default ..default-shadow-length) :representation)
- (|> spread (maybe.default ..default-shadow-length) :representation)
- (:representation color)
- with-inset)
- (text.join-with " ")
- :abstraction)))
-
- (type: #export Rectangle
- {#top (Value Length)
- #right (Value Length)
- #bottom (Value Length)
- #left (Value Length)})
-
- (def: #export (clip rectangle)
- (-> Rectangle (Value Clip))
- (`` (..apply "rect" (list (~~ (template [<side>]
- [(:representation (get@ <side> rectangle))]
-
- [#top] [#right] [#bottom] [#left]))))))
-
- (def: #export counter
- (-> Label (Value Counter))
- (|>> :abstraction))
-
- (def: #export current-count
- (-> (Value Counter) (Value Content))
- (|>> :representation (list) (..apply "counter")))
-
- (def: #export text
- (-> Text (Value Content))
- (|>> %.text :abstraction))
-
- (def: #export attribute
- (-> Label (Value Content))
- (|>> (list) (..apply "attr")))
-
- (def: #export media
- (-> URL (Value Content))
- (|>> (list) (..apply "url")))
-
- (enumeration: Font Text
- font-name
- [[serif "serif"]
- [sans-serif "sans-serif"]
- [cursive "cursive"]
- [fantasy "fantasy"]
- [monospace "monospace"]]
- [(def: #export font
- (-> Text Font)
- (|>> %.text :abstraction))
-
- (def: #export (font-family options)
- (-> (List Font) (Value Font))
- (case options
- (#.Cons _)
- (|> options
- (list\map ..font-name)
- (text.join-with ",")
- (:abstraction Value))
-
- #.Nil
- ..initial))])
-
- (def: #export font-size
- (-> (Value Length) (Value Font-Size))
- (|>> :transmutation))
-
- (def: #export number
- (-> Frac (Value Number))
- (|>> %number :abstraction))
-
- (def: #export grid
- (-> Label (Value Grid))
- (|>> :abstraction))
-
- (def: #export fit-content
- (-> (Value Length) (Value Grid-Content))
- (|>> :representation (list) (..apply "fit-content")))
-
- (def: #export (min-max min max)
- (-> (Value Grid-Content) (Value Grid-Content) (Value Grid-Content))
- (..apply "minmax" (list (:representation min)
- (:representation max))))
-
- (def: #export grid-span
- (-> Nat (Value Grid-Span))
- (|>> %.nat (format "span ") :abstraction))
-
- (def: grid-column-separator " ")
- (def: grid-row-separator " ")
-
- (def: #export grid-template
- (-> (List (List (Maybe (Value Grid)))) (Value Grid-Template))
- (let [empty (: (Value Grid)
- (:abstraction "."))]
- (|>> (list\map (|>> (list\map (|>> (maybe.default empty)
- :representation))
- (text.join-with ..grid-column-separator)
- (text.enclose ["'" "'"])))
- (text.join-with ..grid-row-separator)
- :abstraction)))
-
- (def: #export (resolution dpi)
- (-> Nat (Value Resolution))
- (:abstraction (format (%.nat dpi) "dpi")))
-
- (def: #export (ratio numerator denominator)
- (-> Nat Nat (Value Ratio))
- (:abstraction (format (%.nat numerator) "/" (%.nat denominator))))
-
- (enumeration: Quote Text
- quote-text
- [[double-quote "\0022"]
- [single-quote "\0027"]
- [single-left-angle-quote "\2039"]
- [single-right-angle-quote "\203A"]
- [double-left-angle-quote "\00AB"]
- [double-right-angle-quote "\00BB"]
- [single-left-quote "\2018"]
- [single-right-quote "\2019"]
- [double-left-quote "\201C"]
- [double-right-quote "\201D"]
- [low-double-quote "\201E"]]
- [(def: #export quote
- (-> Text Quote)
- (|>> :abstraction))])
-
- (def: quote-separator " ")
-
- (def: #export (quotes [left0 right0] [left1 right1])
- (-> [Quote Quote] [Quote Quote] (Value Quotes))
- (|> (list left0 right0 left1 right1)
- (list\map (|>> ..quote-text %.text))
- (text.join-with ..quote-separator)
- :abstraction))
-
- (def: #export (matrix-2d [a b] [c d] [tx ty])
- (-> [Frac Frac]
- [Frac Frac]
- [Frac Frac]
- (Value Transform))
- (|> (list a b c d tx ty)
- (list\map %number)
- (..apply "matrix")))
-
- (def: #export (matrix-3d [a0 b0 c0 d0] [a1 b1 c1 d1] [a2 b2 c2 d2] [a3 b3 c3 d3])
- (-> [Frac Frac Frac Frac]
- [Frac Frac Frac Frac]
- [Frac Frac Frac Frac]
- [Frac Frac Frac Frac]
- (Value Transform))
- (|> (list a0 b0 c0 d0 a1 b1 c1 d1 a2 b2 c2 d2 a3 b3 c3 d3)
- (list\map %number)
- (..apply "matrix3d")))
-
- (template [<name> <function> <input-types> <input-values>]
- [(`` (def: #export (<name> [(~~ (template.splice <input-values>))])
- (-> [(~~ (template.splice <input-types>))] (Value Transform))
- (|> (list (~~ (template.splice <input-values>)))
- (list\map %number)
- (..apply <function>))))]
-
- [translate-2d "translate" [Frac Frac] [x y]]
- [translate-3d "translate3d" [Frac Frac Frac] [x y z]]
- [translate-x "translateX" [Frac] [value]]
- [translate-y "translateY" [Frac] [value]]
- [translate-z "translateZ" [Frac] [value]]
-
- [scale-2d "scale" [Frac Frac] [x y]]
- [scale-3d "scale3d" [Frac Frac Frac] [x y z]]
- [scale-x "scaleX" [Frac] [value]]
- [scale-y "scaleY" [Frac] [value]]
- [scale-z "scaleZ" [Frac] [value]]
-
- [perspective "perspective" [Frac] [value]]
- )
-
- (template [<name> <function> <input-types> <input-values>]
- [(`` (def: #export (<name> [(~~ (template.splice <input-values>))])
- (-> [(~~ (template.splice <input-types>))] (Value Transform))
- (|> (list (~~ (template.splice <input-values>)))
- (list\map ..angle)
- (..apply <function>))))]
-
- [rotate-2d "rotate" [Angle] [angle]]
- [rotate-x "rotateX" [Angle] [angle]]
- [rotate-y "rotateY" [Angle] [angle]]
- [rotate-z "rotateZ" [Angle] [angle]]
-
- [skew "skew" [Angle Angle] [x-angle y-angle]]
- [skew-x "skewX" [Angle] [angle]]
- [skew-y "skewY" [Angle] [angle]]
- )
-
- (def: #export (rotate-3d [x y z angle])
- (-> [Frac Frac Frac Angle] (Value Transform))
- (..apply "rotate3d"
- (list (%number x) (%number y) (%number z) (..angle angle))))
-
- (def: origin-separator " ")
-
- (def: #export (origin-2d x y)
- (-> (Value Length) (Value Length) (Value Transform-Origin))
- (:abstraction (format (:representation x) ..origin-separator
- (:representation y))))
-
- (def: #export (origin-3d x y z)
- (-> (Value Length) (Value Length) (Value Length) (Value Transform-Origin))
- (:abstraction (format (:representation x) ..origin-separator
- (:representation y) ..origin-separator
- (:representation z))))
-
- (def: #export vertical-align
- (-> (Value Length) (Value Vertical-Align))
- (|>> :transmutation))
-
- (def: #export (z-index index)
- (-> Int (Value Z-Index))
- (:abstraction (if (i.< +0 index)
- (%.int index)
- (%.nat (.nat index)))))
-
- (multi: multi-image Image ",")
- (multi: multi-shadow Shadow ",")
- (multi: multi-content Content " ")
- )
diff --git a/stdlib/source/lux/data/format/html.lux b/stdlib/source/lux/data/format/html.lux
deleted file mode 100644
index a33182f19..000000000
--- a/stdlib/source/lux/data/format/html.lux
+++ /dev/null
@@ -1,562 +0,0 @@
-(.module:
- [lux (#- Meta Source comment and)
- ["." function]
- [data
- ["." product]
- ["." maybe ("#\." functor)]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [type
- abstract]
- [host
- ["." js]]
- [macro
- ["." template]]
- [world
- [net (#+ URL)]]]
- [//
- [css
- ["." selector]
- ["." style (#+ Style)]]
- ["." xml (#+ XML)]])
-
-(type: #export Tag selector.Tag)
-(type: #export ID selector.ID)
-(type: #export Class selector.Class)
-
-(type: #export Attributes
- {#.doc "Attributes for an HTML tag."}
- (List [Text Text]))
-
-(type: #export Script js.Statement)
-
-(type: #export Target
- #Blank
- #Parent
- #Self
- #Top
- (#Frame Text))
-
-(def: (target value)
- (-> Target Text)
- (case value
- #Blank "_blank"
- #Parent "_parent"
- #Self "_self"
- #Top "_top"
- (#Frame name) name))
-
-(def: sanitize
- {#.doc "Properly formats text to ensure no injection can happen on the HTML."}
- (-> Text Text)
- (|>> (text.replace-all "&" "&amp;")
- (text.replace-all "<" "&lt;")
- (text.replace-all ">" "&gt;")
- (text.replace-all text.double-quote "&quot;")
- (text.replace-all "'" "&#x27;")
- (text.replace-all "/" "&#x2F;")))
-
-(def: attributes
- (-> Attributes Text)
- (|>> (list\map (function (_ [key val])
- (format key "=" text.double-quote (..sanitize val) text.double-quote)))
- (text.join-with " ")))
-
-(def: (open tag attributes)
- (-> Tag Attributes Text)
- (|> attributes
- ..attributes
- (format tag " ")
- (text.enclose ["<" ">"])))
-
-(def: close
- (-> Tag Text)
- (text.enclose ["</" ">"]))
-
-(abstract: #export (HTML brand)
- Text
-
- (template [<name> <brand>]
- [(abstract: #export <brand> Any)
- (type: #export <name> (HTML <brand>))]
-
- [Meta Meta']
- [Head Head']
- [Item Item']
- [Option Option']
- [Input Input']
- [Cell Cell']
- [Header Header']
- [Row Row']
- [Column Column']
- [Parameter Parameter']
- [Body Body']
- [Document Document']
- )
-
- (template [<super> <super-raw> <sub>+]
- [(abstract: #export (<super-raw> brand) Any)
- (type: #export <super> (HTML (<super-raw> Any)))
-
- (`` (template [<sub> <sub-raw>]
- [(abstract: #export <sub-raw> Any)
- (type: #export <sub> (HTML (<super-raw> <sub-raw>)))]
-
- (~~ (template.splice <sub>+))))]
-
- [Element Element'
- [[Content Content']
- [Image Image']]]
-
- [Media Media'
- [[Source Source']
- [Track Track']]]
- )
-
- (def: #export html
- (-> Document Text)
- (|>> :representation))
-
- (def: #export (and pre post)
- (All [brand] (-> (HTML brand) (HTML brand) (HTML brand)))
- (:abstraction (format (:representation pre) (:representation post))))
-
- (def: #export (comment content node)
- (All [brand] (-> Text (HTML brand) (HTML brand)))
- (:abstraction
- (format (text.enclose ["<!--" "-->"] content)
- (:representation node))))
-
- (def: (empty name attributes)
- (-> Tag Attributes HTML)
- (:abstraction
- (format (..open name attributes)
- (..close name))))
-
- (def: (simple tag attributes)
- (-> Tag Attributes HTML)
- (|> attributes
- (..open tag)
- :abstraction))
-
- (def: (tag name attributes content)
- (-> Tag Attributes (HTML Any) HTML)
- (:abstraction
- (format (..open name attributes)
- (:representation content)
- (..close name))))
-
- (def: (raw tag attributes content)
- (-> Text Attributes Text HTML)
- (:abstraction
- (format (..open tag attributes)
- content
- (..close tag))))
-
- (template [<name> <tag> <brand>]
- [(def: #export <name>
- (-> Attributes <brand>)
- (..simple <tag>))]
-
- [link "link" Meta]
- [meta "meta" Meta]
- [input "input" Input]
- [embedded "embed" Element]
- [column "col" Column]
- [parameter "param" Parameter]
- )
-
- (def: #export (base href target)
- (-> URL (Maybe Target) Meta)
- (let [partial (list ["href" href])
- full (case target
- (#.Some target)
- (list& ["target" (..target target)] partial)
-
- #.None
- partial)]
- (..simple "base" full)))
-
- (def: #export style
- (-> Style Meta)
- (|>> style.inline (..raw "style" (list))))
-
- (def: #export (script attributes inline)
- (-> Attributes (Maybe Script) Meta)
- (|> inline
- (maybe\map js.code)
- (maybe.default "")
- (..raw "script" attributes)))
-
- (def: #export text
- (-> Text Content)
- (|>> ..sanitize
- :abstraction))
-
- (template [<tag> <alias> <name>]
- [(def: #export <name>
- Element
- (..simple <tag> (list)))
-
- (def: #export <alias> <name>)]
- ["br" br line-break]
- ["wbr" wbr word-break]
- ["hr" hr separator]
- )
-
- (def: #export (image source attributes)
- (-> URL Attributes Image)
- (|> attributes
- (#.Cons ["src" source])
- (..simple "img")))
-
- (def: #export (svg attributes content)
- (-> Attributes XML Element)
- (|> content
- (\ xml.codec encode)
- (..raw "svg" attributes)))
-
- (type: #export Coord
- {#horizontal Nat
- #vertical Nat})
-
- (def: metric-separator ",")
- (def: coord-separator ",")
-
- (def: (%coord [horizontal vertical])
- (Format Coord)
- (format (%.nat horizontal) ..metric-separator (%.nat vertical)))
-
- (type: #export Rectangle
- {#start Coord
- #end Coord})
-
- (type: #export Circle
- {#center Coord
- #radius Nat})
-
- (type: #export Polygon
- {#first Coord
- #second Coord
- #third Coord
- #extra (List Coord)})
-
- (def: (%rectangle [start end])
- (Format Rectangle)
- (format (%coord start) ..coord-separator (%coord end)))
-
- (def: (%circle [center radius])
- (Format Circle)
- (format (%coord center) ..metric-separator (%.nat radius)))
-
- (def: (%polygon [first second third extra])
- (Format Polygon)
- (|> (list& first second third extra)
- (list\map %coord)
- (text.join-with ..coord-separator)))
-
- (type: #export Shape
- (#Rectangle Rectangle)
- (#Circle Circle)
- (#Polygon Polygon))
-
- (template [<name> <shape> <type> <format>]
- [(def: (<name> attributes shape)
- (-> Attributes <type> (HTML Any))
- (..simple "area" (list& ["shape" <shape>]
- ["coords" (<format> shape)]
- attributes)))]
-
- [rectangle "rect" Rectangle ..%rectangle]
- [circle "circle" Circle ..%circle]
- [polygon "poly" Polygon ..%polygon]
- )
-
- (def: (area attributes shape)
- (-> Attributes Shape (HTML Any))
- (case shape
- (#Rectangle rectangle)
- (..rectangle attributes rectangle)
-
- (#Circle circle)
- (..circle attributes circle)
-
- (#Polygon polygon)
- (..polygon attributes polygon)))
-
- (def: #export (map attributes areas for)
- (-> Attributes (List [Attributes Shape]) Image Image)
- ($_ ..and
- for
- (case (list\map (product.uncurry ..area) areas)
- #.Nil
- (..empty "map" attributes)
-
- (#.Cons head tail)
- (..tag "map" attributes
- (list\fold (function.flip ..and) head tail)))))
-
- (template [<name> <tag> <type>]
- [(def: #export <name>
- (-> Attributes <type>)
- (..empty <tag>))]
-
- [canvas "canvas" Element]
- [progress "progress" Element]
- [output "output" Input]
- [source "source" Source]
- [track "track" Track]
- )
-
- (template [<name> <tag>]
- [(def: #export (<name> attributes media on-unsupported)
- (-> Attributes Media (Maybe Content) Element)
- (..tag <tag> attributes
- (|> on-unsupported
- (maybe.default (..text ""))
- (..and media))))]
-
- [audio "audio"]
- [video "video"]
- )
-
- (def: #export (picture attributes sources image)
- (-> Attributes Source Image Element)
- (..tag "picture" attributes (..and sources image)))
-
- (def: #export (anchor href attributes content)
- (-> URL Attributes Element Element)
- (..tag "a" (list& ["href" href] attributes) content))
-
- (def: #export label
- (-> ID Input)
- (|>> ["for"] list (..empty "label")))
-
- (template [<name> <container-tag> <description-tag> <type>]
- [(def: #export (<name> description attributes content)
- (-> (Maybe Content) Attributes <type> <type>)
- (..tag <container-tag> attributes
- (case description
- (#.Some description)
- ($_ ..and
- (..tag <description-tag> (list) description)
- content)
-
- #.None
- content)))]
-
- [details "details" "summary" Element]
- [field-set "fieldset" "legend" Input]
- [figure "figure" "figcaption" Element]
- )
-
- (template [<name> <tag> <type>]
- [(def: #export (<name> attributes content)
- (-> Attributes (Maybe Content) <type>)
- (|> content
- (maybe.default (..text ""))
- (..tag <tag> attributes)))]
-
- [text-area "textarea" Input]
- [iframe "iframe" Element]
- )
-
- (type: #export Phrase (-> Attributes Content Element))
-
- (template [<name> <tag>]
- [(def: #export <name>
- Phrase
- (..tag <tag>))]
-
- [abbrebiation "abbr"]
- [block-quote "blockquote"]
- [bold "b"]
- [cite "cite"]
- [code "code"]
- [definition "dfn"]
- [deleted "del"]
- [emphasized "em"]
- [h1 "h1"]
- [h2 "h2"]
- [h3 "h3"]
- [h4 "h4"]
- [h5 "h5"]
- [h6 "h6"]
- [inserted "ins"]
- [italic "i"]
- [keyboard "kbd"]
- [marked "mark"]
- [meter "meter"]
- [pre "pre"]
- [quote "q"]
- [sample "samp"]
- [struck "s"]
- [small "small"]
- [sub "sub"]
- [super "sup"]
- [strong "strong"]
- [time "time"]
- [underlined "u"]
- [variable "var"]
- )
-
- (def: #export incorrect ..struck)
-
- (def: (ruby-pronunciation pronunciation)
- (-> Content (HTML Any))
- (..tag "rt" (list)
- ($_ ..and
- (..tag "rp" (list) (..text "("))
- pronunciation
- (..tag "rp" (list) (..text ")")))))
-
- (def: #export (ruby attributes content pronunciation)
- (-> Attributes Content Content Element)
- (..tag "ruby" attributes
- ($_ ..and
- content
- (ruby-pronunciation pronunciation))))
-
- (type: #export Composite (-> Attributes Element Element))
-
- (template [<name> <tag>]
- [(def: #export <name>
- Composite
- (..tag <tag>))]
-
- [article "article"]
- [aside "aside"]
- [dialog "dialog"]
- [div "div"]
- [footer "footer"]
- [header "header"]
- [main "main"]
- [navigation "nav"]
- [paragraph "p"]
- [section "section"]
- [span "span"]
- )
-
- (template [<tag> <name> <input>]
- [(def: <name>
- (-> <input> (HTML Any))
- (..tag <tag> (list)))]
-
- ["dt" term Content]
- ["dd" description Element]
- )
-
- (def: #export (description-list attributes descriptions)
- (-> Attributes (List [Content Element]) Element)
- (case (list\map (function (_ [term description])
- ($_ ..and
- (..term term)
- (..description description)))
- descriptions)
- #.Nil
- (..empty "dl" attributes)
-
- (#.Cons head tail)
- (..tag "dl" attributes
- (list\fold (function.flip ..and) head tail))))
-
- (def: #export p ..paragraph)
-
- (template [<name> <tag> <input> <output>]
- [(def: #export <name>
- (-> Attributes <input> <output>)
- (..tag <tag>))]
-
- [button "button" Element Input]
- [item "li" Element Item]
- [ordered-list "ol" Item Element]
- [unordered-list "ul" Item Element]
- [option "option" Content Option]
- [option-group "optgroup" Option Option]
- [data-list "datalist" Option Element]
- [select "select" Option Input]
- [address "address" Element Element]
- [form "form" Input Element]
- [data "data" Element Element]
- [object "object" Parameter Element]
- )
-
- (template [<name> <tag> <input> <output>]
- [(def: #export <name>
- (-> <input> <output>)
- (..tag <tag> (list)))]
-
- [title "title" Content Meta]
- [no-script "noscript" Content Meta]
- [template "template" (HTML Any) (HTML Nothing)]
- [table-header "th" Element Header]
- [table-cell "td" Element Cell]
- [head "head" Meta Head]
- [body "body" Element Body]
- )
-
- (template [<name> <tag> <input> <output>]
- [(def: <name>
- (-> <input> <output>)
- (..tag <tag> (list)))]
-
- [table-row "tr" (HTML Any) Row]
- [table-head "thead" Row HTML]
- [table-body "tbody" Row HTML]
- [table-foot "tfoot" Row HTML]
- [columns-group "colgroup" Column HTML]
- )
-
- (def: #export (table attributes caption columns headers rows footer)
- (-> Attributes (Maybe Content) (Maybe Column) Header (List Cell) (Maybe Cell) Element)
- (let [head (..table-head (..table-row headers))
- content (case (list\map table-row rows)
- #.Nil
- head
-
- (#.Cons first rest)
- (..and head
- (..table-body
- (list\fold (function.flip ..and) first rest))))
- content (case footer
- #.None
- content
-
- (#.Some footer)
- (..and content
- (..table-foot (..table-row footer))))
- content (case columns
- #.None
- content
-
- (#.Some columns)
- (..and (..columns-group columns)
- content))
- content (case caption
- #.None
- content
-
- (#.Some caption)
- (..and (:as HTML caption)
- content))]
- (..tag "table" attributes
- content)))
-
- (template [<name> <doc-type>]
- [(def: #export <name>
- (-> Head Body Document)
- (let [doc-type <doc-type>]
- (function (_ head body)
- (|> (..tag "html" (list) (..and head body))
- :representation
- (format doc-type)
- :abstraction))))]
-
- [html-5 "<!DOCTYPE html>"]
- [html-4_01 (format "<!DOCTYPE HTML PUBLIC " text.double-quote "-//W3C//DTD HTML 4.01//EN" text.double-quote " " text.double-quote "http://www.w3.org/TR/html4/strict.dtd" text.double-quote ">")]
- [xhtml-1_0 (format "<!DOCTYPE html PUBLIC " text.double-quote "-//W3C//DTD XHTML 1.0 Strict//EN" text.double-quote " " text.double-quote "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd" text.double-quote ">")]
- [xhtml-1_1 (format "<!DOCTYPE html PUBLIC " text.double-quote "-//W3C//DTD XHTML 1.1//EN" text.double-quote " " text.double-quote "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd" text.double-quote ">")]
- )
- )
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
deleted file mode 100644
index a9986822f..000000000
--- a/stdlib/source/lux/data/format/json.lux
+++ /dev/null
@@ -1,421 +0,0 @@
-(.module: {#.doc (.doc "Functionality for reading and writing values in the JSON format."
- "For more information, please see: http://www.json.org/")}
- [lux #*
- ["." meta (#+ monad)]
- [abstract
- [equivalence (#+ Equivalence)]
- [codec (#+ Codec)]
- [predicate (#+ Predicate)]
- ["." monad (#+ do)]]
- [control
- pipe
- ["." try (#+ Try)]
- ["<>" parser ("#\." monad)
- ["<.>" text (#+ Parser)]]]
- [data
- ["." bit]
- ["." maybe]
- ["." product]
- ["." text ("#\." equivalence monoid)]
- [collection
- ["." list ("#\." fold functor)]
- ["." row (#+ Row row) ("#\." monad)]
- ["." dictionary (#+ Dictionary)]]]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number
- ["n" nat]
- ["f" frac ("#\." decimal)]]]])
-
-(template [<name> <type>]
- [(type: #export <name>
- <type>)]
-
- [Null Any]
- [Boolean Bit]
- [Number Frac]
- [String Text]
- )
-
-(type: #export #rec JSON
- (#Null Null)
- (#Boolean Boolean)
- (#Number Number)
- (#String String)
- (#Array (Row JSON))
- (#Object (Dictionary String JSON)))
-
-(template [<name> <type>]
- [(type: #export <name>
- <type>)]
-
- [Array (Row JSON)]
- [Object (Dictionary String JSON)]
- )
-
-(def: #export null?
- (Predicate JSON)
- (|>> (case> #Null true
- _ false)))
-
-(def: #export object
- (-> (List [String JSON]) JSON)
- (|>> (dictionary.from_list text.hash) #..Object))
-
-(syntax: #export (json token)
- {#.doc (doc "A simple way to produce JSON literals."
- (json #null)
- (json #1)
- (json +123.456)
- (json "this is a string")
- (json ["this" "is" "an" "array"])
- (json {"this" "is"
- "an" "object"}))}
- (let [(^open ".") ..monad
- wrapper (function (_ x) (` (..json (~ x))))]
- (case token
- (^template [<ast_tag> <ctor> <json_tag>]
- [[_ (<ast_tag> value)]
- (wrap (list (` (: JSON (<json_tag> (~ (<ctor> value)))))))])
- ([#.Bit code.bit #..Boolean]
- [#.Frac code.frac #..Number]
- [#.Text code.text #..String])
-
- [_ (#.Tag ["" "null"])]
- (wrap (list (` (: JSON #..Null))))
-
- [_ (#.Tuple members)]
- (wrap (list (` (: JSON (#..Array ((~! row) (~+ (list\map wrapper members))))))))
-
- [_ (#.Record pairs)]
- (do {! ..monad}
- [pairs' (monad.map !
- (function (_ [slot value])
- (case slot
- [_ (#.Text key_name)]
- (wrap (` [(~ (code.text key_name)) (~ (wrapper value))]))
-
- _
- (meta.fail "Wrong syntax for JSON object.")))
- pairs)]
- (wrap (list (` (: JSON (#..Object ((~! dictionary.from_list)
- (~! text.hash)
- (list (~+ pairs')))))))))
-
- _
- (wrap (list token)))))
-
-(def: #export (fields json)
- {#.doc "Get all the fields in a JSON object."}
- (-> JSON (Try (List String)))
- (case json
- (#Object obj)
- (#try.Success (dictionary.keys obj))
-
- _
- (#try.Failure ($_ text\compose "Cannot get the fields of a non-object."))))
-
-(def: #export (get key json)
- {#.doc "A JSON object field getter."}
- (-> String JSON (Try JSON))
- (case json
- (#Object obj)
- (case (dictionary.get key obj)
- (#.Some value)
- (#try.Success value)
-
- #.None
- (#try.Failure ($_ text\compose "Missing field '" key "' on object.")))
-
- _
- (#try.Failure ($_ text\compose "Cannot get field '" key "' on a non-object."))))
-
-(def: #export (set key value json)
- {#.doc "A JSON object field setter."}
- (-> String JSON JSON (Try JSON))
- (case json
- (#Object obj)
- (#try.Success (#Object (dictionary.put key value obj)))
-
- _
- (#try.Failure ($_ text\compose "Cannot set field '" key "' on a non-object."))))
-
-(template [<name> <tag> <type> <desc>]
- [(def: #export (<name> key json)
- {#.doc (code.text ($_ text\compose "A JSON object field getter for " <desc> "."))}
- (-> Text JSON (Try <type>))
- (case (get key json)
- (#try.Success (<tag> value))
- (#try.Success value)
-
- (#try.Success _)
- (#try.Failure ($_ text\compose "Wrong value type at key: " key))
-
- (#try.Failure error)
- (#try.Failure error)))]
-
- [get_boolean #Boolean Boolean "booleans"]
- [get_number #Number Number "numbers"]
- [get_string #String String "strings"]
- [get_array #Array Array "arrays"]
- [get_object #Object Object "objects"]
- )
-
-(implementation: #export equivalence
- (Equivalence JSON)
-
- (def: (= x y)
- (case [x y]
- [#Null #Null]
- #1
-
- (^template [<tag> <struct>]
- [[(<tag> x') (<tag> y')]
- (\ <struct> = x' y')])
- ([#Boolean bit.equivalence]
- [#Number f.equivalence]
- [#String text.equivalence])
-
- [(#Array xs) (#Array ys)]
- (and (n.= (row.size xs) (row.size ys))
- (list\fold (function (_ idx prev)
- (and prev
- (maybe.default #0
- (do maybe.monad
- [x' (row.nth idx xs)
- y' (row.nth idx ys)]
- (wrap (= x' y'))))))
- #1
- (list.indices (row.size xs))))
-
- [(#Object xs) (#Object ys)]
- (and (n.= (dictionary.size xs) (dictionary.size ys))
- (list\fold (function (_ [xk xv] prev)
- (and prev
- (case (dictionary.get xk ys)
- #.None #0
- (#.Some yv) (= xv yv))))
- #1
- (dictionary.entries xs)))
-
- _
- #0)))
-
-############################################################
-############################################################
-############################################################
-
-(def: (format_null _)
- (-> Null Text)
- "null")
-
-(def: format_boolean
- (-> Boolean Text)
- (|>> (case>
- #0 "false"
- #1 "true")))
-
-(def: format_number
- (-> Number Text)
- (|>> (case>
- (^or +0.0 -0.0) "0.0"
- value (let [raw (\ f.decimal encode value)]
- (if (f.< +0.0 value)
- raw
- (|> raw (text.split 1) maybe.assume product.right))))))
-
-(def: escape "\")
-(def: escaped_dq (text\compose ..escape text.double_quote))
-
-(def: format_string
- (-> String Text)
- (|>> (text.replace_all text.double_quote ..escaped_dq)
- (text.enclose [text.double_quote text.double_quote])))
-
-(template [<token> <name>]
- [(def: <name>
- Text
- <token>)]
-
- ["," separator]
- [":" entry_separator]
-
- ["[" open_array]
- ["]" close_array]
-
- ["{" open_object]
- ["}" close_object]
- )
-
-(def: (format_array format)
- (-> (-> JSON Text) (-> Array Text))
- (|>> (row\map format)
- row.to_list
- (text.join_with ..separator)
- (text.enclose [..open_array ..close_array])))
-
-(def: (format_kv format [key value])
- (-> (-> JSON Text) (-> [String JSON] Text))
- ($_ text\compose
- (..format_string key)
- ..entry_separator
- (format value)
- ))
-
-(def: (format_object format)
- (-> (-> JSON Text) (-> Object Text))
- (|>> dictionary.entries
- (list\map (..format_kv format))
- (text.join_with ..separator)
- (text.enclose [..open_object ..close_object])))
-
-(def: #export (format json)
- (-> JSON Text)
- (case json
- (^template [<tag> <format>]
- [(<tag> value)
- (<format> value)])
- ([#Null ..format_null]
- [#Boolean ..format_boolean]
- [#Number ..format_number]
- [#String ..format_string]
- [#Array (..format_array format)]
- [#Object (..format_object format)])
- ))
-
-############################################################
-############################################################
-############################################################
-
-(def: parse_space
- (Parser Text)
- (<text>.some <text>.space))
-
-(def: parse_separator
- (Parser [Text Any Text])
- ($_ <>.and
- ..parse_space
- (<text>.this ..separator)
- ..parse_space))
-
-(def: parse_null
- (Parser Null)
- (do <>.monad
- [_ (<text>.this "null")]
- (wrap [])))
-
-(template [<name> <token> <value>]
- [(def: <name>
- (Parser Boolean)
- (do <>.monad
- [_ (<text>.this <token>)]
- (wrap <value>)))]
-
- [parse_true "true" #1]
- [parse_false "false" #0]
- )
-
-(def: parse_boolean
- (Parser Boolean)
- ($_ <>.either
- ..parse_true
- ..parse_false))
-
-(def: parse_number
- (Parser Number)
- (do {! <>.monad}
- [signed? (<>.parses? (<text>.this "-"))
- digits (<text>.many <text>.decimal)
- decimals (<>.default "0"
- (do !
- [_ (<text>.this ".")]
- (<text>.many <text>.decimal)))
- exp (<>.default ""
- (do !
- [mark (<text>.one_of "eE")
- signed?' (<>.parses? (<text>.this "-"))
- offset (<text>.many <text>.decimal)]
- (wrap ($_ text\compose mark (if signed?' "-" "") offset))))]
- (case (f\decode ($_ text\compose (if signed? "-" "") digits "." decimals exp))
- (#try.Failure message)
- (<>.fail message)
-
- (#try.Success value)
- (wrap value))))
-
-(def: parse_escaped
- (Parser Text)
- ($_ <>.either
- (<>.after (<text>.this "\t")
- (<>\wrap text.tab))
- (<>.after (<text>.this "\b")
- (<>\wrap text.back_space))
- (<>.after (<text>.this "\n")
- (<>\wrap text.new_line))
- (<>.after (<text>.this "\r")
- (<>\wrap text.carriage_return))
- (<>.after (<text>.this "\f")
- (<>\wrap text.form_feed))
- (<>.after (<text>.this (text\compose "\" text.double_quote))
- (<>\wrap text.double_quote))
- (<>.after (<text>.this "\\")
- (<>\wrap "\"))))
-
-(def: parse_string
- (Parser String)
- (<| (<text>.enclosed [text.double_quote text.double_quote])
- (loop [_ []])
- (do {! <>.monad}
- [chars (<text>.some (<text>.none_of (text\compose "\" text.double_quote)))
- stop <text>.peek])
- (if (text\= "\" stop)
- (do !
- [escaped parse_escaped
- next_chars (recur [])]
- (wrap ($_ text\compose chars escaped next_chars)))
- (wrap chars))))
-
-(def: (parse_kv parse_json)
- (-> (Parser JSON) (Parser [String JSON]))
- (do <>.monad
- [key ..parse_string
- _ ..parse_space
- _ (<text>.this ..entry_separator)
- _ ..parse_space
- value parse_json]
- (wrap [key value])))
-
-(template [<name> <type> <open> <close> <elem_parser> <prep>]
- [(def: (<name> parse_json)
- (-> (Parser JSON) (Parser <type>))
- (do <>.monad
- [_ (<text>.this <open>)
- _ parse_space
- elems (<>.separated_by ..parse_separator <elem_parser>)
- _ parse_space
- _ (<text>.this <close>)]
- (wrap (<prep> elems))))]
-
- [parse_array Array ..open_array ..close_array parse_json row.from_list]
- [parse_object Object ..open_object ..close_object (parse_kv parse_json) (dictionary.from_list text.hash)]
- )
-
-(def: parse_json
- (Parser JSON)
- (<>.rec
- (function (_ parse_json)
- ($_ <>.or
- parse_null
- parse_boolean
- parse_number
- parse_string
- (parse_array parse_json)
- (parse_object parse_json)))))
-
-(implementation: #export codec
- (Codec Text JSON)
-
- (def: encode ..format)
- (def: decode (<text>.run parse_json)))
diff --git a/stdlib/source/lux/data/format/markdown.lux b/stdlib/source/lux/data/format/markdown.lux
deleted file mode 100644
index 5cdc68865..000000000
--- a/stdlib/source/lux/data/format/markdown.lux
+++ /dev/null
@@ -1,180 +0,0 @@
-(.module:
- [lux (#- and)
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]]]
- [type
- abstract]
- [world
- [net (#+ URL)]]])
-
-## https://www.markdownguide.org/basic-syntax/
-
-(def: sanitize
- (-> Text Text)
- (|>> (text.replace-all "\" "\\")
- (text.replace-all "`" "\`")
- (text.replace-all "*" "\*")
- (text.replace-all "_" "\_")
- (text.replace-all "{" "\{")
- (text.replace-all "}" "\}")
- (text.replace-all "[" "\[")
- (text.replace-all "]" "\]")
- (text.replace-all "(" "\(")
- (text.replace-all ")" "\)")
- (text.replace-all "#" "\#")
- (text.replace-all "+" "\+")
- (text.replace-all "-" "\-")
- (text.replace-all "." "\.")
- (text.replace-all "!" "\!")))
-
-(abstract: #export Span Any)
-(abstract: #export Block Any)
-
-(abstract: #export (Markdown brand)
- Text
-
- (def: #export empty
- Markdown
- (:abstraction ""))
-
- (def: #export text
- (-> Text (Markdown Span))
- (|>> ..sanitize :abstraction))
-
- (def: blank-line (format text.new-line text.new-line))
-
- (template [<name> <prefix>]
- [(def: #export (<name> content)
- (-> Text Markdown)
- (:abstraction (format <prefix> " " (..sanitize content) ..blank-line)))]
-
- [heading/1 "#"]
- [heading/2 "##"]
- [heading/3 "###"]
- [heading/4 "####"]
- [heading/5 "#####"]
- [heading/6 "######"]
- )
-
- (def: (block content)
- (-> Text (Markdown Block))
- (:abstraction (format content ..blank-line)))
-
- (def: #export paragraph
- (-> (Markdown Span) (Markdown Block))
- (|>> :representation ..block))
-
- (def: #export break
- (Markdown Span)
- (:abstraction (format " " text.new-line)))
-
- (template [<name> <wrapper>]
- [(def: #export <name>
- (-> (Markdown Span) (Markdown Span))
- (|>> :representation
- (text.enclose [<wrapper> <wrapper>])
- :abstraction))]
-
- [bold "**"]
- [italic "_"]
- )
-
- (def: (prefix with)
- (-> Text (-> Text Text))
- (|>> (text.split-all-with text.new-line)
- (list\map (function (_ line)
- (if (text.empty? line)
- line
- (format with line))))
- (text.join-with text.new-line)))
-
- (def: indent
- (-> Text Text)
- (..prefix text.tab))
-
- (def: #export quote
- (-> (Markdown Block) (Markdown Block))
- (|>> :representation
- (..prefix "> ")
- :abstraction))
-
- (def: #export numbered-list
- (-> (List [(Markdown Span) (Maybe (Markdown Block))])
- (Markdown Block))
- (|>> list.enumeration
- (list\map (function (_ [idx [summary detail]])
- (format (%.nat (inc idx)) ". " (:representation summary) text.new-line
- (case detail
- (#.Some detail)
- (|> detail :representation ..indent (text.enclose [text.new-line text.new-line]))
-
- #.None
- ""))))
- (text.join-with text.new-line)
- ..block))
-
- (def: #export bullet-list
- (-> (List [(Markdown Span) (Maybe (Markdown Block))])
- (Markdown Block))
- (|>> (list\map (function (_ [summary detail])
- (format "*. " (:representation summary) text.new-line
- (case detail
- (#.Some detail)
- (|> detail :representation ..indent (text.enclose [text.new-line text.new-line]))
-
- #.None
- ""))))
- (text.join-with text.new-line)
- ..block))
-
- (def: #export snippet
- {#.doc "A snippet of code."}
- (-> Text (Markdown Span))
- (|>> ..sanitize (text.enclose ["`" "`"]) :abstraction))
-
- (def: #export code
- {#.doc "A block of code."}
- (-> Text (Markdown Block))
- (let [open (format "```" text.new-line)
- close (format text.new-line "```")]
- (|>> (text.enclose [open close]) ..block)))
-
- (def: #export (image description url)
- (-> Text URL (Markdown Span))
- (:abstraction (format "![" (..sanitize description) "](" url ")")))
-
- (def: #export horizontal-rule
- (Markdown Block)
- (..block "___"))
-
- (def: #export (link description url)
- (-> (Markdown Span) URL (Markdown Span))
- (:abstraction (format "[" (:representation description) "](" url ")")))
-
- (type: #export Email Text)
-
- (template [<name> <type>]
- [(def: #export <name>
- (-> <type> (Markdown Span))
- (|>> (text.enclose ["<" ">"]) :abstraction))]
-
- [url URL]
- [email Email]
- )
-
- (template [<name> <brand> <infix>]
- [(def: #export (<name> pre post)
- (-> (Markdown <brand>) (Markdown <brand>) (Markdown <brand>))
- (:abstraction (format (:representation pre) <infix> (:representation post))))]
-
- [and Span " "]
- [then Block ""]
- )
-
- (def: #export markdown
- (-> (Markdown Any) Text)
- (|>> :representation))
- )
diff --git a/stdlib/source/lux/data/format/tar.lux b/stdlib/source/lux/data/format/tar.lux
deleted file mode 100644
index 504b7f5ac..000000000
--- a/stdlib/source/lux/data/format/tar.lux
+++ /dev/null
@@ -1,870 +0,0 @@
-(.module:
- [lux (#- Mode Name and)
- [abstract
- [monad (#+ do)]]
- [control
- [pipe (#+ case>)]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<b>" binary (#+ Parser)]]]
- [data
- ["." product]
- ["." binary (#+ Binary)]
- ["." text (#+ Char)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- ["." format #_
- ["#" binary (#+ Writer) ("#\." monoid)]]
- [collection
- ["." list ("#\." fold)]
- ["." row (#+ Row) ("#\." fold)]]]
- [math
- ["." number
- ["n" nat]
- ["." i64]]]
- [time
- ["." instant (#+ Instant)]
- ["." duration]]
- [world
- ["." file]]
- [type
- abstract]])
-
-(type: Size Nat)
-
-(def: octal_size Size 8)
-
-(def: (octal_padding max_size number)
- (-> Size Text Text)
- (let [padding_size (n.- (text.size number)
- max_size)
- padding (|> "0"
- (list.repeat padding_size)
- (text.join_with ""))]
- (format padding number)))
-
-(def: blank " ")
-(def: null text.null)
-
-(def: small_size Size 6)
-(def: big_size Size 11)
-
-(template [<exception> <limit> <size>
- <type> <in> <out> <writer> <suffix>
- <coercion>]
- [(def: #export <limit>
- Nat
- (|> ..octal_size
- (list.repeat <size>)
- (list\fold n.* 1)
- inc))
-
- (exception: #export (<exception> {value Nat})
- (exception.report
- ["Value" (%.nat value)]
- ["Maximum" (%.nat (dec <limit>))]))
-
- (abstract: #export <type>
- Nat
-
- (def: #export (<in> value)
- (-> Nat (Try <type>))
- (if (n.< <limit> value)
- (#try.Success (:abstraction value))
- (exception.throw <exception> [value])))
-
- (def: #export <out>
- (-> <type> Nat)
- (|>> :representation))
-
- (def: <writer>
- (Writer <type>)
- (let [suffix <suffix>
- padded_size (n.+ (text.size suffix) <size>)]
- (|>> :representation
- (\ n.octal encode)
- (..octal_padding <size>)
- (text.suffix suffix)
- (\ utf8.codec encode)
- (format.segment padded_size))))
-
- (def: <coercion>
- (-> Nat <type>)
- (|>> (n.% <limit>)
- :abstraction))
- )]
-
- [not_a_small_number small_limit ..small_size
- Small small from_small
- small_writer (format ..blank ..null)
- coerce_small]
- [not_a_big_number big_limit ..big_size
- Big big from_big
- big_writer ..blank
- coerce_big]
- )
-
-(exception: #export (wrong_character {expected Char} {actual Char})
- (exception.report
- ["Expected" (%.nat expected)]
- ["Actual" (%.nat actual)]))
-
-(def: verify_small_suffix
- (Parser Any)
- (do <>.monad
- [pre_end <b>.bits/8
- end <b>.bits/8
- _ (let [expected (`` (char (~~ (static ..blank))))]
- (<>.assert (exception.construct ..wrong_character [expected pre_end])
- (n.= expected pre_end)))
- _ (let [expected (`` (char (~~ (static ..null))))]
- (<>.assert (exception.construct ..wrong_character [expected end])
- (n.= expected end)))]
- (wrap [])))
-
-(def: small_parser
- (Parser Small)
- (do <>.monad
- [digits (<b>.segment ..small_size)
- digits (<>.lift (\ utf8.codec decode digits))
- _ ..verify_small_suffix]
- (<>.lift
- (do {! try.monad}
- [value (\ n.octal decode digits)]
- (..small value)))))
-
-(def: big_parser
- (Parser Big)
- (do <>.monad
- [digits (<b>.segment ..big_size)
- digits (<>.lift (\ utf8.codec decode digits))
- end <b>.bits/8
- _ (let [expected (`` (char (~~ (static ..blank))))]
- (<>.assert (exception.construct ..wrong_character [expected end])
- (n.= expected end)))]
- (<>.lift
- (do {! try.monad}
- [value (\ n.octal decode digits)]
- (..big value)))))
-
-(abstract: Checksum
- Text
-
- (def: from_checksum
- (-> Checksum Text)
- (|>> :representation))
-
- (def: dummy_checksum
- Checksum
- (:abstraction " "))
-
- (def: checksum_suffix
- (format ..blank ..null))
-
- (def: checksum
- (-> Binary Nat)
- (binary.fold n.+ 0))
-
- (def: checksum_checksum
- (|> ..dummy_checksum
- :representation
- (\ utf8.codec encode)
- ..checksum))
-
- (def: checksum_code
- (-> Binary Checksum)
- (|>> ..checksum
- ..coerce_small
- ..from_small
- (\ n.octal encode)
- (..octal_padding ..small_size)
- (text.suffix ..checksum_suffix)
- :abstraction))
-
- (def: checksum_writer
- (Writer Checksum)
- (let [padded_size (n.+ (text.size ..checksum_suffix)
- ..small_size)]
- (|>> :representation
- (\ utf8.codec encode)
- (format.segment padded_size))))
-
- (def: checksum_parser
- (Parser [Nat Checksum])
- (do <>.monad
- [ascii (<b>.segment ..small_size)
- digits (<>.lift (\ utf8.codec decode ascii))
- _ ..verify_small_suffix
- value (<>.lift
- (\ n.octal decode digits))]
- (wrap [value
- (:abstraction (format digits ..checksum_suffix))])))
- )
-
-(def: last_ascii
- Char
- (number.hex "007F"))
-
-(def: ascii?
- (-> Text Bit)
- (|>> (\ utf8.codec encode)
- (binary.fold (function (_ char verdict)
- (.and verdict
- (n.<= ..last_ascii char)))
- true)))
-
-(exception: #export (not_ascii {text Text})
- (exception.report
- ["Text" (%.text text)]))
-
-(def: #export name_size Size 31)
-(def: #export path_size Size 99)
-
-(def: (un_pad string)
- (-> Binary (Try Binary))
- (case (binary.size string)
- 0 (#try.Success string)
- size (loop [end (dec size)]
- (case end
- 0 (#try.Success (\ utf8.codec encode ""))
- _ (do try.monad
- [last_char (binary.read/8 end string)]
- (`` (case (.nat last_char)
- (^ (char (~~ (static ..null))))
- (recur (dec end))
-
- _
- (binary.slice 0 (inc end) string))))))))
-
-(template [<type> <representation> <size> <exception> <in> <out> <writer> <parser> <none>]
- [(abstract: #export <type>
- <representation>
-
- (exception: #export (<exception> {value Text})
- (exception.report
- ["Value" (%.text value)]
- ["Size" (%.nat (text.size value))]
- ["Maximum" (%.nat <size>)]))
-
- (def: #export (<in> value)
- (-> <representation> (Try <type>))
- (if (..ascii? value)
- (if (|> value (\ utf8.codec encode) binary.size (n.<= <size>))
- (#try.Success (:abstraction value))
- (exception.throw <exception> [value]))
- (exception.throw ..not_ascii [value])))
-
- (def: #export <out>
- (-> <type> <representation>)
- (|>> :representation))
-
- (def: <writer>
- (Writer <type>)
- (let [suffix ..null
- padded_size (n.+ (text.size suffix) <size>)]
- (|>> :representation
- (text.suffix suffix)
- (\ utf8.codec encode)
- (format.segment padded_size))))
-
- (def: <parser>
- (Parser <type>)
- (do <>.monad
- [string (<b>.segment <size>)
- end <b>.bits/8
- #let [expected (`` (char (~~ (static ..null))))]
- _ (<>.assert (exception.construct ..wrong_character [expected end])
- (n.= expected end))]
- (<>.lift
- (do {! try.monad}
- [ascii (..un_pad string)
- text (\ utf8.codec decode ascii)]
- (<in> text)))))
-
- (def: #export <none>
- <type>
- (try.assume (<in> "")))
- )]
-
- [Name Text ..name_size name_is_too_long name from_name name_writer name_parser anonymous]
- [Path file.Path ..path_size path_is_too_long path from_path path_writer path_parser no_path]
- )
-
-(def: magic_size Size 7)
-
-(abstract: Magic
- Text
-
- (def: ustar (:abstraction "ustar "))
-
- (def: from_magic
- (-> Magic Text)
- (|>> :representation))
-
- (def: magic_writer
- (Writer Magic)
- (let [padded_size (n.+ (text.size ..null)
- ..magic_size)]
- (|>> :representation
- (\ utf8.codec encode)
- (format.segment padded_size))))
-
- (def: magic_parser
- (Parser Magic)
- (do <>.monad
- [string (<b>.segment ..magic_size)
- end <b>.bits/8
- #let [expected (`` (char (~~ (static ..null))))]
- _ (<>.assert (exception.construct ..wrong_character [expected end])
- (n.= expected end))]
- (<>.lift
- (\ try.monad map (|>> :abstraction)
- (\ utf8.codec decode string)))))
- )
-
-(def: block_size Size 512)
-
-(def: owner_id_size ..small_size)
-
-(def: blank_size Size (text.size ..blank))
-(def: null_size Size (text.size ..null))
-(def: mode_size Size ..small_size)
-(def: content_size Size ..big_size)
-(def: modification_time_size Size ..big_size)
-(def: checksum_size Size ..small_size)
-(def: link_flag_size Size 1)
-(def: device_size Size ..small_size)
-
-(def: small_number
- (-> Size Size)
- (|>> ($_ n.+ ..blank_size ..null_size)))
-
-(def: big_number
- (-> Size Size)
- (|>> ($_ n.+ ..blank_size)))
-
-(def: string
- (-> Size Size)
- (|>> ($_ n.+ ..null_size)))
-
-(def: header_size
- ($_ n.+
- ## name
- (..string ..path_size)
- ## mode
- (..small_number ..mode_size)
- ## uid
- (..small_number ..owner_id_size)
- ## gid
- (..small_number ..owner_id_size)
- ## size
- (..big_number ..content_size)
- ## mtime
- (..big_number ..modification_time_size)
- ## chksum
- (..small_number ..checksum_size)
- ## linkflag
- ..link_flag_size
- ## linkname
- (..string ..path_size)
- ## magic
- (..string ..magic_size)
- ## uname
- (..string ..name_size)
- ## gname
- (..string ..name_size)
- ## devmajor
- (..small_number ..device_size)
- ## devminor
- (..small_number ..device_size)))
-
-(abstract: Link_Flag
- Char
-
- (def: link_flag
- (-> Link_Flag Char)
- (|>> :representation))
-
- (def: link_flag_writer
- (Writer Link_Flag)
- (|>> :representation
- format.bits/8))
-
- (with_expansions [<options> (as_is [0 old_normal]
- [(char "0") normal]
- [(char "1") link]
- [(char "2") symbolic_link]
- [(char "3") character]
- [(char "4") block]
- [(char "5") directory]
- [(char "6") fifo]
- [(char "7") contiguous])]
- (template [<flag> <name>]
- [(def: <name>
- Link_Flag
- (:abstraction <flag>))]
-
- <options>
- )
-
- (exception: #export (invalid_link_flag {value Nat})
- (exception.report
- ["Value" (%.nat value)]))
-
- (def: link_flag_parser
- (Parser Link_Flag)
- (do <>.monad
- [linkflag <b>.bits/8]
- (case (.nat linkflag)
- (^template [<value> <link_flag>]
- [(^ <value>)
- (wrap <link_flag>)])
- (<options>)
-
- _
- (<>.lift
- (exception.throw ..invalid_link_flag [(.nat linkflag)]))))))
- )
-
-(abstract: #export Mode
- Nat
-
- (def: #export mode
- (-> Mode Nat)
- (|>> :representation))
-
- (def: #export (and left right)
- (-> Mode Mode Mode)
- (:abstraction
- (i64.or (:representation left)
- (:representation right))))
-
- (def: mode_writer
- (Writer Mode)
- (|>> :representation
- ..small
- try.assume
- ..small_writer))
-
- (exception: #export (invalid_mode {value Nat})
- (exception.report
- ["Value" (%.nat value)]))
-
- (with_expansions [<options> (as_is ["0000" none]
-
- ["0001" execute_by_other]
- ["0002" write_by_other]
- ["0004" read_by_other]
-
- ["0010" execute_by_group]
- ["0020" write_by_group]
- ["0040" read_by_group]
-
- ["0100" execute_by_owner]
- ["0200" write_by_owner]
- ["0400" read_by_owner]
-
- ["1000" save_text]
- ["2000" set_group_id_on_execution]
- ["4000" set_user_id_on_execution])]
- (template [<code> <name>]
- [(def: #export <name>
- Mode
- (:abstraction (number.oct <code>)))]
-
- <options>
- )
-
- (def: maximum_mode
- Mode
- ($_ and
- ..none
-
- ..execute_by_other
- ..write_by_other
- ..read_by_other
-
- ..execute_by_group
- ..write_by_group
- ..read_by_group
-
- ..execute_by_owner
- ..write_by_owner
- ..read_by_owner
-
- ..save_text
- ..set_group_id_on_execution
- ..set_user_id_on_execution
- ))
-
- (def: mode_parser
- (Parser Mode)
- (do {! <>.monad}
- [value (\ ! map ..from_small ..small_parser)]
- (if (n.<= (:representation ..maximum_mode)
- value)
- (wrap (:abstraction value))
- (<>.lift
- (exception.throw ..invalid_mode [value]))))))
- )
-
-(def: maximum_content_size
- Nat
- (|> ..octal_size
- (list.repeat ..content_size)
- (list\fold n.* 1)))
-
-(abstract: #export Content
- [Big Binary]
-
- (def: #export (content content)
- (-> Binary (Try Content))
- (do try.monad
- [size (..big (binary.size content))]
- (wrap (:abstraction [size content]))))
-
- (def: from_content
- (-> Content [Big Binary])
- (|>> :representation))
-
- (def: #export data
- (-> Content Binary)
- (|>> :representation product.right))
- )
-
-(type: #export ID
- Small)
-
-(def: #export no_id
- ID
- (..coerce_small 0))
-
-(type: #export Owner
- {#name Name
- #id ID})
-
-(type: #export Ownership
- {#user Owner
- #group Owner})
-
-(type: #export File
- [Path Instant Mode Ownership Content])
-
-(type: #export Normal File)
-(type: #export Symbolic_Link Path)
-(type: #export Directory Path)
-(type: #export Contiguous File)
-
-(type: #export Entry
- (#Normal ..Normal)
- (#Symbolic_Link ..Symbolic_Link)
- (#Directory ..Directory)
- (#Contiguous ..Contiguous))
-
-(type: Device
- Small)
-
-(def: no_device
- Device
- (try.assume (..small 0)))
-
-(type: #export Tar
- (Row Entry))
-
-(def: (blocks size)
- (-> Big Nat)
- (n.+ (n./ ..block_size
- (..from_big size))
- (case (n.% ..block_size (..from_big size))
- 0 0
- _ 1)))
-
-(def: rounded_content_size
- (-> Big Nat)
- (|>> ..blocks
- (n.* ..block_size)))
-
-(type: Header
- {#path Path
- #mode Mode
- #user_id ID
- #group_id ID
- #size Big
- #modification_time Big
- #checksum Checksum
- #link_flag Link_Flag
- #link_name Path
- #magic Magic
- #user_name Name
- #group_name Name
- #major_device Device
- #minor_device Device})
-
-(def: header_writer'
- (Writer Header)
- ($_ format.and
- ..path_writer
- ..mode_writer
- ..small_writer
- ..small_writer
- ..big_writer
- ..big_writer
- ..checksum_writer
- ..link_flag_writer
- ..path_writer
- ..magic_writer
- ..name_writer
- ..name_writer
- ..small_writer
- ..small_writer
- ))
-
-(def: (header_writer header)
- (Writer Header)
- (let [checksum (|> header
- (set@ #checksum ..dummy_checksum)
- (format.run ..header_writer')
- ..checksum_code)]
- (|> header
- (set@ #checksum checksum)
- (format.run ..header_writer')
- (format.segment ..block_size))))
-
-(def: modification_time
- (-> Instant Big)
- (|>> instant.relative
- (duration.query duration.second)
- .nat
- ..coerce_big))
-
-(def: (file_writer link_flag)
- (-> Link_Flag (Writer File))
- (function (_ [path modification_time mode ownership content])
- (let [[size content] (..from_content content)
- writer ($_ format.and
- ..header_writer
- (format.segment (..rounded_content_size size)))]
- (writer [{#path path
- #mode mode
- #user_id (get@ [#user #id] ownership)
- #group_id (get@ [#group #id] ownership)
- #size size
- #modification_time (..modification_time modification_time)
- #checksum ..dummy_checksum
- #link_flag link_flag
- #link_name ..no_path
- #magic ..ustar
- #user_name (get@ [#user #name] ownership)
- #group_name (get@ [#group #name] ownership)
- #major_device ..no_device
- #minor_device ..no_device}
- content]))))
-
-(def: normal_file_writer
- (Writer File)
- (..file_writer ..normal))
-
-(def: contiguous_file_writer
- (Writer File)
- (..file_writer ..contiguous))
-
-(def: (symbolic_link_writer path)
- (Writer Path)
- (..header_writer
- {#path ..no_path
- #mode ..none
- #user_id ..no_id
- #group_id ..no_id
- #size (..coerce_big 0)
- #modification_time (..coerce_big 0)
- #checksum ..dummy_checksum
- #link_flag ..symbolic_link
- #link_name path
- #magic ..ustar
- #user_name ..anonymous
- #group_name ..anonymous
- #major_device ..no_device
- #minor_device ..no_device}))
-
-(def: (directory_writer path)
- (Writer Path)
- (..header_writer
- {#path path
- #mode ..none
- #user_id ..no_id
- #group_id ..no_id
- #size (..coerce_big 0)
- #modification_time (..coerce_big 0)
- #checksum ..dummy_checksum
- #link_flag ..directory
- #link_name ..no_path
- #magic ..ustar
- #user_name ..anonymous
- #group_name ..anonymous
- #major_device ..no_device
- #minor_device ..no_device}))
-
-(def: entry_writer
- (Writer Entry)
- (|>> (case> (#Normal value) (..normal_file_writer value)
- (#Symbolic_Link value) (..symbolic_link_writer value)
- (#Directory value) (..directory_writer value)
- (#Contiguous value) (..contiguous_file_writer value))))
-
-(def: end_of_archive_size Size (n.* 2 ..block_size))
-
-(def: #export writer
- (Writer Tar)
- (let [end_of_archive (binary.create ..end_of_archive_size)]
- (function (_ tar)
- (format\compose (row\fold (function (_ next total)
- (format\compose total (..entry_writer next)))
- format\identity
- tar)
- (format.segment ..end_of_archive_size end_of_archive)))))
-
-(exception: #export (wrong_checksum {expected Nat} {actual Nat})
- (exception.report
- ["Expected" (%.nat expected)]
- ["Actual" (%.nat actual)]))
-
-(def: header_padding_size
- (n.- header_size block_size))
-
-## When the checksum gets originally calculated, the assumption is that all the characters in the checksum field
-## of the header will be spaces.
-## This means that just calculating the checksum of the 512 bytes of the header, when reading them, would yield
-## an incorrect result, as the contents of the checksum field would be an actual checksum, instead of just spaces.
-## To correct for this, it is necessary to calculate the checksum of just the checksum field, subtract that, and then
-## add-in the checksum of the spaces.
-(def: (expected_checksum checksum header)
- (-> Checksum Binary Nat)
- (let [|checksum| (|> checksum
- ..from_checksum
- (\ utf8.codec encode)
- ..checksum)]
- (|> (..checksum header)
- (n.- |checksum|)
- (n.+ ..checksum_checksum))))
-
-(def: header_parser
- (Parser Header)
- (do <>.monad
- [binary_header (<>.speculative (<b>.segment block_size))
- path ..path_parser
- mode ..mode_parser
- user_id ..small_parser
- group_id ..small_parser
- size ..big_parser
- modification_time ..big_parser
- [actual checksum_code] ..checksum_parser
- _ (let [expected (expected_checksum checksum_code binary_header)]
- (<>.lift
- (exception.assert ..wrong_checksum [expected actual]
- (n.= expected actual))))
- link_flag ..link_flag_parser
- link_name ..path_parser
- magic ..magic_parser
- user_name ..name_parser
- group_name ..name_parser
- major_device ..small_parser
- minor_device ..small_parser
- _ (<b>.segment ..header_padding_size)]
- (wrap {#path path
- #mode mode
- #user_id user_id
- #group_id group_id
- #size size
- #modification_time modification_time
- #checksum checksum_code
- #link_flag link_flag
- #link_name link_name
- #magic magic
- #user_name user_name
- #group_name group_name
- #major_device major_device
- #minor_device minor_device})))
-
-(exception: #export (wrong_link_flag {expected Link_Flag} {actual Link_Flag})
- (exception.report
- ["Expected" (%.nat (..link_flag expected))]
- ["Actual" (%.nat (..link_flag actual))]))
-
-(def: (file_parser expected)
- (-> Link_Flag (Parser File))
- (do <>.monad
- [header ..header_parser
- _ (<>.assert (exception.construct ..wrong_link_flag [expected (get@ #link_flag header)])
- (is? expected (get@ #link_flag header)))
- #let [size (get@ #size header)
- rounded_size (..rounded_content_size size)]
- content (<b>.segment (..from_big size))
- content (<>.lift (..content content))
- _ (<b>.segment (n.- (..from_big size) rounded_size))]
- (wrap [(get@ #path header)
- (|> header
- (get@ #modification_time)
- ..from_big
- .int
- duration.from_millis
- (duration.up (|> duration.second duration.to_millis .nat))
- instant.absolute)
- (get@ #mode header)
- {#user {#name (get@ #user_name header)
- #id (get@ #user_id header)}
- #group {#name (get@ #group_name header)
- #id (get@ #group_id header)}}
- content])))
-
-(def: (file_name_parser expected extractor)
- (-> Link_Flag (-> Header Path) (Parser Path))
- (do <>.monad
- [header ..header_parser
- _ (<>.lift
- (exception.assert ..wrong_link_flag [expected (get@ #link_flag header)]
- (n.= (..link_flag expected)
- (..link_flag (get@ #link_flag header)))))]
- (wrap (extractor header))))
-
-(def: entry_parser
- (Parser Entry)
- ($_ <>.either
- (\ <>.monad map (|>> #..Normal)
- (<>.either (..file_parser ..normal)
- (..file_parser ..old_normal)))
- (\ <>.monad map (|>> #..Symbolic_Link)
- (..file_name_parser ..symbolic_link (get@ #link_name)))
- (\ <>.monad map (|>> #..Directory)
- (..file_name_parser ..directory (get@ #path)))
- (\ <>.monad map (|>> #..Contiguous)
- (..file_parser ..contiguous))))
-
-## It's safe to implement the parser this way because the range of values for Nat is 2^64
-## Whereas the maximum possible value for the checksum of a 512 block is (256 × 512) = 131,072
-(def: end_of_archive_block_parser
- (Parser Any)
- (do <>.monad
- [block (<b>.segment ..block_size)]
- (let [actual (..checksum block)]
- (<>.lift
- (exception.assert ..wrong_checksum [0 actual]
- (n.= 0 actual))))))
-
-(exception: #export invalid_end_of_archive)
-
-(def: end_of_archive_parser
- (Parser Any)
- (do <>.monad
- [_ (<>.at_most 2 end_of_archive_block_parser)
- done? <b>.end?]
- (<>.lift
- (exception.assert ..invalid_end_of_archive []
- done?))))
-
-(def: #export parser
- (Parser Tar)
- (|> (<>.some entry_parser)
- (\ <>.monad map row.from_list)
- (<>.before ..end_of_archive_parser)))
diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux
deleted file mode 100644
index 4097d1171..000000000
--- a/stdlib/source/lux/data/format/xml.lux
+++ /dev/null
@@ -1,298 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]
- [equivalence (#+ Equivalence)]
- [codec (#+ Codec)]]
- [control
- [try (#+ Try)]
- ["<>" parser ("#\." monad)
- ["<.>" text (#+ Parser)]]]
- [data
- ["." product]
- ["." name ("#\." equivalence codec)]
- ["." text ("#\." equivalence monoid)]
- [collection
- ["." list ("#\." functor)]
- ["." dictionary (#+ Dictionary)]]]
- [math
- [number
- ["n" nat]
- ["." int]]]])
-
-(type: #export Tag
- Name)
-
-(type: #export Attribute
- Name)
-
-(type: #export Attrs
- (Dictionary Attribute Text))
-
-(def: #export attributes
- Attrs
- (dictionary.new name.hash))
-
-(type: #export #rec XML
- (#Text Text)
- (#Node Tag Attrs (List XML)))
-
-(def: namespace_separator
- ":")
-
-(def: xml_standard_escape_char^
- (Parser Text)
- ($_ <>.either
- (<>.after (<text>.this "&lt;") (<>\wrap "<"))
- (<>.after (<text>.this "&gt;") (<>\wrap ">"))
- (<>.after (<text>.this "&amp;") (<>\wrap "&"))
- (<>.after (<text>.this "&apos;") (<>\wrap "'"))
- (<>.after (<text>.this "&quot;") (<>\wrap text.double_quote))
- ))
-
-(def: xml_unicode_escape_char^
- (Parser Text)
- (|> (do <>.monad
- [hex? (<>.maybe (<text>.this "x"))
- code (case hex?
- #.None
- (<>.codec int.decimal (<text>.many <text>.decimal))
-
- (#.Some _)
- (<>.codec int.decimal (<text>.many <text>.hexadecimal)))]
- (wrap (|> code .nat text.from_code)))
- (<>.before (<text>.this ";"))
- (<>.after (<text>.this "&#"))))
-
-(def: xml_escape_char^
- (Parser Text)
- (<>.either xml_standard_escape_char^
- xml_unicode_escape_char^))
-
-(def: xml_char^
- (Parser Text)
- (<>.either (<text>.none_of ($_ text\compose "<>&" text.double_quote))
- xml_escape_char^))
-
-(def: xml_identifier
- (Parser Text)
- (do <>.monad
- [head (<>.either (<text>.one_of "_")
- <text>.alpha)
- tail (<text>.some (<>.either (<text>.one_of "_.-")
- <text>.alpha_num))]
- (wrap ($_ text\compose head tail))))
-
-(def: namespaced_symbol^
- (Parser Name)
- (do <>.monad
- [first_part xml_identifier
- ?second_part (<| <>.maybe (<>.after (<text>.this ..namespace_separator)) xml_identifier)]
- (case ?second_part
- #.None
- (wrap ["" first_part])
-
- (#.Some second_part)
- (wrap [first_part second_part]))))
-
-(def: tag^ namespaced_symbol^)
-(def: attr_name^ namespaced_symbol^)
-
-(def: spaced^
- (All [a] (-> (Parser a) (Parser a)))
- (let [white_space^ (<>.some <text>.space)]
- (|>> (<>.before white_space^)
- (<>.after white_space^))))
-
-(def: attr_value^
- (Parser Text)
- (let [value^ (<text>.some xml_char^)]
- (<>.either (<text>.enclosed [text.double_quote text.double_quote] value^)
- (<text>.enclosed ["'" "'"] value^))))
-
-(def: attrs^
- (Parser Attrs)
- (<| (\ <>.monad map (dictionary.from_list name.hash))
- <>.some
- (<>.and (..spaced^ attr_name^))
- (<>.after (<text>.this "="))
- (..spaced^ attr_value^)))
-
-(def: (close_tag^ expected)
- (-> Tag (Parser []))
- (do <>.monad
- [actual (|> tag^
- ..spaced^
- (<>.after (<text>.this "/"))
- (<text>.enclosed ["<" ">"]))]
- (<>.assert ($_ text\compose "Close tag does not match open tag." text.new_line
- "Expected: " (name\encode expected) text.new_line
- " Actual: " (name\encode actual) text.new_line)
- (name\= expected actual))))
-
-(def: comment^
- (Parser Text)
- (|> (<text>.not (<text>.this "--"))
- <text>.some
- (<text>.enclosed ["<!--" "-->"])
- ..spaced^))
-
-(def: xml_header^
- (Parser Attrs)
- (|> (..spaced^ attrs^)
- (<>.before (<text>.this "?>"))
- (<>.after (<text>.this "<?xml"))
- ..spaced^))
-
-(def: cdata^
- (Parser Text)
- (let [end (<text>.this "]]>")]
- (|> (<text>.some (<text>.not end))
- (<>.after end)
- (<>.after (<text>.this "<![CDATA["))
- ..spaced^)))
-
-(def: text^
- (Parser XML)
- (|> (..spaced^ (<text>.many xml_char^))
- (<>.either cdata^)
- (<>\map (|>> #Text))))
-
-(def: null^
- (Parser Any)
- (<text>.this (text.from_code 0)))
-
-(def: xml^
- (Parser XML)
- (|> (<>.rec
- (function (_ node^)
- (|> (do <>.monad
- [_ (<text>.this "<")
- tag (..spaced^ tag^)
- attrs (..spaced^ attrs^)
- #let [no_children^ ($_ <>.either
- (do <>.monad
- [_ (<text>.this "/>")]
- (wrap (#Node tag attrs (list))))
- (do <>.monad
- [_ (<text>.this ">")
- _ (<>.some (<>.either <text>.space
- ..comment^))
- _ (..close_tag^ tag)]
- (wrap (#Node tag attrs (list)))))
- with_children^ (do <>.monad
- [_ (<text>.this ">")
- children (<>.many node^)
- _ (..close_tag^ tag)]
- (wrap (#Node tag attrs children)))]]
- ($_ <>.either
- no_children^
- with_children^))
- ..spaced^
- (<>.before (<>.some ..comment^))
- (<>.after (<>.some ..comment^))
- (<>.either ..text^))))
- (<>.before (<>.some ..null^))
- (<>.after (<>.maybe ..xml_header^))))
-
-(def: read
- (-> Text (Try XML))
- (<text>.run xml^))
-
-(def: (sanitize_value input)
- (-> Text Text)
- (|> input
- (text.replace_all "&" "&amp;")
- (text.replace_all "<" "&lt;")
- (text.replace_all ">" "&gt;")
- (text.replace_all "'" "&apos;")
- (text.replace_all text.double_quote "&quot;")))
-
-(def: #export (tag [namespace name])
- (-> Tag Text)
- (case namespace
- "" name
- _ ($_ text\compose namespace ..namespace_separator name)))
-
-(def: #export attribute
- (-> Attribute Text)
- ..tag)
-
-(def: (write_attrs attrs)
- (-> Attrs Text)
- (|> attrs
- dictionary.entries
- (list\map (function (_ [key value])
- ($_ text\compose (..attribute key) "=" text.double_quote (sanitize_value value) text.double_quote)))
- (text.join_with " ")))
-
-(def: xml_header
- Text
- (let [quote (: (-> Text Text)
- (function (_ value)
- ($_ text\compose text.double_quote value text.double_quote)))]
- ($_ text\compose
- "<?xml"
- " version=" (quote "1.0")
- " encoding=" (quote "UTF-8")
- "?>")))
-
-(def: (write input)
- (-> XML Text)
- ($_ text\compose
- ..xml_header text.new_line
- (loop [prefix ""
- input input]
- (case input
- (#Text value)
- (sanitize_value value)
-
- (^ (#Node xml_tag xml_attrs (list (#Text value))))
- (let [tag (..tag xml_tag)
- attrs (if (dictionary.empty? xml_attrs)
- ""
- ($_ text\compose " " (..write_attrs xml_attrs)))]
- ($_ text\compose
- prefix "<" tag attrs ">"
- (sanitize_value value)
- "</" tag ">"))
-
- (#Node xml_tag xml_attrs xml_children)
- (let [tag (..tag xml_tag)
- attrs (if (dictionary.empty? xml_attrs)
- ""
- ($_ text\compose " " (..write_attrs xml_attrs)))]
- (if (list.empty? xml_children)
- ($_ text\compose prefix "<" tag attrs "/>")
- ($_ text\compose prefix "<" tag attrs ">"
- (|> xml_children
- (list\map (|>> (recur (text\compose prefix text.tab)) (text\compose text.new_line)))
- (text.join_with ""))
- text.new_line prefix "</" tag ">")))))
- ))
-
-(implementation: #export codec
- (Codec Text XML)
-
- (def: encode ..write)
- (def: decode ..read))
-
-(implementation: #export equivalence
- (Equivalence XML)
-
- (def: (= reference sample)
- (case [reference sample]
- [(#Text reference/value) (#Text sample/value)]
- (text\= reference/value sample/value)
-
- [(#Node reference/tag reference/attrs reference/children)
- (#Node sample/tag sample/attrs sample/children)]
- (and (name\= reference/tag sample/tag)
- (\ (dictionary.equivalence text.equivalence) = reference/attrs sample/attrs)
- (n.= (list.size reference/children)
- (list.size sample/children))
- (|> (list.zip/2 reference/children sample/children)
- (list.every? (product.uncurry =))))
-
- _
- false)))
diff --git a/stdlib/source/lux/data/identity.lux b/stdlib/source/lux/data/identity.lux
deleted file mode 100644
index 35b44ec62..000000000
--- a/stdlib/source/lux/data/identity.lux
+++ /dev/null
@@ -1,37 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- [monad (#+ Monad)]
- [comonad (#+ CoMonad)]]
- [control
- ["." function]]])
-
-(type: #export (Identity a)
- a)
-
-(implementation: #export functor
- (Functor Identity)
-
- (def: map function.identity))
-
-(implementation: #export apply
- (Apply Identity)
-
- (def: &functor ..functor)
- (def: (apply ff fa) (ff fa)))
-
-(implementation: #export monad
- (Monad Identity)
-
- (def: &functor ..functor)
- (def: wrap function.identity)
- (def: join function.identity))
-
-(implementation: #export comonad
- (CoMonad Identity)
-
- (def: &functor ..functor)
- (def: unwrap function.identity)
- (def: split function.identity))
diff --git a/stdlib/source/lux/data/lazy.lux b/stdlib/source/lux/data/lazy.lux
deleted file mode 100644
index adc8458e6..000000000
--- a/stdlib/source/lux/data/lazy.lux
+++ /dev/null
@@ -1,67 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- [monad (#+ Monad do)]
- [equivalence (#+ Equivalence)]]
- [control
- ["." io]
- [parser
- ["s" code]]
- [concurrency
- ["." atom]]]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]]
- [type
- abstract]])
-
-(abstract: #export (Lazy a)
- (-> [] a)
-
- (def: (freeze' generator)
- (All [a] (-> (-> [] a) (Lazy a)))
- (let [cache (atom.atom #.None)]
- (:abstraction (function (_ _)
- (case (io.run (atom.read cache))
- (#.Some value)
- value
-
- _
- (let [value (generator [])]
- (exec (io.run (atom.compare_and_swap _ (#.Some value) cache))
- value)))))))
-
- (def: #export (thaw l_value)
- (All [a] (-> (Lazy a) a))
- ((:representation l_value) [])))
-
-(syntax: #export (freeze expr)
- (with_gensyms [g!_]
- (wrap (list (` ((~! freeze') (function ((~ g!_) (~ g!_)) (~ expr))))))))
-
-(implementation: #export (equivalence (^open "_\."))
- (All [a] (-> (Equivalence a) (Equivalence (Lazy a))))
-
- (def: (= left right)
- (_\= (..thaw left) (..thaw right))))
-
-(implementation: #export functor
- (Functor Lazy)
-
- (def: (map f fa)
- (freeze (f (thaw fa)))))
-
-(implementation: #export apply
- (Apply Lazy)
-
- (def: &functor ..functor)
- (def: (apply ff fa)
- (freeze ((thaw ff) (thaw fa)))))
-
-(implementation: #export monad
- (Monad Lazy)
-
- (def: &functor ..functor)
- (def: wrap (|>> freeze))
- (def: join thaw))
diff --git a/stdlib/source/lux/data/maybe.lux b/stdlib/source/lux/data/maybe.lux
deleted file mode 100644
index 6376cfebf..000000000
--- a/stdlib/source/lux/data/maybe.lux
+++ /dev/null
@@ -1,150 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monoid (#+ Monoid)]
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]
- [apply (#+ Apply)]
- ["." functor (#+ Functor)]
- ["." monad (#+ Monad do)]]
- [meta
- ["." location]]])
-
-## (type: (Maybe a)
-## #.None
-## (#.Some a))
-
-(implementation: #export monoid
- (All [a] (Monoid (Maybe a)))
-
- (def: identity #.None)
-
- (def: (compose mx my)
- (case mx
- #.None
- my
-
- (#.Some x)
- (#.Some x))))
-
-(implementation: #export functor
- (Functor Maybe)
-
- (def: (map f ma)
- (case ma
- #.None #.None
- (#.Some a) (#.Some (f a)))))
-
-(implementation: #export apply
- (Apply Maybe)
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (case [ff fa]
- [(#.Some f) (#.Some a)]
- (#.Some (f a))
-
- _
- #.None)))
-
-(implementation: #export monad
- (Monad Maybe)
-
- (def: &functor ..functor)
-
- (def: (wrap x)
- (#.Some x))
-
- (def: (join mma)
- (case mma
- #.None
- #.None
-
- (#.Some mx)
- mx)))
-
-(implementation: #export (equivalence super)
- (All [a] (-> (Equivalence a) (Equivalence (Maybe a))))
-
- (def: (= mx my)
- (case [mx my]
- [#.None #.None]
- #1
-
- [(#.Some x) (#.Some y)]
- (\ super = x y)
-
- _
- #0)))
-
-(implementation: #export (hash super)
- (All [a] (-> (Hash a) (Hash (Maybe a))))
-
- (def: &equivalence
- (..equivalence (\ super &equivalence)))
-
- (def: (hash value)
- (case value
- #.None
- 0
-
- (#.Some value)
- (\ super hash value))))
-
-(implementation: #export (with monad)
- (All [M] (-> (Monad M) (Monad (All [a] (M (Maybe a))))))
-
- (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor))
-
- (def: wrap (|>> (\ ..monad wrap) (\ monad wrap)))
-
- (def: (join MmMma)
- (do monad
- [mMma MmMma]
- (case mMma
- #.None
- (wrap #.None)
-
- (#.Some Mma)
- Mma))))
-
-(def: #export (lift monad)
- (All [M a] (-> (Monad M) (-> (M a) (M (Maybe a)))))
- (\ monad map (\ ..monad wrap)))
-
-(macro: #export (default tokens state)
- {#.doc (doc "Allows you to provide a default value that will be used"
- "if a (Maybe x) value turns out to be #.None."
- "Note: the expression for the default value will not be computed if the base computation succeeds."
- (default +20 (#.Some +10))
- "=>"
- +10
- (default +20 #.None)
- "=>"
- +20)}
- (case tokens
- (^ (list else maybe))
- (let [g!temp (: Code [location.dummy (#.Identifier ["" ""])])]
- (#.Right [state (list (` (case (~ maybe)
- (#.Some (~ g!temp))
- (~ g!temp)
-
- #.None
- (~ else))))]))
-
- _
- (#.Left "Wrong syntax for default")))
-
-(def: #export assume
- (All [a] (-> (Maybe a) a))
- (|>> (..default (undefined))))
-
-(def: #export (to-list value)
- (All [a] (-> (Maybe a) (List a)))
- (case value
- #.None
- #.Nil
-
- (#.Some value)
- (#.Cons value #.Nil)))
diff --git a/stdlib/source/lux/data/name.lux b/stdlib/source/lux/data/name.lux
deleted file mode 100644
index 539b9a99f..000000000
--- a/stdlib/source/lux/data/name.lux
+++ /dev/null
@@ -1,63 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]
- [order (#+ Order)]
- [codec (#+ Codec)]]
- [data
- ["." text ("#\." equivalence monoid)]
- ["." product]]])
-
-## (type: Name
-## [Text Text])
-
-(template [<name> <side>]
- [(def: #export (<name> [module short])
- (-> Name Text)
- <side>)]
-
- [module module]
- [short short]
- )
-
-(def: #export hash
- (Hash Name)
- (product.hash text.hash text.hash))
-
-(def: #export equivalence
- (Equivalence Name)
- (\ ..hash &equivalence))
-
-(implementation: #export order
- (Order Name)
-
- (def: &equivalence ..equivalence)
- (def: (< [moduleP shortP] [moduleS shortS])
- (if (text\= moduleP moduleS)
- (\ text.order < shortP shortS)
- (\ text.order < moduleP moduleS))))
-
-(def: separator
- ".")
-
-(implementation: #export codec
- (Codec Text Name)
-
- (def: (encode [module short])
- (case module
- "" short
- _ ($_ text\compose module ..separator short)))
-
- (def: (decode input)
- (if (text\= "" input)
- (#.Left (text\compose "Invalid format for Name: " input))
- (case (text.split_all_with ..separator input)
- (^ (list short))
- (#.Right ["" short])
-
- (^ (list module short))
- (#.Right [module short])
-
- _
- (#.Left (text\compose "Invalid format for Name: " input))))))
diff --git a/stdlib/source/lux/data/product.lux b/stdlib/source/lux/data/product.lux
deleted file mode 100644
index 9a8c37fb2..000000000
--- a/stdlib/source/lux/data/product.lux
+++ /dev/null
@@ -1,68 +0,0 @@
-(.module:
- {#.doc "Functionality for working with tuples (particularly 2-tuples)."}
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]]])
-
-(template [<name> <type> <output>]
- [(def: #export (<name> xy)
- (All [a b] (-> (& a b) <type>))
- (let [[x y] xy]
- <output>))]
-
- [left a x]
- [right b y]
- )
-
-(def: #export (curry f)
- (All [a b c]
- (-> (-> (& a b) c)
- (-> a b c)))
- (function (_ x y)
- (f [x y])))
-
-(def: #export (uncurry f)
- (All [a b c]
- (-> (-> a b c)
- (-> (& a b) c)))
- (function (_ 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]))
-
-(def: #export (apply f g)
- (All [a b c d]
- (-> (-> a c) (-> b d)
- (-> (& a b) (& c d))))
- (function (_ [x y])
- [(f x) (g y)]))
-
-(def: #export (fork f g)
- (All [a l r]
- (-> (-> a l) (-> a r)
- (-> a (& l r))))
- (function (_ x)
- [(f x) (g x)]))
-
-(implementation: #export (equivalence left right)
- (All [l r] (-> (Equivalence l) (Equivalence r) (Equivalence [l r])))
-
- (def: (= [rl rr] [sl sr])
- (and (\ left = rl sl)
- (\ right = rr sr))))
-
-(def: #export (hash left right)
- (All [l r] (-> (Hash l) (Hash r) (Hash (& l r))))
- (implementation
- (def: &equivalence
- (..equivalence (\ left &equivalence)
- (\ right &equivalence)))
- (def: (hash [leftV rightV])
- ("lux i64 +"
- (\ left hash leftV)
- (\ right hash rightV)))))
diff --git a/stdlib/source/lux/data/store.lux b/stdlib/source/lux/data/store.lux
deleted file mode 100644
index 52842eac9..000000000
--- a/stdlib/source/lux/data/store.lux
+++ /dev/null
@@ -1,49 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [functor (#+ Functor)]
- comonad]
- [type
- implicit]])
-
-(type: #export (Store s a)
- {#cursor s
- #peek (-> s a)})
-
-(def: (extend f wa)
- (All [s a b] (-> (-> (Store s a) b) (Store s a) (Store s b)))
- {#cursor (get@ #cursor wa)
- #peek (function (_ s) (f (set@ #cursor s wa)))})
-
-(implementation: #export functor
- (All [s] (Functor (Store s)))
-
- (def: (map f fa)
- (extend (function (_ store)
- (f (\ store peek (\ store cursor))))
- fa)))
-
-(implementation: #export comonad
- (All [s] (CoMonad (Store s)))
-
- (def: &functor ..functor)
-
- (def: (unwrap wa) (\\ peek (\\ cursor)))
-
- (def: split (extend id)))
-
-(def: #export (peeks trans store)
- (All [s a] (-> (-> s s) (Store s a) a))
- (|> (\\ cursor) trans (\\ peek)))
-
-(def: #export (seek cursor store)
- (All [s a] (-> s (Store s a) (Store s a)))
- (\ (\\ split store) peek cursor))
-
-(def: #export (seeks change store)
- (All [s a] (-> (-> s s) (Store s a) (Store s a)))
- (|> store (\\ split) (peeks change)))
-
-(def: #export (experiment Functor<f> change store)
- (All [f s a] (-> (Functor f) (-> s (f s)) (Store s a) (f a)))
- (\ Functor<f> map (\\ peek) (change (\\ cursor))))
diff --git a/stdlib/source/lux/data/sum.lux b/stdlib/source/lux/data/sum.lux
deleted file mode 100644
index bb0e6d0e7..000000000
--- a/stdlib/source/lux/data/sum.lux
+++ /dev/null
@@ -1,89 +0,0 @@
-(.module:
- {#.doc "Functionality for working with variants (particularly 2-variants)."}
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]]])
-
-(template [<name> <type> <right?>]
- [(def: #export (<name> value)
- (All [a b] (-> <type> (| a b)))
- (0 <right?> value))]
-
- [left a #0]
- [right b #1])
-
-(def: #export (either fl fr)
- (All [a b c]
- (-> (-> a c) (-> b c)
- (-> (| a b) c)))
- (function (_ input)
- (case input
- (0 #0 l) (fl l)
- (0 #1 r) (fr r))))
-
-(def: #export (apply fl fr)
- (All [l l' r r']
- (-> (-> l l') (-> r r')
- (-> (| l r) (| l' r'))))
- (function (_ input)
- (case input
- (0 #0 l) (0 #0 (fl l))
- (0 #1 r) (0 #1 (fr r)))))
-
-(template [<name> <side> <right?>]
- [(def: #export (<name> es)
- (All [a b] (-> (List (| a b)) (List <side>)))
- (case es
- #.Nil
- #.Nil
-
- (#.Cons (0 <right?> x) es')
- (#.Cons [x (<name> es')])
-
- (#.Cons _ es')
- (<name> 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 #0 x') [(#.Cons x' lefts) rights]
- (0 #1 x') [lefts (#.Cons x' rights)]))))
-
-(def: #export (equivalence left right)
- (All [l r] (-> (Equivalence l) (Equivalence r) (Equivalence (| l r))))
- (implementation
- (def: (= reference sample)
- (case [reference sample]
- [(#.Left reference) (#.Left sample)]
- (\ left = reference sample)
-
- [(#.Right reference) (#.Right sample)]
- (\ right = reference sample)
-
- _
- false))))
-
-(def: #export (hash left right)
- (All [l r] (-> (Hash l) (Hash r) (Hash (| l r))))
- (implementation
- (def: &equivalence
- (..equivalence (\ left &equivalence)
- (\ right &equivalence)))
- (def: (hash value)
- (case value
- (#.Left value)
- (\ left hash value)
-
- (#.Right value)
- (\ right hash value)))))
diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux
deleted file mode 100644
index 1c54218f9..000000000
--- a/stdlib/source/lux/data/text.lux
+++ /dev/null
@@ -1,379 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- [abstract
- [hash (#+ Hash)]
- [monoid (#+ Monoid)]
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]
- [monad (#+ Monad do)]
- [codec (#+ Codec)]]
- [data
- ["." maybe]
- [collection
- ["." list ("#\." fold)]]]
- [math
- [number
- ["n" nat]
- ["." i64]]]])
-
-(type: #export Char
- Nat)
-
-## TODO: Instead of ints, chars should be produced fron nats.
-## (The JVM specifies chars as 16-bit unsigned integers)
-(def: #export from_code
- (-> Char Text)
- (|>> .int "lux i64 char"))
-
-(template [<code> <short> <long>]
- [(def: #export <long> (from_code <code>))
- (def: #export <short> <long>)]
-
- [00 \0 null]
- [07 \a alarm]
- [08 \b back_space]
- [09 \t tab]
- [10 \n new_line]
- [11 \v vertical_tab]
- [12 \f form_feed]
- [13 \r carriage_return]
- [34 \'' double_quote]
- )
-
-(def: #export line_feed ..new_line)
-
-(def: #export size
- (-> Text Nat)
- (|>> "lux text size"))
-
-(def: #export (nth idx input)
- (-> Nat Text (Maybe Char))
- (if (n.< ("lux text size" input) idx)
- (#.Some ("lux text char" idx input))
- #.None))
-
-(def: #export (index_of' pattern from input)
- (-> Text Nat Text (Maybe Nat))
- ("lux text index" from pattern input))
-
-(def: #export (index_of pattern input)
- (-> Text Text (Maybe Nat))
- ("lux text index" 0 pattern input))
-
-(def: (last_index_of'' part since text)
- (-> Text Nat Text (Maybe Nat))
- (case ("lux text index" (inc since) part text)
- #.None
- (#.Some since)
-
- (#.Some since')
- (last_index_of'' part since' text)))
-
-(def: #export (last_index_of' part from text)
- (-> Text Nat Text (Maybe Nat))
- (case ("lux text index" from part text)
- (#.Some since)
- (last_index_of'' part since text)
-
- #.None
- #.None))
-
-(def: #export (last_index_of part text)
- (-> Text Text (Maybe Nat))
- (case ("lux text index" 0 part text)
- (#.Some since)
- (last_index_of'' part since text)
-
- #.None
- #.None))
-
-(def: #export (starts_with? prefix x)
- (-> Text Text Bit)
- (case (index_of prefix x)
- (#.Some 0)
- true
-
- _
- false))
-
-(def: #export (ends_with? postfix x)
- (-> Text Text Bit)
- (case (last_index_of postfix x)
- (#.Some n)
- (n.= (size x)
- (n.+ (size postfix) n))
-
- _
- false))
-
-(def: #export (encloses? boundary value)
- (-> Text Text Bit)
- (and (starts_with? boundary value)
- (ends_with? boundary value)))
-
-(def: #export (contains? sub text)
- (-> Text Text Bit)
- (case ("lux text index" 0 sub text)
- (#.Some _)
- true
-
- _
- false))
-
-(def: #export (prefix param subject)
- (-> Text Text Text)
- ("lux text concat" param subject))
-
-(def: #export (suffix param subject)
- (-> Text Text Text)
- ("lux text concat" subject param))
-
-(def: #export (enclose [left right] content)
- {#.doc "Surrounds the given content text with left and right side additions."}
- (-> [Text Text] Text Text)
- ($_ "lux text concat" left content right))
-
-(def: #export (enclose' boundary content)
- {#.doc "Surrounds the given content text with the same boundary text."}
- (-> Text Text Text)
- (enclose [boundary boundary] content))
-
-(def: #export format
- (-> Text Text)
- (..enclose' ..double_quote))
-
-(def: #export (clip offset characters input)
- (-> Nat Nat Text (Maybe Text))
- (if (|> characters (n.+ offset) (n.<= ("lux text size" input)))
- (#.Some ("lux text clip" offset characters input))
- #.None))
-
-(def: #export (clip' offset input)
- (-> Nat Text (Maybe Text))
- (let [size ("lux text size" input)]
- (if (n.<= size offset)
- (#.Some ("lux text clip" offset (n.- offset size) input))
- #.None)))
-
-(def: #export (split at x)
- (-> Nat Text (Maybe [Text Text]))
- (case [(..clip 0 at x) (..clip' at x)]
- [(#.Some pre) (#.Some post)]
- (#.Some [pre post])
-
- _
- #.None))
-
-(def: #export (split_with token sample)
- (-> Text Text (Maybe [Text Text]))
- (do maybe.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))
- (loop [input sample
- output (: (List Text) (list))]
- (case (..split_with token input)
- (#.Some [pre post])
- (|> output
- (#.Cons pre)
- (recur post))
-
- #.None
- (|> output
- (#.Cons input)
- list.reverse))))
-
-(def: #export (replace_once pattern replacement template)
- (-> Text Text Text Text)
- (<| (maybe.default template)
- (do maybe.monad
- [[pre post] (..split_with pattern template)]
- (wrap ($_ "lux text concat" pre replacement post)))))
-
-(def: #export (replace_all pattern replacement template)
- (-> Text Text Text Text)
- (for {@.old
- (:as Text
- ("jvm invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"
- (:as (primitive "java.lang.String") template)
- (:as (primitive "java.lang.CharSequence") pattern)
- (:as (primitive "java.lang.CharSequence") replacement)))
- @.jvm
- (:as Text
- ("jvm member invoke virtual" [] "java.lang.String" "replace" []
- (:as (primitive "java.lang.String") template)
- ["Ljava/lang/CharSequence;" (:as (primitive "java.lang.CharSequence") pattern)]
- ["Ljava/lang/CharSequence;" (:as (primitive "java.lang.CharSequence") replacement)]))
- ## TODO: Comment/turn-off when generating a JS compiler using a JVM-based compiler because Nashorn's implementation of "replaceAll" is incorrect.
- @.js
- (:as Text
- ("js object do" "replaceAll" template [pattern replacement]))
- @.python
- (:as Text
- ("python object do" "replace" template pattern replacement))
- ## TODO @.lua
- @.ruby
- (:as Text
- ("ruby object do" "gsub" template pattern replacement))
- @.php
- (:as Text
- ("php apply" (:assume ("php constant" "str_replace"))
- pattern replacement template))
- ## TODO @.scheme
- ## TODO @.common_lisp
- ## TODO @.r
- }
- ## Inefficient default
- (loop [left ""
- right template]
- (case (..split_with pattern right)
- (#.Some [pre post])
- (recur ($_ "lux text concat" left pre replacement) post)
-
- #.None
- ("lux text concat" left right)))))
-
-(implementation: #export equivalence
- (Equivalence Text)
-
- (def: (= reference sample)
- ("lux text =" reference sample)))
-
-(implementation: #export order
- (Order Text)
-
- (def: &equivalence ..equivalence)
-
- (def: (< reference sample)
- ("lux text <" reference sample)))
-
-(implementation: #export monoid
- (Monoid Text)
-
- (def: identity "")
-
- (def: (compose left right)
- ("lux text concat" left right)))
-
-(implementation: #export hash
- (Hash Text)
-
- (def: &equivalence ..equivalence)
-
- (def: (hash input)
- (for {@.old
- (|> input
- (: (primitive "java.lang.String"))
- "jvm invokevirtual:java.lang.String:hashCode:"
- "jvm convert int-to-long"
- (:as Nat))
-
- @.jvm
- (|> input
- (:as (primitive "java.lang.String"))
- ("jvm member invoke virtual" [] "java.lang.String" "hashCode" [])
- "jvm conversion int-to-long"
- "jvm object cast"
- (: (primitive "java.lang.Long"))
- (:as Nat))}
- ## Platform-independent default.
- (let [length ("lux text size" input)]
- (loop [idx 0
- hash 0]
- (if (n.< length idx)
- (recur (inc idx)
- (|> hash
- (i64.left_shift 5)
- (n.- hash)
- (n.+ ("lux text char" idx input))))
- hash))))))
-
-(def: #export concat
- (-> (List Text) Text)
- (let [(^open ".") ..monoid]
- (|>> list.reverse (list\fold compose identity))))
-
-(def: #export (join_with sep texts)
- (-> Text (List Text) Text)
- (|> texts (list.interpose sep) concat))
-
-(def: #export (empty? text)
- (-> Text Bit)
- (case text
- "" true
- _ false))
-
-(def: #export space
- Text
- " ")
-
-(def: #export (space? char)
- {#.doc "Checks whether the character is white-space."}
- (-> Char Bit)
- (with_expansions [<options> (template [<char>]
- [(^ (char (~~ (static <char>))))]
-
- [..tab]
- [..vertical_tab]
- [..space]
- [..new_line]
- [..carriage_return]
- [..form_feed]
- )]
- (`` (case char
- (^or <options>)
- true
-
- _
- false))))
-
-(def: #export (lower_case value)
- (-> Text Text)
- (for {@.old
- (:as Text
- ("jvm invokevirtual:java.lang.String:toLowerCase:"
- (:as (primitive "java.lang.String") value)))
- @.jvm
- (:as Text
- ("jvm member invoke virtual" [] "java.lang.String" "toLowerCase" []
- (:as (primitive "java.lang.String") value)))
- @.js
- (:as Text
- ("js object do" "toLowerCase" value []))
- @.python
- (:as Text
- ("python object do" "lower" value))
- @.lua
- (:as Text
- ("lua apply" ("lua constant" "string.lower") value))
- @.ruby
- (:as Text
- ("ruby object do" "downcase" value))}))
-
-(def: #export (upper_case value)
- (-> Text Text)
- (for {@.old
- (:as Text
- ("jvm invokevirtual:java.lang.String:toUpperCase:"
- (:as (primitive "java.lang.String") value)))
- @.jvm
- (:as Text
- ("jvm member invoke virtual" [] "java.lang.String" "toUpperCase" []
- (:as (primitive "java.lang.String") value)))
- @.js
- (:as Text
- ("js object do" "toUpperCase" value []))
- @.python
- (:as Text
- ("python object do" "upper" value))
- @.lua
- (:as Text
- ("lua apply" ("lua constant" "string.upper") value))
- @.ruby
- (:as Text
- ("ruby object do" "upcase" value))}))
diff --git a/stdlib/source/lux/data/text/buffer.lux b/stdlib/source/lux/data/text/buffer.lux
deleted file mode 100644
index d07b10567..000000000
--- a/stdlib/source/lux/data/text/buffer.lux
+++ /dev/null
@@ -1,114 +0,0 @@
-(.module:
- [lux #*
- [ffi (#+ import:)]
- ["@" target]
- [control
- ["." function]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." array]
- ["." row (#+ Row) ("#\." fold)]]]
- [math
- [number
- ["n" nat]]]
- [type
- abstract]]
- ["." //])
-
-(with_expansions [<jvm> (as_is (import: java/lang/CharSequence)
-
- (import: java/lang/Appendable
- ["#::."
- (append [java/lang/CharSequence] java/lang/Appendable)])
-
- (import: java/lang/String
- ["#::."
- (new [int])
- (toString [] java/lang/String)])
-
- (import: java/lang/StringBuilder
- ["#::."
- (new [int])
- (toString [] java/lang/String)]))]
- (`` (for {@.old (as_is <jvm>)
- @.jvm (as_is <jvm>)
- @.lua (as_is (import: (table/concat [(array.Array Text) Text] Text))
- ##https://www.lua.org/manual/5.3/manual.html#pdf-table.concat
- (import: (table/insert [(array.Array Text) Text] #? Nothing))
- ## https://www.lua.org/manual/5.3/manual.html#pdf-table.insert
- )}
- (as_is))))
-
-(`` (abstract: #export Buffer
- (for {@.old [Nat (-> java/lang/StringBuilder java/lang/StringBuilder)]
- @.jvm [Nat (-> java/lang/StringBuilder java/lang/StringBuilder)]
- @.lua [Nat (-> (array.Array Text) (array.Array Text))]}
- ## default
- (Row Text))
-
- {#.doc "Immutable text buffer for efficient text concatenation."}
-
- (def: #export empty
- Buffer
- (:abstraction (with_expansions [<jvm> [0 function.identity]]
- (for {@.old <jvm>
- @.jvm <jvm>
- @.lua [0 function.identity]}
- ## default
- row.empty))))
-
- (def: #export (append chunk buffer)
- (-> Text Buffer Buffer)
- (with_expansions [<jvm> (let [[capacity transform] (:representation buffer)
- append! (: (-> Text java/lang/StringBuilder java/lang/StringBuilder)
- (function (_ chunk builder)
- (exec
- (java/lang/Appendable::append (:as java/lang/CharSequence chunk)
- builder)
- builder)))]
- (:abstraction [(n.+ (//.size chunk) capacity)
- (|>> transform (append! chunk))]))]
- (for {@.old <jvm>
- @.jvm <jvm>
- @.lua (let [[capacity transform] (:representation buffer)
- append! (: (-> Text (array.Array Text) (array.Array Text))
- (function (_ chunk array)
- (exec
- (table/insert [array chunk])
- array)))]
- (:abstraction [(n.+ (//.size chunk) capacity)
- (|>> transform (append! chunk))]))}
- ## default
- (|> buffer :representation (row.add chunk) :abstraction))))
-
- (def: #export size
- (-> Buffer Nat)
- (with_expansions [<jvm> (|>> :representation product.left)]
- (for {@.old <jvm>
- @.jvm <jvm>
- @.lua <jvm>}
- ## default
- (|>> :representation
- (row\fold (function (_ chunk total)
- (n.+ (//.size chunk) total))
- 0)))))
-
- (def: #export (text buffer)
- (-> Buffer Text)
- (with_expansions [<jvm> (let [[capacity transform] (:representation buffer)]
- (|> (java/lang/StringBuilder::new (.int capacity))
- transform
- java/lang/StringBuilder::toString))]
- (for {@.old <jvm>
- @.jvm <jvm>
- @.lua (let [[capacity transform] (:representation buffer)]
- (table/concat [(transform (array.new 0)) ""]))}
- ## default
- (row\fold (function (_ chunk total)
- (format total chunk))
- ""
- (:representation buffer)))))
- ))
diff --git a/stdlib/source/lux/data/text/encoding.lux b/stdlib/source/lux/data/text/encoding.lux
deleted file mode 100644
index 92f68dfe0..000000000
--- a/stdlib/source/lux/data/text/encoding.lux
+++ /dev/null
@@ -1,162 +0,0 @@
-(.module:
- [lux #*
- [type
- abstract]])
-
-## https://docs.oracle.com/javase/8/docs/technotes/guides/intl/encoding.doc.html
-
-(abstract: #export Encoding
- Text
-
- (template [<name> <encoding>]
- [(def: #export <name> Encoding (:abstraction <encoding>))]
-
- [ascii "ASCII"]
-
- [ibm_37 "IBM037"]
- [ibm_273 "IBM273"]
- [ibm_277 "IBM277"]
- [ibm_278 "IBM278"]
- [ibm_280 "IBM280"]
- [ibm_284 "IBM284"]
- [ibm_285 "IBM285"]
- [ibm_290 "IBM290"]
- [ibm_297 "IBM297"]
- [ibm_300 "IBM300"]
- [ibm_420 "IBM420"]
- [ibm_424 "IBM424"]
- [ibm_437 "IBM437"]
- [ibm_500 "IBM500"]
- [ibm_737 "IBM737"]
- [ibm_775 "IBM775"]
- [ibm_833 "IBM833"]
- [ibm_834 "IBM834"]
- [ibm_838 "IBM-Thai"]
- [ibm_850 "IBM850"]
- [ibm_852 "IBM852"]
- [ibm_855 "IBM855"]
- [ibm_856 "IBM856"]
- [ibm_857 "IBM857"]
- [ibm_858 "IBM00858"]
- [ibm_860 "IBM860"]
- [ibm_861 "IBM861"]
- [ibm_862 "IBM862"]
- [ibm_863 "IBM863"]
- [ibm_864 "IBM864"]
- [ibm_865 "IBM865"]
- [ibm_866 "IBM866"]
- [ibm_868 "IBM868"]
- [ibm_869 "IBM869"]
- [ibm_870 "IBM870"]
- [ibm_871 "IBM871"]
- [ibm_874 "IBM874"]
- [ibm_875 "IBM875"]
- [ibm_918 "IBM918"]
- [ibm_921 "IBM921"]
- [ibm_922 "IBM922"]
- [ibm_930 "IBM930"]
- [ibm_933 "IBM933"]
- [ibm_935 "IBM935"]
- [ibm_937 "IBM937"]
- [ibm_939 "IBM939"]
- [ibm_942 "IBM942"]
- [ibm_942c "IBM942C"]
- [ibm_943 "IBM943"]
- [ibm_943c "IBM943C"]
- [ibm_948 "IBM948"]
- [ibm_949 "IBM949"]
- [ibm_949c "IBM949C"]
- [ibm_950 "IBM950"]
- [ibm_964 "IBM964"]
- [ibm_970 "IBM970"]
- [ibm_1006 "IBM1006"]
- [ibm_1025 "IBM1025"]
- [ibm_1026 "IBM1026"]
- [ibm_1046 "IBM1046"]
- [ibm_1047 "IBM1047"]
- [ibm_1097 "IBM1097"]
- [ibm_1098 "IBM1098"]
- [ibm_1112 "IBM1112"]
- [ibm_1122 "IBM1122"]
- [ibm_1123 "IBM1123"]
- [ibm_1124 "IBM1124"]
- [ibm_1140 "IBM01140"]
- [ibm_1141 "IBM01141"]
- [ibm_1142 "IBM01142"]
- [ibm_1143 "IBM01143"]
- [ibm_1144 "IBM01144"]
- [ibm_1145 "IBM01145"]
- [ibm_1146 "IBM01146"]
- [ibm_1147 "IBM01147"]
- [ibm_1148 "IBM01148"]
- [ibm_1149 "IBM01149"]
- [ibm_1166 "IBM1166"]
- [ibm_1364 "IBM1364"]
- [ibm_1381 "IBM1381"]
- [ibm_1383 "IBM1383"]
- [ibm_33722 "IBM33722"]
-
- [iso_2022_cn "ISO-2022-CN"]
- [iso2022_cn_cns "ISO2022-CN-CNS"]
- [iso2022_cn_gb "ISO2022-CN-GB"]
- [iso_2022_jp "ISO-2022-JP"]
- [iso_2022_jp_2 "ISO-2022-JP-2"]
- [iso_2022_kr "ISO-2022-KR"]
- [iso_8859_1 "ISO-8859-1"]
- [iso_8859_2 "ISO-8859-2"]
- [iso_8859_3 "ISO-8859-3"]
- [iso_8859_4 "ISO-8859-4"]
- [iso_8859_5 "ISO-8859-5"]
- [iso_8859_6 "ISO-8859-6"]
- [iso_8859_7 "ISO-8859-7"]
- [iso_8859_8 "ISO-8859-8"]
- [iso_8859_9 "ISO-8859-9"]
- [iso_8859_11 "iso-8859-11"]
- [iso_8859_13 "ISO-8859-13"]
- [iso_8859_15 "ISO-8859-15"]
-
- [mac_arabic "MacArabic"]
- [mac_central_europe "MacCentralEurope"]
- [mac_croatian "MacCroatian"]
- [mac_cyrillic "MacCyrillic"]
- [mac_dingbat "MacDingbat"]
- [mac_greek "MacGreek"]
- [mac_hebrew "MacHebrew"]
- [mac_iceland "MacIceland"]
- [mac_roman "MacRoman"]
- [mac_romania "MacRomania"]
- [mac_symbol "MacSymbol"]
- [mac_thai "MacThai"]
- [mac_turkish "MacTurkish"]
- [mac_ukraine "MacUkraine"]
-
- [utf_8 "UTF-8"]
- [utf_16 "UTF-16"]
- [utf_32 "UTF-32"]
-
- [windows_31j "windows-31j"]
- [windows_874 "windows-874"]
- [windows_949 "windows-949"]
- [windows_950 "windows-950"]
- [windows_1250 "windows-1250"]
- [windows_1252 "windows-1252"]
- [windows_1251 "windows-1251"]
- [windows_1253 "windows-1253"]
- [windows_1254 "windows-1254"]
- [windows_1255 "windows-1255"]
- [windows_1256 "windows-1256"]
- [windows_1257 "windows-1257"]
- [windows_1258 "windows-1258"]
- [windows_iso2022jp "windows-iso2022jp"]
- [windows_50220 "windows-50220"]
- [windows_50221 "windows-50221"]
-
- [cesu_8 "CESU-8"]
- [koi8_r "KOI8-R"]
- [koi8_u "KOI8-U"]
- )
-
- (def: #export name
- (-> Encoding Text)
- (|>> :representation))
- )
diff --git a/stdlib/source/lux/data/text/encoding/utf8.lux b/stdlib/source/lux/data/text/encoding/utf8.lux
deleted file mode 100644
index 7b9e75524..000000000
--- a/stdlib/source/lux/data/text/encoding/utf8.lux
+++ /dev/null
@@ -1,163 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- ["." ffi]
- [abstract
- [codec (#+ Codec)]]
- [control
- ["." try (#+ Try)]]
- [data
- ["." binary (#+ Binary)]]]
- ["." //])
-
-(with_expansions [<jvm> (as_is (ffi.import: java/lang/String
- ["#::."
- (new [[byte] java/lang/String])
- (getBytes [java/lang/String] [byte])]))]
- (for {@.old (as_is <jvm>)
- @.jvm (as_is <jvm>)
-
- @.js
- (as_is (ffi.import: Uint8Array)
-
- ## On Node
- (ffi.import: Buffer
- ["#::."
- (#static from #as from|encode [ffi.String ffi.String] Buffer)
- (#static from #as from|decode [Uint8Array] Buffer)
- (toString [ffi.String] ffi.String)])
-
- ## On the browser
- (ffi.import: TextEncoder
- ["#::."
- (new [ffi.String])
- (encode [ffi.String] Uint8Array)])
-
- (ffi.import: TextDecoder
- ["#::."
- (new [ffi.String])
- (decode [Uint8Array] ffi.String)]))
-
- @.ruby
- (as_is (ffi.import: String #as RubyString
- ["#::."
- (encode [Text] RubyString)
- (force_encoding [Text] Text)
- (bytes [] Binary)])
-
- (ffi.import: Array #as RubyArray
- ["#::."
- (pack [Text] RubyString)]))
-
- @.php
- (as_is (ffi.import: Almost_Binary)
- (ffi.import: (unpack [ffi.String ffi.String] Almost_Binary))
- (ffi.import: (array_values [Almost_Binary] Binary))
- (def: php_byte_array_format "C*"))
-
- @.scheme
- ## https://srfi.schemers.org/srfi-140/srfi-140.html
- (as_is (ffi.import: (string->utf8 [Text] Binary))
- (ffi.import: (utf8->string [Binary] Text)))}
- (as_is)))
-
-(def: (encode value)
- (-> Text Binary)
- (for {@.old
- (java/lang/String::getBytes (//.name //.utf_8)
- ## TODO: Remove coercion below.
- ## The coercion below may seem
- ## gratuitous, but removing it
- ## causes a grave compilation problem.
- (:as java/lang/String value))
-
- @.jvm
- (java/lang/String::getBytes (//.name //.utf_8) value)
-
- @.js
- (cond ffi.on_nashorn?
- (:as Binary ("js object do" "getBytes" value ["utf8"]))
-
- ffi.on_node_js?
- (|> (Buffer::from|encode [value "utf8"])
- ## This coercion is valid as per NodeJS's documentation:
- ## https://nodejs.org/api/buffer.html#buffer_buffers_and_typedarrays
- (:as Uint8Array))
-
- ## On the browser
- (|> (TextEncoder::new [(//.name //.utf_8)])
- (TextEncoder::encode [value]))
- )
-
- @.python
- (:as Binary ("python apply" (:assume ("python constant" "bytearray")) value "utf-8"))
-
- @.lua
- ("lua utf8 encode" value)
-
- @.ruby
- (|> value
- (:as RubyString)
- (RubyString::encode ["UTF-8"])
- (RubyString::bytes []))
-
- @.php
- (|> (..unpack [..php_byte_array_format value])
- ..array_values
- ("php object new" "ArrayObject")
- (:as Binary))
-
- @.scheme
- (..string->utf8 value)}))
-
-(def: (decode value)
- (-> Binary (Try Text))
- (with_expansions [<jvm> (#try.Success (java/lang/String::new value (//.name //.utf_8)))]
- (for {@.old <jvm>
- @.jvm <jvm>
-
- @.js
- (cond ffi.on_nashorn?
- (|> ("js object new" ("js constant" "java.lang.String") [value "utf8"])
- (:as Text)
- #try.Success)
-
- ffi.on_node_js?
- (|> (Buffer::from|decode [value])
- (Buffer::toString ["utf8"])
- #try.Success)
-
- ## On the browser
- (|> (TextDecoder::new [(//.name //.utf_8)])
- (TextDecoder::decode [value])
- #try.Success))
-
- @.python
- (try (:as Text ("python object do" "decode" (:assume value) "utf-8")))
-
- @.lua
- (#try.Success ("lua utf8 decode" value))
-
- @.ruby
- (|> value
- (:as RubyArray)
- (RubyArray::pack ["C*"])
- (:as RubyString)
- (RubyString::force_encoding ["UTF-8"])
- #try.Success)
-
- @.php
- (|> value
- ("php pack" ..php_byte_array_format)
- #try.Success)
-
- @.scheme
- (|> value
- ..utf8->string
- #try.Success)})))
-
-(implementation: #export codec
- (Codec Binary Text)
-
- (def: encode ..encode)
- (def: decode ..decode))
diff --git a/stdlib/source/lux/data/text/escape.lux b/stdlib/source/lux/data/text/escape.lux
deleted file mode 100644
index 7a710ae74..000000000
--- a/stdlib/source/lux/data/text/escape.lux
+++ /dev/null
@@ -1,243 +0,0 @@
-(.module:
- [lux #*
- ["." meta]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<.>" code]]]
- [data
- ["." maybe]]
- [math
- [number (#+ hex)
- ["n" nat]]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]]]
- ["." // (#+ Char)
- ["%" format (#+ format)]])
-
-(def: sigil "\")
-
-(template [<char> <sigil>]
- [(def: <char>
- (|> <sigil> (//.nth 0) maybe.assume))]
-
- [sigil_char ..sigil]
- [\u_sigil "u"]
- )
-
-(template [<literal> <sigil> <escaped>]
- [(def: <sigil>
- (|> <literal> (//.nth 0) maybe.assume))
-
- (def: <escaped>
- (format ..sigil <literal>))]
-
- ["0" \0_sigil escaped_\0]
- ["a" \a_sigil escaped_\a]
- ["b" \b_sigil escaped_\b]
- ["t" \t_sigil escaped_\t]
- ["n" \n_sigil escaped_\n]
- ["v" \v_sigil escaped_\v]
- ["f" \f_sigil escaped_\f]
- ["r" \r_sigil escaped_\r]
- [//.\'' \''_sigil escaped_\'']
- [..sigil \\_sigil escaped_\\]
- )
-
-(template [<char> <text>]
- [(def: <char>
- (|> <text> (//.nth 0) maybe.assume))]
-
- [\0 //.\0]
- [\a //.\a]
- [\b //.\b]
- [\t //.\t]
- [\n //.\n]
- [\v //.\v]
- [\f //.\f]
- [\r //.\r]
- [\'' //.\'']
- [\\ ..sigil]
- )
-
-(def: ascii_bottom (hex "20"))
-(def: ascii_top (hex "7E"))
-
-(def: #export (escapable? char)
- (-> Char Bit)
- (case char
- (^template [<char>]
- [(^ (static <char>))
- true])
- ([..\0] [..\a] [..\b] [..\t]
- [..\n] [..\v] [..\f] [..\r]
- [..\''] [..\\])
-
- _
- (or (n.< ..ascii_bottom char)
- (n.> ..ascii_top char))))
-
-(def: (ascii_escape replacement pre_offset pre_limit previous current)
- (-> Text Nat Nat Text Text [Text Text Nat])
- (let [post_offset (inc pre_offset)
- post_limit (n.- post_offset pre_limit)]
- [(format previous
- ("lux text clip" 0 pre_offset current)
- replacement)
- ("lux text clip" post_offset post_limit current)
- post_limit]))
-
-(def: (unicode_escape char pre_offset pre_limit previous current)
- (-> Char Nat Nat Text Text [Text Text Nat])
- (let [code (\ n.hex encode char)
- replacement (format ..sigil "u"
- (case ("lux text size" code)
- 1 (format "000" code)
- 2 (format "00" code)
- 3 (format "0" code)
- _ code))
- post_offset (inc pre_offset)
- post_limit (n.- post_offset pre_limit)]
- [(format previous
- ("lux text clip" 0 pre_offset current)
- replacement)
- ("lux text clip" post_offset post_limit current)
- post_limit]))
-
-(def: #export (escape text)
- (-> Text Text)
- (loop [offset 0
- previous ""
- current text
- limit ("lux text size" text)]
- (if (n.< limit offset)
- (case ("lux text char" offset current)
- (^template [<char> <replacement>]
- [(^ (static <char>))
- (let [[previous' current' limit'] (ascii_escape <replacement> offset limit previous current)]
- (recur 0 previous' current' limit'))])
- ([..\0 ..escaped_\0]
- [..\a ..escaped_\a]
- [..\b ..escaped_\b]
- [..\t ..escaped_\t]
- [..\n ..escaped_\n]
- [..\v ..escaped_\v]
- [..\f ..escaped_\f]
- [..\r ..escaped_\r]
- [..\'' ..escaped_\'']
- [..\\ ..escaped_\\])
-
- char
- (if (or (n.< ..ascii_bottom char)
- (n.> ..ascii_top char))
- (let [[previous' current' limit'] (unicode_escape char offset limit previous current)]
- (recur 0 previous' current' limit'))
- (recur (inc offset) previous current limit)))
- (format previous current))))
-
-(exception: #export (dangling_escape {text Text})
- (exception.report
- ["In" (%.text text)]
- ["At" (%.nat (dec (//.size text)))]))
-
-(exception: #export (invalid_escape {text Text} {offset Nat} {sigil Char})
- (exception.report
- ["In" (%.text text)]
- ["At" (%.nat offset)]
- ["Name" (%.text (//.from_code sigil))]))
-
-(exception: #export (invalid_unicode_escape {text Text} {offset Nat})
- (exception.report
- ["In" (%.text text)]
- ["At" (%.nat offset)]))
-
-(def: code_size
- 4)
-
-(def: ascii_escape_offset
- 2)
-
-(def: unicode_escape_offset
- (n.+ ..ascii_escape_offset ..code_size))
-
-(def: (ascii_un_escape replacement offset previous current limit)
- (-> Text Nat Text Text Nat [Text Text Nat])
- (let [limit' (|> limit (n.- offset) (n.- ..ascii_escape_offset))]
- [(format previous
- ("lux text clip" 0 offset current)
- replacement)
- ("lux text clip" (n.+ ..ascii_escape_offset offset) limit' current)
- limit']))
-
-(def: (unicode_un_escape offset previous current limit)
- (-> Nat Text Text Nat (Try [Text Text Nat]))
- (case (|> current
- ("lux text clip" (n.+ ..ascii_escape_offset offset) ..code_size)
- (\ n.hex decode))
- (#try.Success char)
- (let [limit' (|> limit (n.- offset) (n.- ..unicode_escape_offset))]
- (#try.Success [(format previous
- ("lux text clip" 0 offset current)
- (//.from_code char))
- ("lux text clip" (n.+ ..unicode_escape_offset offset) limit' current)
- limit']))
-
- (#try.Failure error)
- (exception.throw ..invalid_unicode_escape [current offset])))
-
-(def: #export (un_escape text)
- (-> Text (Try Text))
- (loop [offset 0
- previous ""
- current text
- limit ("lux text size" text)]
- (if (n.< limit offset)
- (case ("lux text char" offset current)
- (^ (static ..sigil_char))
- (let [@sigil (inc offset)]
- (if (n.< limit @sigil)
- (case ("lux text char" @sigil current)
- (^template [<sigil> <un_escaped>]
- [(^ (static <sigil>))
- (let [[previous' current' limit'] (..ascii_un_escape <un_escaped> offset previous current limit)]
- (recur 0 previous' current' limit'))])
- ([..\0_sigil //.\0]
- [..\a_sigil //.\a]
- [..\b_sigil //.\b]
- [..\t_sigil //.\t]
- [..\n_sigil //.\n]
- [..\v_sigil //.\v]
- [..\f_sigil //.\f]
- [..\r_sigil //.\r]
- [..\''_sigil //.\'']
- [..\\_sigil ..sigil])
-
- (^ (static ..\u_sigil))
- (let [@unicode (n.+ code_size @sigil)]
- (if (n.< limit @unicode)
- (do try.monad
- [[previous' current' limit'] (..unicode_un_escape offset previous current limit)]
- (recur 0 previous' current' limit'))
- (exception.throw ..invalid_unicode_escape [text offset])))
-
- invalid_sigil
- (exception.throw ..invalid_escape [text offset invalid_sigil]))
- (exception.throw ..dangling_escape [text])))
-
- _
- (recur (inc offset) previous current limit))
- (#try.Success (case previous
- "" current
- _ (format previous current))))))
-
-(syntax: #export (escaped {literal <code>.text})
- (case (..un_escape literal)
- (#try.Success un_escaped)
- (wrap (list (code.text un_escaped)))
-
- (#try.Failure error)
- (meta.fail error)))
diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux
deleted file mode 100644
index 6deb80074..000000000
--- a/stdlib/source/lux/data/text/format.lux
+++ /dev/null
@@ -1,134 +0,0 @@
-(.module:
- [lux (#- list nat int rev type)
- [abstract
- [monad (#+ do)]
- [functor
- ["." contravariant]]]
- [control
- ["<>" parser
- ["<c>" code (#+ Parser)]]]
- [data
- ["." bit]
- ["." name]
- ["." text]
- [format
- ["." xml]
- ["." json]]
- [collection
- ["." list ("#\." monad)]]]
- ["." time
- ["." instant]
- ["." duration]
- ["." date]
- ["." day]
- ["." month]]
- [math
- ["." modular]
- [number
- ["." nat]
- ["." int]
- ["." rev]
- ["." frac]
- ["." ratio]]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]
- ["." template]]
- [meta
- ["." location]]
- ["." type]])
-
-(type: #export (Format a)
- {#.doc "A way to produce readable text from values."}
- (-> a Text))
-
-(implementation: #export functor
- (contravariant.Functor Format)
-
- (def: (map f fb)
- (|>> f fb)))
-
-(syntax: #export (format {fragments (<>.many <c>.any)})
- {#.doc (doc "Text interpolation."
- (format "Static part " (text static) " does not match URI: " uri))}
- (wrap (.list (` ($_ "lux text concat" (~+ fragments))))))
-
-(template [<name> <type> <formatter>]
- [(def: #export <name>
- (Format <type>)
- <formatter>)]
-
- [bit Bit (\ bit.codec encode)]
- [nat Nat (\ nat.decimal encode)]
- [int Int (\ int.decimal encode)]
- [rev Rev (\ rev.decimal encode)]
- [frac Frac (\ frac.decimal encode)]
- [text Text text.format]
-
- [ratio ratio.Ratio (\ ratio.codec encode)]
- [name Name (\ name.codec encode)]
- [location Location location.format]
- [code Code code.format]
- [type Type type.format]
-
- [instant instant.Instant (\ instant.codec encode)]
- [duration duration.Duration (\ duration.codec encode)]
- [date date.Date (\ date.codec encode)]
- [time time.Time (\ time.codec encode)]
- [day day.Day (\ day.codec encode)]
- [month month.Month (\ month.codec encode)]
-
- [xml xml.XML (\ xml.codec encode)]
- [json json.JSON (\ json.codec encode)]
- )
-
-(template [<type> <format>,<codec>]
- [(`` (template [<format> <codec>]
- [(def: #export <format>
- (Format <type>)
- (\ <codec> encode))]
-
- (~~ (template.splice <format>,<codec>))))]
-
- [Nat
- [[nat/2 nat.binary]
- [nat/8 nat.octal]
- [nat/10 nat.decimal]
- [nat/16 nat.hex]]]
- [Int
- [[int/2 int.binary]
- [int/8 int.octal]
- [int/10 int.decimal]
- [int/16 int.hex]]]
- [Rev
- [[rev/2 rev.binary]
- [rev/8 rev.octal]
- [rev/10 rev.decimal]
- [rev/16 rev.hex]]]
- [Frac
- [[frac/2 frac.binary]
- [frac/8 frac.octal]
- [frac/10 frac.decimal]
- [frac/16 frac.hex]]]
- )
-
-(def: #export (mod modular)
- (All [m] (Format (modular.Mod m)))
- (let [codec (modular.codec (modular.modulus modular))]
- (\ codec encode modular)))
-
-(def: #export (list formatter)
- (All [a] (-> (Format a) (Format (List a))))
- (|>> (list\map (|>> formatter (format " ")))
- (text.join_with "")
- (text.enclose ["(list" ")"])))
-
-(def: #export (maybe format)
- (All [a] (-> (Format a) (Format (Maybe a))))
- (function (_ value)
- (case value
- #.None
- "#.None"
-
- (#.Some value)
- (..format "(#.Some " (format value) ")"))))
diff --git a/stdlib/source/lux/data/text/regex.lux b/stdlib/source/lux/data/text/regex.lux
deleted file mode 100644
index 47b559d15..000000000
--- a/stdlib/source/lux/data/text/regex.lux
+++ /dev/null
@@ -1,494 +0,0 @@
-(.module:
- [lux #*
- ["." meta]
- [abstract
- monad]
- [control
- ["." try]
- ["<>" parser ("#\." monad)
- ["<t>" text (#+ Parser)]
- ["<c>" code]]]
- [data
- ["." product]
- ["." maybe]
- [collection
- ["." list ("#\." fold monad)]]]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number (#+ hex)
- ["n" nat ("#\." decimal)]]]]
- ["." //
- ["%" format (#+ format)]])
-
-(def: regex_char^
- (Parser Text)
- (<t>.none_of "\.|&()[]{}"))
-
-(def: escaped_char^
- (Parser Text)
- (do <>.monad
- [? (<>.parses? (<t>.this "\"))]
- (if ?
- <t>.any
- regex_char^)))
-
-(def: (refine^ refinement^ base^)
- (All [a] (-> (Parser a) (Parser Text) (Parser Text)))
- (do <>.monad
- [output base^
- _ (<t>.local output refinement^)]
- (wrap output)))
-
-(def: word^
- (Parser Text)
- (<>.either <t>.alpha_num
- (<t>.one_of "_")))
-
-(def: (copy reference)
- (-> Text (Parser Text))
- (<>.after (<t>.this reference) (<>\wrap reference)))
-
-(def: (join_text^ part^)
- (-> (Parser (List Text)) (Parser Text))
- (do <>.monad
- [parts part^]
- (wrap (//.join_with "" parts))))
-
-(def: name_char^
- (Parser Text)
- (<t>.none_of (format "[]{}()s#.<>" //.double_quote)))
-
-(def: name_part^
- (Parser Text)
- (do <>.monad
- [head (refine^ (<t>.not <t>.decimal)
- name_char^)
- tail (<t>.some name_char^)]
- (wrap (format head tail))))
-
-(def: (name^ current_module)
- (-> Text (Parser Name))
- ($_ <>.either
- (<>.and (<>\wrap current_module) (<>.after (<t>.this "..") name_part^))
- (<>.and name_part^ (<>.after (<t>.this ".") name_part^))
- (<>.and (<>\wrap "lux") (<>.after (<t>.this ".") name_part^))
- (<>.and (<>\wrap "") name_part^)))
-
-(def: (re_var^ current_module)
- (-> Text (Parser Code))
- (do <>.monad
- [name (<t>.enclosed ["\@<" ">"] (name^ current_module))]
- (wrap (` (: (Parser Text) (~ (code.identifier name)))))))
-
-(def: re_range^
- (Parser Code)
- (do {! <>.monad}
- [from (|> regex_char^ (\ ! map (|>> (//.nth 0) maybe.assume)))
- _ (<t>.this "-")
- to (|> regex_char^ (\ ! map (|>> (//.nth 0) maybe.assume)))]
- (wrap (` (<t>.range (~ (code.nat from)) (~ (code.nat to)))))))
-
-(def: re_char^
- (Parser Code)
- (do <>.monad
- [char escaped_char^]
- (wrap (` ((~! ..copy) (~ (code.text char)))))))
-
-(def: re_options^
- (Parser Code)
- (do <>.monad
- [options (<t>.many escaped_char^)]
- (wrap (` (<t>.one_of (~ (code.text options)))))))
-
-(def: re_user_class^'
- (Parser Code)
- (do <>.monad
- [negate? (<>.maybe (<t>.this "^"))
- parts (<>.many ($_ <>.either
- re_range^
- re_options^))]
- (wrap (case negate?
- (#.Some _) (` (<t>.not ($_ <>.either (~+ parts))))
- #.None (` ($_ <>.either (~+ parts)))))))
-
-(def: re_user_class^
- (Parser Code)
- (do <>.monad
- [_ (wrap [])
- init re_user_class^'
- rest (<>.some (<>.after (<t>.this "&&") (<t>.enclosed ["[" "]"] re_user_class^')))]
- (wrap (list\fold (function (_ refinement base)
- (` ((~! refine^) (~ refinement) (~ base))))
- init
- rest))))
-
-(def: blank^
- (Parser Text)
- (<t>.one_of (format " " //.tab)))
-
-(def: ascii^
- (Parser Text)
- (<t>.range (hex "0") (hex "7F")))
-
-(def: control^
- (Parser Text)
- (<>.either (<t>.range (hex "0") (hex "1F"))
- (<t>.one_of (//.from_code (hex "7F")))))
-
-(def: punct^
- (Parser Text)
- (<t>.one_of (format "!#$%&'()*+,-./:;<=>?@[\]^_`{|}~"
- //.double_quote)))
-
-(def: graph^
- (Parser Text)
- (<>.either punct^ <t>.alpha_num))
-
-(def: print^
- (Parser Text)
- (<>.either graph^
- (<t>.one_of (//.from_code (hex "20")))))
-
-(def: re_system_class^
- (Parser Code)
- (do <>.monad
- []
- ($_ <>.either
- (<>.after (<t>.this ".") (wrap (` <t>.any)))
- (<>.after (<t>.this "\d") (wrap (` <t>.decimal)))
- (<>.after (<t>.this "\D") (wrap (` (<t>.not <t>.decimal))))
- (<>.after (<t>.this "\s") (wrap (` <t>.space)))
- (<>.after (<t>.this "\S") (wrap (` (<t>.not <t>.space))))
- (<>.after (<t>.this "\w") (wrap (` (~! word^))))
- (<>.after (<t>.this "\W") (wrap (` (<t>.not (~! word^)))))
-
- (<>.after (<t>.this "\p{Lower}") (wrap (` <t>.lower)))
- (<>.after (<t>.this "\p{Upper}") (wrap (` <t>.upper)))
- (<>.after (<t>.this "\p{Alpha}") (wrap (` <t>.alpha)))
- (<>.after (<t>.this "\p{Digit}") (wrap (` <t>.decimal)))
- (<>.after (<t>.this "\p{Alnum}") (wrap (` <t>.alpha_num)))
- (<>.after (<t>.this "\p{Space}") (wrap (` <t>.space)))
- (<>.after (<t>.this "\p{HexDigit}") (wrap (` <t>.hexadecimal)))
- (<>.after (<t>.this "\p{OctDigit}") (wrap (` <t>.octal)))
- (<>.after (<t>.this "\p{Blank}") (wrap (` (~! blank^))))
- (<>.after (<t>.this "\p{ASCII}") (wrap (` (~! ascii^))))
- (<>.after (<t>.this "\p{Contrl}") (wrap (` (~! control^))))
- (<>.after (<t>.this "\p{Punct}") (wrap (` (~! punct^))))
- (<>.after (<t>.this "\p{Graph}") (wrap (` (~! graph^))))
- (<>.after (<t>.this "\p{Print}") (wrap (` (~! print^))))
- )))
-
-(def: re_class^
- (Parser Code)
- (<>.either re_system_class^
- (<t>.enclosed ["[" "]"] re_user_class^)))
-
-(def: number^
- (Parser Nat)
- (|> (<t>.many <t>.decimal)
- (<>.codec n.decimal)))
-
-(def: re_back_reference^
- (Parser Code)
- (<>.either (do <>.monad
- [_ (<t>.this "\")
- id number^]
- (wrap (` ((~! ..copy) (~ (code.identifier ["" (n\encode id)]))))))
- (do <>.monad
- [_ (<t>.this "\k<")
- captured_name name_part^
- _ (<t>.this ">")]
- (wrap (` ((~! ..copy) (~ (code.identifier ["" captured_name]))))))))
-
-(def: (re_simple^ current_module)
- (-> Text (Parser Code))
- ($_ <>.either
- re_class^
- (re_var^ current_module)
- re_back_reference^
- re_char^
- ))
-
-(def: (re_simple_quantified^ current_module)
- (-> Text (Parser Code))
- (do <>.monad
- [base (re_simple^ current_module)
- quantifier (<t>.one_of "?*+")]
- (case quantifier
- "?"
- (wrap (` (<>.default "" (~ base))))
-
- "*"
- (wrap (` ((~! join_text^) (<>.some (~ base)))))
-
- ## "+"
- _
- (wrap (` ((~! join_text^) (<>.many (~ base)))))
- )))
-
-(def: (re_counted_quantified^ current_module)
- (-> Text (Parser Code))
- (do {! <>.monad}
- [base (re_simple^ current_module)]
- (<t>.enclosed ["{" "}"]
- ($_ <>.either
- (do !
- [[from to] (<>.and number^ (<>.after (<t>.this ",") number^))]
- (wrap (` ((~! join_text^) (<>.between (~ (code.nat from))
- (~ (code.nat to))
- (~ base))))))
- (do !
- [limit (<>.after (<t>.this ",") number^)]
- (wrap (` ((~! join_text^) (<>.at_most (~ (code.nat limit)) (~ base))))))
- (do !
- [limit (<>.before (<t>.this ",") number^)]
- (wrap (` ((~! join_text^) (<>.at_least (~ (code.nat limit)) (~ base))))))
- (do !
- [limit number^]
- (wrap (` ((~! join_text^) (<>.exactly (~ (code.nat limit)) (~ base))))))))))
-
-(def: (re_quantified^ current_module)
- (-> Text (Parser Code))
- (<>.either (re_simple_quantified^ current_module)
- (re_counted_quantified^ current_module)))
-
-(def: (re_complex^ current_module)
- (-> Text (Parser Code))
- ($_ <>.either
- (re_quantified^ current_module)
- (re_simple^ current_module)))
-
-(type: Re_Group
- #Non_Capturing
- (#Capturing [(Maybe Text) Nat]))
-
-(def: (re_sequential^ capturing? re_scoped^ current_module)
- (-> Bit
- (-> Text (Parser [Re_Group Code]))
- Text
- (Parser [Nat Code]))
- (do <>.monad
- [parts (<>.many (<>.or (re_complex^ current_module)
- (re_scoped^ current_module)))
- #let [g!total (code.identifier ["" "0total"])
- g!temp (code.identifier ["" "0temp"])
- [_ names steps] (list\fold (: (-> (Either Code [Re_Group Code])
- [Nat (List Code) (List (List Code))]
- [Nat (List Code) (List (List Code))])
- (function (_ part [idx names steps])
- (case part
- (^or (#.Left complex) (#.Right [#Non_Capturing complex]))
- [idx
- names
- (list& (list g!temp complex
- (' #let) (` [(~ g!total) (\ (~! //.monoid) (~' compose) (~ g!total) (~ g!temp))]))
- steps)]
-
- (#.Right [(#Capturing [?name num_captures]) scoped])
- (let [[idx! name!] (case ?name
- (#.Some _name)
- [idx (code.identifier ["" _name])]
-
- #.None
- [(inc idx) (code.identifier ["" (n\encode idx)])])
- access (if (n.> 0 num_captures)
- (` ((~! product.left) (~ name!)))
- name!)]
- [idx!
- (list& name! names)
- (list& (list name! scoped
- (' #let) (` [(~ g!total) (\ (~! //.monoid) (~' compose) (~ g!total) (~ access))]))
- steps)])
- )))
- [0
- (: (List Code) (list))
- (: (List (List Code)) (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: (unflatten^ lexer)
- (-> (Parser Text) (Parser [Text Any]))
- (<>.and lexer (\ <>.monad wrap [])))
-
-(def: (|||^ left right)
- (All [l r] (-> (Parser [Text l]) (Parser [Text r]) (Parser [Text (| l r)])))
- (function (_ input)
- (case (left input)
- (#try.Success [input' [lt lv]])
- (#try.Success [input' [lt (0 #0 lv)]])
-
- (#try.Failure _)
- (case (right input)
- (#try.Success [input' [rt rv]])
- (#try.Success [input' [rt (0 #1 rv)]])
-
- (#try.Failure error)
- (#try.Failure error)))))
-
-(def: (|||_^ left right)
- (All [l r] (-> (Parser [Text l]) (Parser [Text r]) (Parser Text)))
- (function (_ input)
- (case (left input)
- (#try.Success [input' [lt lv]])
- (#try.Success [input' lt])
-
- (#try.Failure _)
- (case (right input)
- (#try.Success [input' [rt rv]])
- (#try.Success [input' rt])
-
- (#try.Failure error)
- (#try.Failure error)))))
-
-(def: (prep_alternative [num_captures alt])
- (-> [Nat Code] Code)
- (if (n.> 0 num_captures)
- alt
- (` ((~! unflatten^) (~ alt)))))
-
-(def: (re_alternative^ capturing? re_scoped^ current_module)
- (-> Bit
- (-> Text (Parser [Re_Group Code]))
- Text
- (Parser [Nat Code]))
- (do <>.monad
- [#let [sub^ (re_sequential^ capturing? re_scoped^ current_module)]
- head sub^
- tail (<>.some (<>.after (<t>.this "|") sub^))]
- (if (list.empty? tail)
- (wrap head)
- (wrap [(list\fold n.max (product.left head) (list\map product.left tail))
- (` ($_ ((~ (if capturing?
- (` (~! |||^))
- (` (~! |||_^)))))
- (~ (prep_alternative head))
- (~+ (list\map prep_alternative tail))))]))))
-
-(def: (re_scoped^ current_module)
- (-> Text (Parser [Re_Group Code]))
- ($_ <>.either
- (do <>.monad
- [_ (<t>.this "(?:")
- [_ scoped] (re_alternative^ #0 re_scoped^ current_module)
- _ (<t>.this ")")]
- (wrap [#Non_Capturing scoped]))
- (do <>.monad
- [complex (re_complex^ current_module)]
- (wrap [#Non_Capturing complex]))
- (do <>.monad
- [_ (<t>.this "(?<")
- captured_name name_part^
- _ (<t>.this ">")
- [num_captures pattern] (re_alternative^ #1 re_scoped^ current_module)
- _ (<t>.this ")")]
- (wrap [(#Capturing [(#.Some captured_name) num_captures]) pattern]))
- (do <>.monad
- [_ (<t>.this "(")
- [num_captures pattern] (re_alternative^ #1 re_scoped^ current_module)
- _ (<t>.this ")")]
- (wrap [(#Capturing [#.None num_captures]) pattern]))))
-
-(def: (regex^ current_module)
- (-> Text (Parser Code))
- (\ <>.monad map product.right (re_alternative^ #1 re_scoped^ current_module)))
-
-(syntax: #export (regex {pattern <c>.text})
- {#.doc (doc "Create lexers using regular-expression syntax."
- "For example:"
-
- "Literals"
- (regex "a")
-
- "Wildcards"
- (regex ".")
-
- "Escaping"
- (regex "\.")
-
- "Character classes"
- (regex "\d")
- (regex "\p{Lower}")
- (regex "[abc]")
- (regex "[a-z]")
- (regex "[a-zA-Z]")
- (regex "[a-z&&[def]]")
-
- "Negation"
- (regex "[^abc]")
- (regex "[^a-z]")
- (regex "[^a-zA-Z]")
- (regex "[a-z&&[^bc]]")
- (regex "[a-z&&[^m-p]]")
-
- "Combinations"
- (regex "aa")
- (regex "a?")
- (regex "a*")
- (regex "a+")
-
- "Specific amounts"
- (regex "a{2}")
-
- "At least"
- (regex "a{1,}")
-
- "At most"
- (regex "a{,1}")
-
- "Between"
- (regex "a{1,2}")
-
- "Groups"
- (regex "a(.)c")
- (regex "a(b+)c")
- (regex "(\d{3})-(\d{3})-(\d{4})")
- (regex "(\d{3})-(?:\d{3})-(\d{4})")
- (regex "(?<code>\d{3})-\k<code>-(\d{4})")
- (regex "(?<code>\d{3})-\k<code>-(\d{4})-\0")
- (regex "(\d{3})-((\d{3})-(\d{4}))")
-
- "Alternation"
- (regex "a|b")
- (regex "a(.)(.)|b(.)(.)")
- )}
- (do meta.monad
- [current_module meta.current_module_name]
- (case (<t>.run (regex^ current_module)
- pattern)
- (#try.Failure error)
- (meta.fail (format "Error while parsing regular-expression:" //.new_line
- error))
-
- (#try.Success regex)
- (wrap (list regex))
- )))
-
-(syntax: #export (^regex {[pattern bindings] (<c>.form (<>.and <c>.text (<>.maybe <c>.any)))}
- body
- {branches (<>.many <c>.any)})
- {#.doc (doc "Allows you to test text against regular expressions."
- (case some_text
- (^regex "(\d{3})-(\d{3})-(\d{4})"
- [_ country_code area_code place_code])
- do_some_thing_when_number
-
- (^regex "\w+")
- do_some_thing_when_word
-
- _
- do_something_else))}
- (with_gensyms [g!temp]
- (wrap (list& (` (^multi (~ g!temp)
- [((~! <t>.run) (..regex (~ (code.text pattern))) (~ g!temp))
- (#try.Success (~ (maybe.default g!temp bindings)))]))
- body
- branches))))
diff --git a/stdlib/source/lux/data/text/unicode/block.lux b/stdlib/source/lux/data/text/unicode/block.lux
deleted file mode 100644
index 76fe97b78..000000000
--- a/stdlib/source/lux/data/text/unicode/block.lux
+++ /dev/null
@@ -1,204 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]
- [monoid (#+ Monoid)]
- ["." interval (#+ Interval)]]
- [math
- [number (#+ hex)
- ["n" nat ("#\." interval)]
- ["." i64]]]
- [type
- abstract]]
- [/// (#+ Char)])
-
-(abstract: #export Block
- (Interval Char)
-
- (implementation: #export monoid
- (Monoid Block)
-
- (def: identity
- (:abstraction (interval.between n.enum n\top n\bottom)))
- (def: (compose left right)
- (let [left (:representation left)
- right (:representation right)]
- (:abstraction
- (interval.between n.enum
- (n.min (\ left bottom)
- (\ right bottom))
- (n.max (\ left top)
- (\ right top)))))))
-
- (def: #export (block start end)
- (-> Char Char Block)
- (:abstraction (interval.between n.enum (n.min start end) (n.max start end))))
-
- (template [<name> <slot>]
- [(def: #export <name>
- (-> Block Char)
- (|>> :representation (get@ <slot>)))]
-
- [start #interval.bottom]
- [end #interval.top]
- )
-
- (def: #export (size block)
- (-> Block Nat)
- (let [start (get@ #interval.bottom (:representation block))
- end (get@ #interval.top (:representation block))]
- (|> end (n.- start) inc)))
-
- (def: #export (within? block char)
- (All [a] (-> Block Char Bit))
- (interval.within? (:representation block) char))
- )
-
-(implementation: #export equivalence
- (Equivalence Block)
-
- (def: (= reference subject)
- (and (n.= (..start reference) (..start subject))
- (n.= (..end reference) (..end subject)))))
-
-(implementation: #export hash
- (Hash Block)
-
- (def: &equivalence ..equivalence)
- (def: (hash value)
- (i64.or (i64.left_shift 32 (..start value))
- (..end value))))
-
-(template [<name> <start> <end>]
- [(def: #export <name> Block (..block (hex <start>) (hex <end>)))]
-
- ## Normal blocks
- [basic_latin "0000" "007F"]
- [latin_1_supplement "00A0" "00FF"]
- [latin_extended_a "0100" "017F"]
- [latin_extended_b "0180" "024F"]
- [ipa_extensions "0250" "02AF"]
- [spacing_modifier_letters "02B0" "02FF"]
- [combining_diacritical_marks "0300" "036F"]
- [greek_and_coptic "0370" "03FF"]
- [cyrillic "0400" "04FF"]
- [cyrillic_supplementary "0500" "052F"]
- [armenian "0530" "058F"]
- [hebrew "0590" "05FF"]
- [arabic "0600" "06FF"]
- [syriac "0700" "074F"]
- [thaana "0780" "07BF"]
- [devanagari "0900" "097F"]
- [bengali "0980" "09FF"]
- [gurmukhi "0A00" "0A7F"]
- [gujarati "0A80" "0AFF"]
- [oriya "0B00" "0B7F"]
- [tamil "0B80" "0BFF"]
- [telugu "0C00" "0C7F"]
- [kannada "0C80" "0CFF"]
- [malayalam "0D00" "0D7F"]
- [sinhala "0D80" "0DFF"]
- [thai "0E00" "0E7F"]
- [lao "0E80" "0EFF"]
- [tibetan "0F00" "0FFF"]
- [myanmar "1000" "109F"]
- [georgian "10A0" "10FF"]
- [hangul_jamo "1100" "11FF"]
- [ethiopic "1200" "137F"]
- [cherokee "13A0" "13FF"]
- [unified_canadian_aboriginal_syllabics "1400" "167F"]
- [ogham "1680" "169F"]
- [runic "16A0" "16FF"]
- [tagalog "1700" "171F"]
- [hanunoo "1720" "173F"]
- [buhid "1740" "175F"]
- [tagbanwa "1760" "177F"]
- [khmer "1780" "17FF"]
- [mongolian "1800" "18AF"]
- [limbu "1900" "194F"]
- [tai_le "1950" "197F"]
- [khmer_symbols "19E0" "19FF"]
- [phonetic_extensions "1D00" "1D7F"]
- [latin_extended_additional "1E00" "1EFF"]
- [greek_extended "1F00" "1FFF"]
- [general_punctuation "2000" "206F"]
- [superscripts_and_subscripts "2070" "209F"]
- [currency_symbols "20A0" "20CF"]
- [combining_diacritical_marks_for_symbols "20D0" "20FF"]
- [letterlike_symbols "2100" "214F"]
- [number_forms "2150" "218F"]
- [arrows "2190" "21FF"]
- [mathematical_operators "2200" "22FF"]
- [miscellaneous_technical "2300" "23FF"]
- [control_pictures "2400" "243F"]
- [optical_character_recognition "2440" "245F"]
- [enclosed_alphanumerics "2460" "24FF"]
- [box_drawing "2500" "257F"]
- [block_elements "2580" "259F"]
- [geometric_shapes "25A0" "25FF"]
- [miscellaneous_symbols "2600" "26FF"]
- [dingbats "2700" "27BF"]
- [miscellaneous_mathematical_symbols_a "27C0" "27EF"]
- [supplemental_arrows_a "27F0" "27FF"]
- [braille_patterns "2800" "28FF"]
- [supplemental_arrows_b "2900" "297F"]
- [miscellaneous_mathematical_symbols_b "2980" "29FF"]
- [supplemental_mathematical_operators "2A00" "2AFF"]
- [miscellaneous_symbols_and_arrows "2B00" "2BFF"]
- [cjk_radicals_supplement "2E80" "2EFF"]
- [kangxi_radicals "2F00" "2FDF"]
- [ideographic_description_characters "2FF0" "2FFF"]
- [cjk_symbols_and_punctuation "3000" "303F"]
- [hiragana "3040" "309F"]
- [katakana "30A0" "30FF"]
- [bopomofo "3100" "312F"]
- [hangul_compatibility_jamo "3130" "318F"]
- [kanbun "3190" "319F"]
- [bopomofo_extended "31A0" "31BF"]
- [katakana_phonetic_extensions "31F0" "31FF"]
- [enclosed_cjk_letters_and_months "3200" "32FF"]
- [cjk_compatibility "3300" "33FF"]
- [cjk_unified_ideographs_extension_a "3400" "4DBF"]
- [yijing_hexagram_symbols "4DC0" "4DFF"]
- [cjk_unified_ideographs "4E00" "9FFF"]
- [yi_syllables "A000" "A48F"]
- [yi_radicals "A490" "A4CF"]
- [hangul_syllables "AC00" "D7AF"]
- [high_surrogates "D800" "DB7F"]
- [high_private_use_surrogates "DB80" "DBFF"]
- [low_surrogates "DC00" "DFFF"]
- [private_use_area "E000" "F8FF"]
- [cjk_compatibility_ideographs "F900" "FAFF"]
- [alphabetic_presentation_forms "FB00" "FB4F"]
- [arabic_presentation_forms_a "FB50" "FDFF"]
- [variation_selectors "FE00" "FE0F"]
- [combining_half_marks "FE20" "FE2F"]
- [cjk_compatibility_forms "FE30" "FE4F"]
- [small_form_variants "FE50" "FE6F"]
- [arabic_presentation_forms_b "FE70" "FEFF"]
- [halfwidth_and_fullwidth_forms "FF00" "FFEF"]
- [specials "FFF0" "FFFF"]
- ## [linear_b_syllabary "10000" "1007F"]
- ## [linear_b_ideograms "10080" "100FF"]
- ## [aegean_numbers "10100" "1013F"]
- ## [old_italic "10300" "1032F"]
- ## [gothic "10330" "1034F"]
- ## [ugaritic "10380" "1039F"]
- ## [deseret "10400" "1044F"]
- ## [shavian "10450" "1047F"]
- ## [osmanya "10480" "104AF"]
- ## [cypriot_syllabary "10800" "1083F"]
- ## [byzantine_musical_symbols "1D000" "1D0FF"]
- ## [musical_symbols "1D100" "1D1FF"]
- ## [tai_xuan_jing_symbols "1D300" "1D35F"]
- ## [mathematical_alphanumeric_symbols "1D400" "1D7FF"]
- ## [cjk_unified_ideographs_extension_b "20000" "2A6DF"]
- ## [cjk_compatibility_ideographs_supplement "2F800" "2FA1F"]
- ## [tags "E0000" "E007F"]
-
- ## Specialized blocks
- [basic_latin/decimal "0030" "0039"]
- [basic_latin/upper "0041" "005A"]
- [basic_latin/lower "0061" "007A"]
- )
diff --git a/stdlib/source/lux/data/text/unicode/set.lux b/stdlib/source/lux/data/text/unicode/set.lux
deleted file mode 100644
index 117df224c..000000000
--- a/stdlib/source/lux/data/text/unicode/set.lux
+++ /dev/null
@@ -1,239 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- [collection
- ["." list ("#\." fold functor)]
- ["." set ("#\." equivalence)]
- ["." tree #_
- ["#" finger (#+ Tree)]]]]
- [type (#+ :by_example)
- abstract]]
- ["." / #_
- ["/#" // #_
- [// (#+ Char)]
- ["#." block (#+ Block)]]])
-
-(def: builder
- (tree.builder //block.monoid))
-
-(def: :@:
- (:by_example [@]
- (tree.Builder @ Block)
- ..builder
-
- @))
-
-(abstract: #export Set
- (Tree :@: Block [])
-
- (def: #export (compose left right)
- (-> Set Set Set)
- (:abstraction
- (\ builder branch
- (:representation left)
- (:representation right))))
-
- (def: (singleton block)
- (-> Block Set)
- (:abstraction
- (\ builder leaf block [])))
-
- (def: #export (set [head tail])
- (-> [Block (List Block)] Set)
- (list\fold (: (-> Block Set Set)
- (function (_ block set)
- (..compose (..singleton block) set)))
- (..singleton head)
- tail))
-
- (def: character/0
- Set
- (..set [//block.basic_latin
- (list //block.latin_1_supplement
- //block.latin_extended_a
- //block.latin_extended_b
- //block.ipa_extensions
- //block.spacing_modifier_letters
- //block.combining_diacritical_marks
- //block.greek_and_coptic
- //block.cyrillic
- //block.cyrillic_supplementary
- //block.armenian
- //block.hebrew
- //block.arabic
- //block.syriac
- //block.thaana
- //block.devanagari
- //block.bengali
- //block.gurmukhi
- //block.gujarati
- //block.oriya
- //block.tamil
- //block.telugu
- //block.kannada
- //block.malayalam
- //block.sinhala
- //block.thai
- //block.lao
- //block.tibetan
- //block.myanmar
- //block.georgian)]))
-
- (def: character/1
- Set
- (..set [//block.hangul_jamo
- (list //block.ethiopic
- //block.cherokee
- //block.unified_canadian_aboriginal_syllabics
- //block.ogham
- //block.runic
- //block.tagalog
- //block.hanunoo
- //block.buhid
- //block.tagbanwa
- //block.khmer
- //block.mongolian
- //block.limbu
- //block.tai_le
- //block.khmer_symbols
- //block.phonetic_extensions
- //block.latin_extended_additional
- //block.greek_extended
- //block.general_punctuation
- //block.superscripts_and_subscripts
- //block.currency_symbols
- //block.combining_diacritical_marks_for_symbols
- //block.letterlike_symbols
- //block.number_forms
- //block.arrows
- //block.mathematical_operators
- //block.miscellaneous_technical
- //block.control_pictures
- //block.optical_character_recognition
- //block.enclosed_alphanumerics
- //block.box_drawing)]))
-
- (def: character/2
- Set
- (..set [//block.block_elements
- (list //block.geometric_shapes
- //block.miscellaneous_symbols
- //block.dingbats
- //block.miscellaneous_mathematical_symbols_a
- //block.supplemental_arrows_a
- //block.braille_patterns
- //block.supplemental_arrows_b
- //block.miscellaneous_mathematical_symbols_b
- //block.supplemental_mathematical_operators
- //block.miscellaneous_symbols_and_arrows
- //block.cjk_radicals_supplement
- //block.kangxi_radicals
- //block.ideographic_description_characters
- //block.cjk_symbols_and_punctuation
- //block.hiragana
- //block.katakana
- //block.bopomofo
- //block.hangul_compatibility_jamo
- //block.kanbun
- //block.bopomofo_extended
- //block.katakana_phonetic_extensions
- //block.enclosed_cjk_letters_and_months
- //block.cjk_compatibility
- //block.cjk_unified_ideographs_extension_a
- //block.yijing_hexagram_symbols
- //block.cjk_unified_ideographs
- //block.yi_syllables
- //block.yi_radicals
- //block.hangul_syllables
- )]))
-
- (def: #export character
- Set
- ($_ ..compose
- ..character/0
- ..character/1
- ..character/2
- ))
-
- (def: #export non_character
- Set
- (..set [//block.high_surrogates
- (list //block.high_private_use_surrogates
- //block.low_surrogates
- //block.private_use_area
- //block.cjk_compatibility_ideographs
- //block.alphabetic_presentation_forms
- //block.arabic_presentation_forms_a
- //block.variation_selectors
- //block.combining_half_marks
- //block.cjk_compatibility_forms
- //block.small_form_variants
- //block.arabic_presentation_forms_b
- //block.halfwidth_and_fullwidth_forms
- //block.specials
- ## //block.linear_b_syllabary
- ## //block.linear_b_ideograms
- ## //block.aegean_numbers
- ## //block.old_italic
- ## //block.gothic
- ## //block.ugaritic
- ## //block.deseret
- ## //block.shavian
- ## //block.osmanya
- ## //block.cypriot_syllabary
- ## //block.byzantine_musical_symbols
- ## //block.musical_symbols
- ## //block.tai_xuan_jing_symbols
- ## //block.mathematical_alphanumeric_symbols
- ## //block.cjk_unified_ideographs_extension_b
- ## //block.cjk_compatibility_ideographs_supplement
- ## //block.tags
- )]))
-
- (def: #export full
- Set
- ($_ ..compose
- ..character
- ..non_character
- ))
-
- (def: #export (range set)
- (-> Set [Char Char])
- (let [tag (tree.tag (:representation set))]
- [(//block.start tag)
- (//block.end tag)]))
-
- (def: #export (member? set character)
- (-> Set Char Bit)
- (loop [tree (:representation set)]
- (if (//block.within? (tree.tag tree) character)
- (case (tree.root tree)
- (0 #0 _)
- true
-
- (0 #1 left right)
- (or (recur left)
- (recur right)))
- false)))
-
- (implementation: #export equivalence
- (Equivalence Set)
-
- (def: (= reference subject)
- (set\= (set.from_list //block.hash (tree.tags (:representation reference)))
- (set.from_list //block.hash (tree.tags (:representation subject))))))
- )
-
-(template [<name> <blocks>]
- [(def: #export <name>
- (..set <blocks>))]
-
- [ascii [//block.basic_latin (list)]]
- [ascii/alpha [//block.basic_latin/upper (list //block.basic_latin/lower)]]
- [ascii/alpha_num [//block.basic_latin/upper (list //block.basic_latin/lower //block.basic_latin/decimal)]]
- [ascii/numeric [//block.basic_latin/decimal (list)]]
- [ascii/upper [//block.basic_latin/upper (list)]]
- [ascii/lower [//block.basic_latin/lower (list)]]
- )
diff --git a/stdlib/source/lux/data/trace.lux b/stdlib/source/lux/data/trace.lux
deleted file mode 100644
index 1b2f87ddf..000000000
--- a/stdlib/source/lux/data/trace.lux
+++ /dev/null
@@ -1,35 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monoid (#+ Monoid)]
- [functor (#+ Functor)]
- comonad]
- function])
-
-(type: #export (Trace t a)
- {#monoid (Monoid t)
- #trace (-> t a)})
-
-(implementation: #export functor (All [t] (Functor (Trace t)))
- (def: (map f fa)
- (update@ #trace (compose f) fa)))
-
-(implementation: #export comonad (All [t] (CoMonad (Trace t)))
- (def: &functor ..functor)
-
- (def: (unwrap wa)
- ((get@ #trace wa)
- (get@ [#monoid #monoid.identity] wa)))
-
- (def: (split wa)
- (let [monoid (get@ #monoid wa)]
- {#monoid monoid
- #trace (function (_ t1)
- {#monoid monoid
- #trace (function (_ t2)
- ((get@ #trace wa)
- (\ monoid compose t1 t2)))})})))
-
-(def: #export (run context tracer)
- (All [t a] (-> t (Trace t a) a))
- (\ tracer trace context))
diff --git a/stdlib/source/lux/debug.lux b/stdlib/source/lux/debug.lux
deleted file mode 100644
index cf6fb803c..000000000
--- a/stdlib/source/lux/debug.lux
+++ /dev/null
@@ -1,597 +0,0 @@
-(.module:
- [lux (#- type)
- ["@" target]
- ["." type]
- ["." ffi (#+ import:)]
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- [pipe (#+ new>)]
- ["." function]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<.>" type (#+ Parser)]
- ["<.>" code]]]
- [data
- ["." text
- ["%" format (#+ Format)]]
- [format
- [xml (#+ XML)]
- ["." json]]
- [collection
- ["." array]
- ["." list ("#\." functor)]
- ["." dictionary]]]
- [macro
- ["." template]
- ["." syntax (#+ syntax:)]
- ["." code]]
- [math
- [number
- [ratio (#+ Ratio)]
- ["n" nat]
- ["i" int]]]
- [time (#+ Time)
- [instant (#+ Instant)]
- [duration (#+ Duration)]
- [date (#+ Date)]
- [month (#+ Month)]
- [day (#+ Day)]]])
-
-(with_expansions [<jvm> (as_is (import: java/lang/String)
-
- (import: (java/lang/Class a)
- ["#::."
- (getCanonicalName [] java/lang/String)])
-
- (import: java/lang/Object
- ["#::."
- (new [])
- (toString [] java/lang/String)
- (getClass [] (java/lang/Class java/lang/Object))])
-
- (import: java/lang/Integer
- ["#::."
- (longValue [] long)])
-
- (import: java/lang/Long
- ["#::."
- (intValue [] int)])
-
- (import: java/lang/Number
- ["#::."
- (intValue [] int)
- (longValue [] long)
- (doubleValue [] double)]))]
- (for {@.old (as_is <jvm>)
- @.jvm (as_is <jvm>)
-
- @.js
- (as_is (import: JSON
- ["#::."
- (#static stringify [.Any] ffi.String)])
- (import: Array
- ["#::."
- (#static isArray [.Any] ffi.Boolean)]))
-
- @.python
- (as_is (type: PyType
- (primitive "python_type"))
-
- (import: (type [.Any] PyType))
- (import: (str [.Any] ffi.String)))
-
- @.lua
- (as_is (import: (type [.Any] ffi.String))
- (import: (tostring [.Any] ffi.String))
-
- (import: math
- ["#::."
- (#static type [.Any] #? ffi.String)]))
-
- @.ruby
- (as_is (import: Class)
-
- (import: Object
- ["#::."
- (class [] Class)
- (to_s [] ffi.String)]))
-
- @.php
- (as_is (import: (gettype [.Any] ffi.String))
- (import: (strval [.Any] ffi.String)))
-
- @.scheme
- (as_is (import: (boolean? [.Any] Bit))
- (import: (integer? [.Any] Bit))
- (import: (real? [.Any] Bit))
- (import: (string? [.Any] Bit))
- (import: (vector? [.Any] Bit))
- (import: (pair? [.Any] Bit))
- (import: (car [.Any] .Any))
- (import: (cdr [.Any] .Any))
- (import: (format [Text .Any] Text)))
- }))
-
-(def: Inspector
- (.type (Format Any)))
-
-(for {@.lua (def: (tuple_array tuple)
- (-> (array.Array Any) (array.Array Any))
- (array.from_list
- (loop [idx 0]
- (let [member ("lua array read" idx tuple)]
- (if ("lua object nil?" member)
- #.Nil
- (#.Cons member (recur (inc idx))))))))}
- (as_is))
-
-(def: (inspect_tuple inspect)
- (-> Inspector Inspector)
- (with_expansions [<adaption> (for {@.lua (~~ (as_is ..tuple_array))}
- (~~ (as_is)))]
- (`` (|>> (:as (array.Array Any))
- <adaption>
- array.to_list
- (list\map inspect)
- (text.join_with " ")
- (text.enclose ["[" "]"])))))
-
-(def: #export (inspect value)
- Inspector
- (with_expansions [<jvm> (let [object (:as java/lang/Object value)]
- (`` (<| (~~ (template [<class> <processing>]
- [(case (ffi.check <class> object)
- (#.Some value)
- (`` (|> value (~~ (template.splice <processing>))))
- #.None)]
-
- [java/lang/Boolean [(:as .Bit) %.bit]]
- [java/lang/Long [(:as .Int) %.int]]
- [java/lang/Number [java/lang/Number::doubleValue %.frac]]
- [java/lang/String [(:as .Text) %.text]]
- ))
- (case (ffi.check [java/lang/Object] object)
- (#.Some value)
- (let [value (:as (array.Array java/lang/Object) value)]
- (case (array.read 0 value)
- (^multi (#.Some tag)
- [(ffi.check java/lang/Integer tag)
- (#.Some tag)]
- [[(array.read 1 value)
- (array.read 2 value)]
- [last?
- (#.Some choice)]])
- (let [last? (case last?
- (#.Some _) #1
- #.None #0)]
- (|> (%.format (%.nat (.nat (java/lang/Integer::longValue tag)))
- " " (%.bit last?)
- " " (inspect choice))
- (text.enclose ["(" ")"])))
-
- _
- (inspect_tuple inspect value)))
- #.None)
- (java/lang/Object::toString object))))]
- (for {@.old <jvm>
- @.jvm <jvm>
-
- @.js
- (case (ffi.type_of value)
- (^template [<type_of> <then>]
- [<type_of>
- (`` (|> value (~~ (template.splice <then>))))])
- (["boolean" [(:as .Bit) %.bit]]
- ["number" [(:as .Frac) %.frac]]
- ["string" [(:as .Text) %.text]]
- ["undefined" [JSON::stringify]])
-
- "object"
- (let [variant_tag ("js object get" "_lux_tag" value)
- variant_flag ("js object get" "_lux_flag" value)
- variant_value ("js object get" "_lux_value" value)]
- (cond (not (or ("js object undefined?" variant_tag)
- ("js object undefined?" variant_flag)
- ("js object undefined?" variant_value)))
- (|> (%.format (JSON::stringify variant_tag)
- " " (%.bit (not ("js object null?" variant_flag)))
- " " (inspect variant_value))
- (text.enclose ["(" ")"]))
-
- (not (or ("js object undefined?" ("js object get" "_lux_low" value))
- ("js object undefined?" ("js object get" "_lux_high" value))))
- (|> value (:as .Int) %.int)
-
- (Array::isArray value)
- (inspect_tuple inspect value)
-
- ## else
- (JSON::stringify value)))
-
- _
- (JSON::stringify value))
-
- @.python
- (case (..str (..type value))
- (^template [<type_of> <class_of> <then>]
- [(^or <type_of> <class_of>)
- (`` (|> value (~~ (template.splice <then>))))])
- (["<type 'bool'>" "<class 'bool'>" [(:as .Bit) %.bit]]
- ["<type 'int'>" "<class 'int'>" [(:as .Int) %.int]]
- ["<type 'float'>" "<class 'float'>" [(:as .Frac) %.frac]]
- ["<type 'str'>" "<class 'str'>" [(:as .Text) %.text]]
- ["<type 'unicode'>" "<class 'unicode'>" [(:as .Text) %.text]])
-
- (^or "<type 'list'>" "<class 'list'>")
- (inspect_tuple inspect value)
-
- (^or "<type 'tuple'>" "<type 'tuple'>")
- (let [variant (:as (array.Array Any) value)]
- (case (array.size variant)
- 3 (let [variant_tag ("python array read" 0 variant)
- variant_flag ("python array read" 1 variant)
- variant_value ("python array read" 2 variant)]
- (if (or ("python object none?" variant_tag)
- ("python object none?" variant_value))
- (..str value)
- (|> (%.format (|> variant_tag (:as .Nat) %.nat)
- " " (|> variant_flag "python object none?" not %.bit)
- " " (inspect variant_value))
- (text.enclose ["(" ")"]))))
- _ (..str value)))
-
- _
- (..str value))
-
- @.lua
- (case (..type value)
- (^template [<type_of> <then>]
- [<type_of>
- (`` (|> value (~~ (template.splice <then>))))])
- (["boolean" [(:as .Bit) %.bit]]
- ["string" [(:as .Text) %.text]]
- ["nil" [(new> "nil" [])]])
-
- "number"
- (case (math::type [value])
- (#.Some "integer") (|> value (:as .Int) %.int)
- (#.Some "float") (|> value (:as .Frac) %.frac)
-
- _
- (..tostring value))
-
- "table"
- (let [variant_tag ("lua object get" "_lux_tag" value)
- variant_flag ("lua object get" "_lux_flag" value)
- variant_value ("lua object get" "_lux_value" value)]
- (if (or ("lua object nil?" variant_tag)
- ("lua object nil?" variant_value))
- (inspect_tuple inspect value)
- (|> (%.format (|> variant_tag (:as .Nat) %.nat)
- " " (%.bit (not ("lua object nil?" variant_flag)))
- " " (inspect variant_value))
- (text.enclose ["(" ")"]))))
-
- _
- (..tostring value))
-
- @.ruby
- (template.let [(class_of <literal>)
- [(|> <literal>
- (:as ..Object)
- (Object::class []))]
-
- (to_s <object>)
- [(|> <object>
- (:as ..Object)
- (Object::to_s []))]]
- (let [value_class (class_of value)]
- (`` (cond (~~ (template [<literal> <type> <format>]
- [(is? (class_of <literal>) value_class)
- (|> value (:as <type>) <format>)]
-
- [#0 Bit %.bit]
- [#1 Bit %.bit]
- [+1 Int %.int]
- [+1.0 Frac %.frac]
- ["" Text %.text]
- [("ruby object nil") Any (new> "nil" [])]
- ))
-
- (is? (class_of #.None) value_class)
- (let [variant_tag ("ruby object get" "_lux_tag" value)
- variant_flag ("ruby object get" "_lux_flag" value)
- variant_value ("ruby object get" "_lux_value" value)]
- (if (or ("ruby object nil?" variant_tag)
- ("ruby object nil?" variant_value))
- (inspect_tuple inspect value)
- (|> (%.format (|> variant_tag (:as .Nat) %.nat)
- " " (%.bit (not ("ruby object nil?" variant_flag)))
- " " (inspect variant_value))
- (text.enclose ["(" ")"]))))
-
- (is? (class_of [[] []]) value_class)
- (inspect_tuple inspect value)
-
- ## else
- (to_s value)))))
-
- @.php
- (case (..gettype value)
- (^template [<type_of> <then>]
- [<type_of>
- (`` (|> value (~~ (template.splice <then>))))])
- (["boolean" [(:as .Bit) %.bit]]
- ["integer" [(:as .Int) %.int]]
- ["double" [(:as .Frac) %.frac]]
- ["string" [(:as .Text) %.text]]
- ["NULL" [(new> "null" [])]]
- ["array" [(inspect_tuple inspect)]])
-
- "object"
- (let [variant_tag ("php object get" "_lux_tag" value)
- variant_flag ("php object get" "_lux_flag" value)
- variant_value ("php object get" "_lux_value" value)]
- (if (or ("php object null?" variant_tag)
- ("php object null?" variant_value))
- (..strval value)
- (|> (%.format (|> variant_tag (:as .Nat) %.nat)
- " " (%.bit (not ("php object null?" variant_flag)))
- " " (inspect variant_value))
- (text.enclose ["(" ")"]))))
-
- _
- (..strval value))
-
- @.scheme
- (`` (cond (~~ (template [<when> <then>]
- [(<when> value)
- (`` (|> value (~~ (template.splice <then>))))]
-
- [..boolean? [(:as .Bit) %.bit]]
- [..integer? [(:as .Int) %.int]]
- [..real? [(:as .Frac) %.frac]]
- [..string? [(:as .Text) %.text]]
- ["scheme object nil?" [(new> "()" [])]]
- [..vector? [(inspect_tuple inspect)]]))
-
- (..pair? value)
- (let [variant_tag (..car value)
- variant_rest (..cdr value)]
- (if (and (..integer? variant_tag)
- (i.> +0 (:as Int variant_tag))
- (..pair? variant_rest))
- (let [variant_flag (..car variant_rest)
- variant_value (..cdr variant_rest)]
- (|> (%.format (|> variant_tag (:as .Nat) %.nat)
- " " (%.bit (not ("scheme object nil?" variant_flag)))
- " " (inspect variant_value))
- (text.enclose ["(" ")"])))
- (..format ["~s" value])))
-
- ## else
- (..format ["~s" value])
- ))
- })))
-
-(exception: #export (cannot_represent_value {type Type})
- (exception.report
- ["Type" (%.type type)]))
-
-(type: Representation
- (-> Any Text))
-
-(def: primitive_representation
- (Parser Representation)
- (`` ($_ <>.either
- (do <>.monad
- [_ (<type>.exactly Any)]
- (wrap (function.constant "[]")))
-
- (~~ (template [<type> <formatter>]
- [(do <>.monad
- [_ (<type>.sub <type>)]
- (wrap (|>> (:as <type>) <formatter>)))]
-
- [Bit %.bit]
- [Nat %.nat]
- [Int %.int]
- [Rev %.rev]
- [Frac %.frac]
- [Text %.text]))
- )))
-
-(def: (special_representation representation)
- (-> (Parser Representation) (Parser Representation))
- (`` ($_ <>.either
- (~~ (template [<type> <formatter>]
- [(do <>.monad
- [_ (<type>.sub <type>)]
- (wrap (|>> (:as <type>) <formatter>)))]
-
- [Ratio %.ratio]
- [Name %.name]
- [Location %.location]
- [Type %.type]
- [Code %.code]
-
- [Instant %.instant]
- [Duration %.duration]
- [Date %.date]
- [Time %.time]
- [Month %.month]
- [Day %.day]
-
- [json.JSON %.json]
- [XML %.xml]))
-
- (do <>.monad
- [[_ elemT] (<type>.apply (<>.and (<type>.exactly List) <type>.any))
- elemR (<type>.local (list elemT) representation)]
- (wrap (|>> (:as (List Any)) (%.list elemR))))
-
- (do <>.monad
- [[_ elemT] (<type>.apply (<>.and (<type>.exactly Maybe) <type>.any))
- elemR (<type>.local (list elemT) representation)]
- (wrap (|>> (:as (Maybe Any))
- (%.maybe elemR)))))))
-
-(def: (variant_representation representation)
- (-> (Parser Representation) (Parser Representation))
- (do <>.monad
- [membersR+ (<type>.variant (<>.many representation))]
- (wrap (function (_ variantV)
- (let [[lefts right? sub_repr] (loop [lefts 0
- representations membersR+
- variantV variantV]
- (case representations
- (#.Cons leftR (#.Cons rightR extraR+))
- (case (:as (| Any Any) variantV)
- (#.Left left)
- [lefts #0 (leftR left)]
-
- (#.Right right)
- (case extraR+
- #.Nil
- [lefts #1 (rightR right)]
-
- _
- (recur (inc lefts) (#.Cons rightR extraR+) right)))
-
- _
- (undefined)))]
- (%.format "(" (%.nat lefts) " " (%.bit right?) " " sub_repr ")"))))))
-
-(def: (tuple_representation representation)
- (-> (Parser Representation) (Parser Representation))
- (do <>.monad
- [membersR+ (<type>.tuple (<>.many representation))]
- (wrap (function (_ tupleV)
- (let [tuple_body (loop [representations membersR+
- tupleV tupleV]
- (case representations
- #.Nil
- ""
-
- (#.Cons lastR #.Nil)
- (lastR tupleV)
-
- (#.Cons headR tailR)
- (let [[leftV rightV] (:as [Any Any] tupleV)]
- (%.format (headR leftV) " " (recur tailR rightV)))))]
- (%.format "[" tuple_body "]"))))))
-
-(def: representation
- (Parser Representation)
- (<>.rec
- (function (_ representation)
- ($_ <>.either
- ..primitive_representation
- (..special_representation representation)
- (..variant_representation representation)
- (..tuple_representation representation)
-
- (do <>.monad
- [[funcT inputsT+] (<type>.apply (<>.and <type>.any (<>.many <type>.any)))]
- (case (type.apply inputsT+ funcT)
- (#.Some outputT)
- (<type>.local (list outputT) representation)
-
- #.None
- (<>.fail "")))
-
- (do <>.monad
- [[name anonymous] <type>.named]
- (<type>.local (list anonymous) representation))
-
- (<>.fail "")
- ))))
-
-(def: #export (represent type value)
- (-> Type Any (Try Text))
- (case (<type>.run ..representation type)
- (#try.Success representation)
- (#try.Success (representation value))
-
- (#try.Failure _)
- (exception.throw ..cannot_represent_value type)))
-
-(syntax: #export (private {definition <code>.identifier})
- (let [[module _] definition]
- (wrap (list (` ("lux in-module"
- (~ (code.text module))
- (~ (code.identifier definition))))))))
-
-(def: #export (log! message)
- {#.doc "Logs message to standard output."}
- (-> Text Any)
- ("lux io log" message))
-
-(exception: #export (type_hole {location Location} {type Type})
- (exception.report
- ["Location" (%.location location)]
- ["Type" (%.type type)]))
-
-(syntax: #export (:hole)
- (do meta.monad
- [location meta.location
- expectedT meta.expected_type]
- (function.constant (exception.throw ..type_hole [location expectedT]))))
-
-(type: Target
- [Text (Maybe Code)])
-
-(def: target
- (<code>.Parser Target)
- (<>.either (<>.and <code>.local_identifier
- (\ <>.monad wrap #.None))
- (<code>.record (<>.and <code>.local_identifier
- (\ <>.monad map (|>> #.Some) <code>.any)))))
-
-(exception: #export (unknown_local_binding {name Text})
- (exception.report
- ["Name" (%.text name)]))
-
-(syntax: #export (here {targets (: (<code>.Parser (List Target))
- (|> ..target
- <>.some
- (<>.default (list))))})
- (do {! meta.monad}
- [location meta.location
- locals meta.locals
- #let [environment (|> locals
- list.concat
- ## The list is reversed to make sure that, when building the dictionary,
- ## later bindings overshadow earlier ones if they have the same name.
- list.reverse
- (dictionary.from_list text.hash))]
- targets (: (Meta (List Target))
- (case targets
- #.Nil
- (|> environment
- dictionary.keys
- (list\map (function (_ local) [local #.None]))
- wrap)
-
- _
- (monad.map ! (function (_ [name format])
- (if (dictionary.key? environment name)
- (wrap [name format])
- (function.constant (exception.throw ..unknown_local_binding [name]))))
- targets)))]
- (wrap (list (` (..log! ("lux text concat"
- (~ (code.text (%.format (%.location location) text.new_line)))
- ((~! exception.report)
- (~+ (list\map (function (_ [name format])
- (let [format (case format
- #.None
- (` (~! ..inspect))
-
- (#.Some format)
- format)]
- (` [(~ (code.text name))
- ((~ format) (~ (code.local_identifier name)))])))
- targets))))))))))
diff --git a/stdlib/source/lux/extension.lux b/stdlib/source/lux/extension.lux
deleted file mode 100644
index 4f02d6ebe..000000000
--- a/stdlib/source/lux/extension.lux
+++ /dev/null
@@ -1,88 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad]]
- [control
- ["<>" parser ("#\." monad)
- ["<c>" code (#+ Parser)]
- ["<a>" analysis]
- ["<s>" synthesis]]]
- [data
- ["." product]
- [collection
- ["." list ("#\." functor)]]]
- [macro (#+ with_gensyms)
- ["." code]
- [syntax (#+ syntax:)]]
- [tool
- [compiler
- ["." phase]]]])
-
-(type: Input
- {#variable Text
- #parser Code})
-
-(def: (simple default)
- (-> Code (Parser Input))
- ($_ <>.and
- <c>.local_identifier
- (<>\wrap default)))
-
-(def: complex
- (Parser Input)
- (<c>.record ($_ <>.and
- <c>.local_identifier
- <c>.any)))
-
-(def: (input default)
- (-> Code (Parser Input))
- (<>.either (..simple default)
- ..complex))
-
-(type: Declaration
- {#name Code
- #label Text
- #phase Text
- #archive Text
- #inputs (List Input)})
-
-(def: (declaration default)
- (-> Code (Parser Declaration))
- (<c>.form ($_ <>.and
- <c>.any
- <c>.local_identifier
- <c>.local_identifier
- <c>.local_identifier
- (<>.some (..input default)))))
-
-(template [<any> <end> <and> <run> <extension> <name>]
- [(syntax: #export (<name>
- {[name extension phase archive inputs] (..declaration (` <any>))}
- body)
- (let [g!parser (case (list\map product.right inputs)
- #.Nil
- (` <end>)
-
- parsers
- (` (.$_ <and> (~+ parsers))))
- g!name (code.local_identifier extension)
- g!phase (code.local_identifier phase)
- g!archive (code.local_identifier archive)]
- (with_gensyms [g!handler g!inputs g!error]
- (wrap (list (` (<extension> (~ name)
- (.function ((~ g!handler) (~ g!name) (~ g!phase) (~ g!archive) (~ g!inputs))
- (.case ((~! <run>) (~ g!parser) (~ g!inputs))
- (#.Right [(~+ (list\map (|>> product.left
- code.local_identifier)
- inputs))])
- (~ body)
-
- (#.Left (~ g!error))
- ((~! phase.fail) (~ g!error)))
- ))))))))]
-
- [<c>.any <c>.end! <c>.and <c>.run "lux def analysis" analysis:]
- [<a>.any <a>.end! <a>.and <a>.run "lux def synthesis" synthesis:]
- [<s>.any <s>.end! <s>.and <s>.run "lux def generation" generation:]
- [<c>.any <c>.end! <c>.and <c>.run "lux def directive" directive:]
- )
diff --git a/stdlib/source/lux/ffi.js.lux b/stdlib/source/lux/ffi.js.lux
deleted file mode 100644
index dd5f584c5..000000000
--- a/stdlib/source/lux/ffi.js.lux
+++ /dev/null
@@ -1,363 +0,0 @@
-(.module:
- [lux #*
- ["." meta]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io]
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- ["." product]
- ["." maybe]
- ["." text
- ["%" format]]
- [collection
- ["." list ("#\." functor fold)]]]
- [type
- abstract]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]
- ["." template]]])
-
-(abstract: #export (Object brand)
- Any)
-
-(template [<name>]
- [(with_expansions [<brand> (template.identifier [<name> "'"])]
- (abstract: <brand>
- Any
-
- (type: #export <name>
- (Object <brand>))))]
-
- [Function]
- [Symbol]
- [Null]
- [Undefined]
- )
-
-(template [<name> <type>]
- [(type: #export <name>
- <type>)]
-
- [Boolean Bit]
- [Number Frac]
- [String Text]
- )
-
-(type: Nullable
- [Bit Code])
-
-(def: nullable
- (Parser Nullable)
- (let [token (' #?)]
- (<| (<>.and (<>.parses? (<code>.this! token)))
- (<>.after (<>.not (<code>.this! token)))
- <code>.any)))
-
-(type: Constructor
- (List Nullable))
-
-(def: constructor
- (Parser Constructor)
- (<code>.form (<>.after (<code>.this! (' new))
- (<code>.tuple (<>.some ..nullable)))))
-
-(type: Field
- [Bit Text Nullable])
-
-(def: static!
- (Parser Any)
- (<code>.this! (' #static)))
-
-(def: field
- (Parser Field)
- (<code>.form ($_ <>.and
- (<>.parses? ..static!)
- <code>.local_identifier
- ..nullable)))
-
-(type: Common_Method
- {#name Text
- #alias (Maybe Text)
- #inputs (List Nullable)
- #io? Bit
- #try? Bit
- #output Nullable})
-
-(type: Static_Method Common_Method)
-(type: Virtual_Method Common_Method)
-
-(type: Method
- (#Static Static_Method)
- (#Virtual Virtual_Method))
-
-(def: common_method
- (Parser Common_Method)
- ($_ <>.and
- <code>.local_identifier
- (<>.maybe (<>.after (<code>.this! (' #as)) <code>.local_identifier))
- (<code>.tuple (<>.some ..nullable))
- (<>.parses? (<code>.this! (' #io)))
- (<>.parses? (<code>.this! (' #try)))
- ..nullable))
-
-(def: static_method
- (<>.after ..static! ..common_method))
-
-(def: method
- (Parser Method)
- (<code>.form (<>.or ..static_method
- ..common_method)))
-
-(type: Member
- (#Constructor Constructor)
- (#Field Field)
- (#Method Method))
-
-(def: member
- (Parser Member)
- ($_ <>.or
- ..constructor
- ..field
- ..method
- ))
-
-(def: input_variables
- (-> (List Nullable) (List [Bit Code]))
- (|>> list.enumeration
- (list\map (function (_ [idx [nullable? type]])
- [nullable? (|> idx %.nat code.local_identifier)]))))
-
-(def: (nullable_type [nullable? type])
- (-> Nullable Code)
- (if nullable?
- (` (.Maybe (~ type)))
- type))
-
-(def: (with_null g!temp [nullable? input])
- (-> Code [Bit Code] Code)
- (if nullable?
- (` (case (~ input)
- (#.Some (~ g!temp))
- (~ g!temp)
-
- #.None
- ("js object null")))
- input))
-
-(def: (without_null g!temp [nullable? outputT] output)
- (-> Code Nullable Code Code)
- (if nullable?
- (` (let [(~ g!temp) (~ output)]
- (if ("js object null?" (~ g!temp))
- #.None
- (#.Some (~ g!temp)))))
- (` (let [(~ g!temp) (~ output)]
- (if (not ("js object null?" (~ g!temp)))
- (~ g!temp)
- (.error! "Null is an invalid value."))))))
-
-(type: Import
- (#Class [Text Text (List Member)])
- (#Function Static_Method))
-
-(def: import
- (Parser Import)
- (<>.or (<>.and <code>.local_identifier
- (<>.default ["" (list)]
- (<code>.tuple (<>.and <code>.text
- (<>.some member)))))
- (<code>.form ..common_method)))
-
-(def: (with_io with? without)
- (-> Bit Code Code)
- (if with?
- (` (io.io (~ without)))
- without))
-
-(def: (io_type io? rawT)
- (-> Bit Code Code)
- (if io?
- (` (io.IO (~ rawT)))
- rawT))
-
-(def: (with_try with? without_try)
- (-> Bit Code Code)
- (if with?
- (` (.try (~ without_try)))
- without_try))
-
-(def: (try_type try? rawT)
- (-> Bit Code Code)
- (if try?
- (` (.Either .Text (~ rawT)))
- rawT))
-
-(def: (make_function g!method g!temp source inputsT io? try? outputT)
- (-> Code Code Text (List Nullable) Bit Bit Nullable Code)
- (let [g!inputs (input_variables inputsT)]
- (` (def: ((~ g!method)
- [(~+ (list\map product.right g!inputs))])
- (-> [(~+ (list\map nullable_type inputsT))]
- (~ (|> (nullable_type outputT)
- (try_type try?)
- (io_type io?))))
- (:assume
- (~ (<| (with_io io?)
- (with_try try?)
- (without_null g!temp outputT)
- (` ("js apply"
- ("js constant" (~ (code.text source)))
- (~+ (list\map (with_null g!temp) g!inputs)))))))))))
-
-(syntax: #export (import: {import ..import})
- (with_gensyms [g!temp]
- (case import
- (#Class [class format members])
- (with_gensyms [g!object]
- (let [qualify (: (-> Text Code)
- (function (_ member_name)
- (|> format
- (text.replace_all "#" class)
- (text.replace_all "." member_name)
- code.local_identifier)))
- g!type (code.local_identifier class)
- real_class (text.replace_all "/" "." class)]
- (wrap (list& (` (type: (~ g!type)
- (..Object (primitive (~ (code.text real_class))))))
- (list\map (function (_ member)
- (case member
- (#Constructor inputsT)
- (let [g!inputs (input_variables inputsT)]
- (` (def: ((~ (qualify "new"))
- [(~+ (list\map product.right g!inputs))])
- (-> [(~+ (list\map nullable_type inputsT))]
- (~ g!type))
- (:assume
- ("js object new"
- ("js constant" (~ (code.text real_class)))
- [(~+ (list\map (with_null g!temp) g!inputs))])))))
-
- (#Field [static? field fieldT])
- (if static?
- (` ((~! syntax:) ((~ (qualify field)))
- (\ (~! meta.monad) (~' wrap)
- (list (` (.:as (~ (nullable_type fieldT))
- ("js constant" (~ (code.text (%.format real_class "." field))))))))))
- (` (def: ((~ (qualify field))
- (~ g!object))
- (-> (~ g!type)
- (~ (nullable_type fieldT)))
- (:assume
- (~ (without_null g!temp fieldT (` ("js object get" (~ (code.text field)) (~ g!object)))))))))
-
- (#Method method)
- (case method
- (#Static [method alias inputsT io? try? outputT])
- (..make_function (qualify (maybe.default method alias))
- g!temp
- (%.format real_class "." method)
- inputsT
- io?
- try?
- outputT)
-
- (#Virtual [method alias inputsT io? try? outputT])
- (let [g!inputs (input_variables inputsT)]
- (` (def: ((~ (qualify (maybe.default method alias)))
- [(~+ (list\map product.right g!inputs))]
- (~ g!object))
- (-> [(~+ (list\map nullable_type inputsT))]
- (~ g!type)
- (~ (|> (nullable_type outputT)
- (try_type try?)
- (io_type io?))))
- (:assume
- (~ (<| (with_io io?)
- (with_try try?)
- (without_null g!temp outputT)
- (` ("js object do"
- (~ (code.text method))
- (~ g!object)
- [(~+ (list\map (with_null g!temp) g!inputs))])))))))))))
- members)))))
-
- (#Function [name alias inputsT io? try? outputT])
- (wrap (list (..make_function (code.local_identifier (maybe.default name alias))
- g!temp
- name
- inputsT
- io?
- try?
- outputT)))
- )))
-
-(template: #export (type_of object)
- ("js type-of" object))
-
-(syntax: #export (constant type
- {[head tail] (<code>.tuple (<>.and <code>.local_identifier (<>.some <code>.local_identifier)))})
- (with_gensyms [g!_]
- (let [constant (` ("js constant" (~ (code.text head))))]
- (case tail
- #.Nil
- (wrap (list (` (: (.Maybe (~ type))
- (case (..type_of (~ constant))
- "undefined"
- #.None
-
- (~ g!_)
- (#.Some (:as (~ type) (~ constant))))))))
-
- (#.Cons [next tail])
- (let [separator "."]
- (wrap (list (` (: (.Maybe (~ type))
- (case (..type_of (~ constant))
- "undefined"
- #.None
-
- (~ g!_)
- (..constant (~ type) [(~ (code.local_identifier (%.format head "." next)))
- (~+ (list\map code.local_identifier tail))])))))))))))
-
-(template: (!defined? <constant>)
- (.case (..constant Any <constant>)
- #.None
- .false
-
- (#.Some _)
- .true))
-
-(template [<name> <constant>]
- [(def: #export <name>
- Bit
- (!defined? <constant>))]
-
- [on_browser? [window]]
- [on_nashorn? [java lang Object]]
- )
-
-(def: #export on_node_js?
- Bit
- (case (..constant (Object Any) [process])
- (#.Some process)
- (case (:as Text
- ("js apply" ("js constant" "Object.prototype.toString.call") process))
- "[object process]"
- true
-
- _
- false)
-
- #.None
- false))
-
-(template: #export (closure <inputs> <output>)
- (.:as ..Function
- (`` ("js function"
- (~~ (template.count <inputs>))
- (.function (_ [<inputs>])
- <output>)))))
diff --git a/stdlib/source/lux/ffi.jvm.lux b/stdlib/source/lux/ffi.jvm.lux
deleted file mode 100644
index 8e58c5e50..000000000
--- a/stdlib/source/lux/ffi.jvm.lux
+++ /dev/null
@@ -1,2047 +0,0 @@
-(.module:
- ["." lux (#- Type type int char interface:)
- ["#_." type ("#\." equivalence)]
- [abstract
- ["." monad (#+ Monad do)]
- ["." enum]]
- [control
- ["." function]
- ["." io]
- ["." try (#+ Try)]
- ["." exception (#+ Exception exception:)]
- ["<>" parser ("#\." monad)
- ["<.>" code (#+ Parser)]]]
- [data
- ["." maybe]
- ["." product]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." array]
- ["." list ("#\." monad fold monoid)]
- ["." dictionary (#+ Dictionary)]]]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]
- ["." template]]
- ["." meta
- ["." annotation]]
- [target
- [jvm
- [encoding
- ["." name (#+ External)]]
- ["." type (#+ Type Argument Typed)
- ["." category (#+ Void Value' Value Return' Return Method Primitive Object Class Array Var Parameter Declaration)]
- ["." box]
- ["." descriptor]
- ["." signature]
- ["." reflection]
- ["." parser]]]]])
-
-(def: internal
- (-> External Text)
- (|>> name.internal
- name.read))
-
-(def: signature
- (All [category]
- (-> (Type category) Text))
- (|>> type.signature signature.signature))
-
-(def: reflection
- (All [category]
- (-> (Type (<| Return' Value' category)) Text))
- (|>> type.reflection reflection.reflection))
-
-(template [<name> <class>]
- [(def: #export <name>
- .Type
- (#.Primitive <class> #.Nil))]
-
- [Boolean box.boolean]
- [Byte box.byte]
- [Short box.short]
- [Integer box.int]
- [Long box.long]
- [Float box.float]
- [Double box.double]
- [Character box.char]
- )
-
-(template [<name> <class>]
- [(def: #export <name>
- .Type
- (#.Primitive (reflection.reflection <class>) #.Nil))]
-
- ## Primitives
- [boolean reflection.boolean]
- [byte reflection.byte]
- [short reflection.short]
- [int reflection.int]
- [long reflection.long]
- [float reflection.float]
- [double reflection.double]
- [char reflection.char]
- )
-
-(def: (get_static_field class field)
- (-> Text Text Code)
- (` ("jvm member get static"
- (~ (code.text class))
- (~ (code.text field)))))
-
-(def: (get_virtual_field class field object)
- (-> Text Text Code Code)
- (` ("jvm member get virtual"
- (~ (code.text class))
- (~ (code.text field))
- (~ object))))
-
-(def: boxes
- (Dictionary (Type Value) Text)
- (|> (list [type.boolean box.boolean]
- [type.byte box.byte]
- [type.short box.short]
- [type.int box.int]
- [type.long box.long]
- [type.float box.float]
- [type.double box.double]
- [type.char box.char])
- (dictionary.from_list type.hash)))
-
-(template [<name> <pre> <post>]
- [(def: (<name> unboxed boxed raw)
- (-> (Type Value) Text Code Code)
- (let [unboxed (..reflection unboxed)]
- (` (|> (~ raw)
- (: (primitive (~ (code.text <pre>))))
- "jvm object cast"
- (: (primitive (~ (code.text <post>))))))))]
-
- [unbox boxed unboxed]
- [box unboxed boxed]
- )
-
-(template [<name> <op> <from> <to>]
- [(template: #export (<name> value)
- {#.doc (doc "Type converter."
- (: <to>
- (<name> (: <from> foo))))}
- (|> value
- (: <from>)
- "jvm object cast"
- <op>
- "jvm object cast"
- (: <to>)))]
-
- [byte_to_long "jvm conversion byte-to-long" ..Byte ..Long]
-
- [short_to_long "jvm conversion short-to-long" ..Short ..Long]
-
- [double_to_int "jvm conversion double-to-int" ..Double ..Integer]
- [double_to_long "jvm conversion double-to-long" ..Double ..Long]
- [double_to_float "jvm conversion double-to-float" ..Double ..Float]
-
- [float_to_int "jvm conversion float-to-int" ..Float ..Integer]
- [float_to_long "jvm conversion float-to-long" ..Float ..Long]
- [float_to_double "jvm conversion float-to-double" ..Float ..Double]
-
- [int_to_byte "jvm conversion int-to-byte" ..Integer ..Byte]
- [int_to_short "jvm conversion int-to-short" ..Integer ..Short]
- [int_to_long "jvm conversion int-to-long" ..Integer ..Long]
- [int_to_float "jvm conversion int-to-float" ..Integer ..Float]
- [int_to_double "jvm conversion int-to-double" ..Integer ..Double]
- [int_to_char "jvm conversion int-to-char" ..Integer ..Character]
-
- [long_to_byte "jvm conversion long-to-byte" ..Long ..Byte]
- [long_to_short "jvm conversion long-to-short" ..Long ..Short]
- [long_to_int "jvm conversion long-to-int" ..Long ..Integer]
- [long_to_float "jvm conversion long-to-float" ..Long ..Float]
- [long_to_double "jvm conversion long-to-double" ..Long ..Double]
-
- [char_to_byte "jvm conversion char-to-byte" ..Character ..Byte]
- [char_to_short "jvm conversion char-to-short" ..Character ..Short]
- [char_to_int "jvm conversion char-to-int" ..Character ..Integer]
- [char_to_long "jvm conversion char-to-long" ..Character ..Long]
- )
-
-(template [<name> <from> <to> <0> <1>]
- [(template: #export (<name> value)
- {#.doc (doc "Type converter."
- (: <to>
- (<name> (: <from> foo))))}
- (|> value <0> <1>))]
-
- [long_to_char ..Long ..Character ..long_to_int ..int_to_char]
- [byte_to_int ..Byte ..Integer ..byte_to_long ..long_to_int]
- [short_to_int ..Short ..Integer ..short_to_long ..long_to_int]
- [byte_to_char ..Byte ..Character ..byte_to_int ..int_to_char]
- [short_to_char ..Short ..Character ..short_to_int ..int_to_char]
- )
-
-(def: constructor_method_name
- "<init>")
-
-(type: Primitive_Mode
- #ManualPrM
- #AutoPrM)
-
-(type: Privacy
- #PublicP
- #PrivateP
- #ProtectedP
- #DefaultP)
-
-(type: StateModifier
- #VolatileSM
- #FinalSM
- #DefaultSM)
-
-(type: InheritanceModifier
- #FinalIM
- #AbstractIM
- #DefaultIM)
-
-(type: Class_Kind
- #Class
- #Interface)
-
-(type: StackFrame (primitive "java/lang/StackTraceElement"))
-(type: StackTrace (array.Array StackFrame))
-
-(type: Annotation_Parameter
- [Text Code])
-
-(type: Annotation
- {#ann_name Text
- #ann_params (List Annotation_Parameter)})
-
-(type: Member_Declaration
- {#member_name Text
- #member_privacy Privacy
- #member_anns (List Annotation)})
-
-(type: FieldDecl
- (#ConstantField (Type Value) Code)
- (#VariableField StateModifier (Type Value)))
-
-(type: MethodDecl
- {#method_tvars (List (Type Var))
- #method_inputs (List (Type Value))
- #method_output (Type Return)
- #method_exs (List (Type Class))})
-
-(type: Method_Definition
- (#ConstructorMethod [Bit
- (List (Type Var))
- Text
- (List Argument)
- (List (Typed Code))
- Code
- (List (Type Class))])
- (#VirtualMethod [Bit
- Bit
- (List (Type Var))
- Text
- (List Argument)
- (Type Return)
- Code
- (List (Type Class))])
- (#OverridenMethod [Bit
- (Type Declaration)
- (List (Type Var))
- Text
- (List Argument)
- (Type Return)
- Code
- (List (Type Class))])
- (#StaticMethod [Bit
- (List (Type Var))
- (List Argument)
- (Type Return)
- Code
- (List (Type Class))])
- (#AbstractMethod [(List (Type Var))
- (List Argument)
- (Type Return)
- (List (Type Class))])
- (#NativeMethod [(List (Type Var))
- (List Argument)
- (Type Return)
- (List (Type Class))]))
-
-(type: Partial_Call
- {#pc_method Name
- #pc_args (List Code)})
-
-(type: ImportMethodKind
- #StaticIMK
- #VirtualIMK)
-
-(type: ImportMethodCommons
- {#import_member_mode Primitive_Mode
- #import_member_alias Text
- #import_member_kind ImportMethodKind
- #import_member_tvars (List (Type Var))
- #import_member_args (List [Bit (Type Value)])
- #import_member_maybe? Bit
- #import_member_try? Bit
- #import_member_io? Bit})
-
-(type: ImportConstructorDecl
- {})
-
-(type: ImportMethodDecl
- {#import_method_name Text
- #import_method_return (Type Return)})
-
-(type: ImportFieldDecl
- {#import_field_mode Primitive_Mode
- #import_field_name Text
- #import_field_static? Bit
- #import_field_maybe? Bit
- #import_field_setter? Bit
- #import_field_type (Type Value)})
-
-(type: Import_Member_Declaration
- (#EnumDecl (List Text))
- (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl])
- (#MethodDecl [ImportMethodCommons ImportMethodDecl])
- (#FieldAccessDecl ImportFieldDecl))
-
-(def: (primitive_type mode type)
- (-> Primitive_Mode (Type Primitive) Code)
- (case mode
- #ManualPrM
- (cond (\ type.equivalence = type.boolean type) (` ..Boolean)
- (\ type.equivalence = type.byte type) (` ..Byte)
- (\ type.equivalence = type.short type) (` ..Short)
- (\ type.equivalence = type.int type) (` ..Integer)
- (\ type.equivalence = type.long type) (` ..Long)
- (\ type.equivalence = type.float type) (` ..Float)
- (\ type.equivalence = type.double type) (` ..Double)
- (\ type.equivalence = type.char type) (` ..Character)
- ## else
- (undefined))
-
- #AutoPrM
- (cond (\ type.equivalence = type.boolean type)
- (` .Bit)
-
- (or (\ type.equivalence = type.short type)
- (\ type.equivalence = type.byte type)
- (\ type.equivalence = type.int type)
- (\ type.equivalence = type.long type))
- (` .Int)
-
- (or (\ type.equivalence = type.float type)
- (\ type.equivalence = type.double type))
- (` .Frac)
-
- (\ type.equivalence = type.char type)
- (` .Nat)
-
- ## else
- (undefined))))
-
-(def: (parameter_type type)
- (-> (Type Parameter) Code)
- (`` (<| (~~ (template [<when> <binding> <then>]
- [(case (<when> type)
- (#.Some <binding>)
- <then>
-
- #.None)]
-
- [parser.var? name (code.identifier ["" name])]
- [parser.wildcard? _ (` .Any)]
- [parser.lower? _ (` .Any)]
- [parser.upper? limit (parameter_type limit)]
- [parser.class? [name parameters]
- (` (.primitive (~ (code.text name))
- [(~+ (list\map parameter_type parameters))]))]))
- ## else
- (undefined)
- )))
-
-(def: (value_type mode type)
- (-> Primitive_Mode (Type Value) Code)
- (`` (<| (~~ (template [<when> <binding> <then>]
- [(case (<when> type)
- (#.Some <binding>)
- <then>
-
- #.None)]
-
- [parser.parameter? type (parameter_type type)]
- [parser.primitive? type (primitive_type mode type)]
- [parser.array? elementT (case (parser.primitive? elementT)
- (#.Some elementT)
- (` (#.Primitive (~ (code.text (..reflection (type.array elementT)))) #.Nil))
-
- #.None
- (` (#.Primitive (~ (code.text array.type_name))
- (#.Cons (~ (value_type mode elementT)) #.Nil))))]))
- (undefined)
- )))
-
-(def: declaration_type$
- (-> (Type Declaration) Code)
- (|>> ..signature code.text))
-
-(def: (make_get_const_parser class_name field_name)
- (-> Text Text (Parser Code))
- (do <>.monad
- [#let [dotted_name (format "::" field_name)]
- _ (<code>.this! (code.identifier ["" dotted_name]))]
- (wrap (get_static_field class_name field_name))))
-
-(def: (make_get_var_parser class_name field_name)
- (-> Text Text (Parser Code))
- (do <>.monad
- [#let [dotted_name (format "::" field_name)]
- _ (<code>.this! (code.identifier ["" dotted_name]))]
- (wrap (get_virtual_field class_name field_name (' _jvm_this)))))
-
-(def: (make_put_var_parser class_name field_name)
- (-> Text Text (Parser Code))
- (do <>.monad
- [#let [dotted_name (format "::" field_name)]
- [_ _ value] (: (Parser [Any Any Code])
- (<code>.form ($_ <>.and (<code>.this! (' :=)) (<code>.this! (code.identifier ["" dotted_name])) <code>.any)))]
- (wrap (`' ((~ (code.text (format "jvm putfield" ":" class_name ":" field_name))) _jvm_this (~ value))))))
-
-(def: (pre_walk_replace f input)
- (-> (-> Code Code) Code Code)
- (case (f input)
- (^template [<tag>]
- [[meta (<tag> parts)]
- [meta (<tag> (list\map (pre_walk_replace f) parts))]])
- ([#.Form]
- [#.Tuple])
-
- [meta (#.Record pairs)]
- [meta (#.Record (list\map (: (-> [Code Code] [Code Code])
- (function (_ [key val])
- [(pre_walk_replace f key) (pre_walk_replace f val)]))
- pairs))]
-
- ast'
- ast'))
-
-(def: (parser->replacer p ast)
- (-> (Parser Code) (-> Code Code))
- (case (<>.run p (list ast))
- (#.Right [#.Nil ast'])
- ast'
-
- _
- ast
- ))
-
-(def: (field->parser class_name [[field_name _ _] field])
- (-> Text [Member_Declaration FieldDecl] (Parser Code))
- (case field
- (#ConstantField _)
- (make_get_const_parser class_name field_name)
-
- (#VariableField _)
- (<>.either (make_get_var_parser class_name field_name)
- (make_put_var_parser class_name field_name))))
-
-(def: (decorate_input [class value])
- (-> [(Type Value) Code] Code)
- (` [(~ (code.text (..signature class))) (~ value)]))
-
-(def: (make_constructor_parser class_name arguments)
- (-> Text (List Argument) (Parser Code))
- (do <>.monad
- [args (: (Parser (List Code))
- (<code>.form (<>.after (<code>.this! (' ::new!))
- (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))]
- (wrap (` ("jvm member invoke constructor" (~ (code.text class_name))
- (~+ (|> args
- (list.zip/2 (list\map product.right arguments))
- (list\map ..decorate_input))))))))
-
-(def: (make_static_method_parser class_name method_name arguments)
- (-> Text Text (List Argument) (Parser Code))
- (do <>.monad
- [#let [dotted_name (format "::" method_name "!")]
- args (: (Parser (List Code))
- (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name]))
- (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))]
- (wrap (` ("jvm member invoke static" (~ (code.text class_name)) (~ (code.text method_name))
- (~+ (|> args
- (list.zip/2 (list\map product.right arguments))
- (list\map ..decorate_input))))))))
-
-(template [<name> <jvm_op>]
- [(def: (<name> class_name method_name arguments)
- (-> Text Text (List Argument) (Parser Code))
- (do <>.monad
- [#let [dotted_name (format "::" method_name "!")]
- args (: (Parser (List Code))
- (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name]))
- (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))]
- (wrap (` (<jvm_op> (~ (code.text class_name)) (~ (code.text method_name))
- (~' _jvm_this)
- (~+ (|> args
- (list.zip/2 (list\map product.right arguments))
- (list\map ..decorate_input))))))))]
-
- [make_special_method_parser "jvm member invoke special"]
- [make_virtual_method_parser "jvm member invoke virtual"]
- )
-
-(def: (method->parser class_name [[method_name _ _] meth_def])
- (-> Text [Member_Declaration Method_Definition] (Parser Code))
- (case meth_def
- (#ConstructorMethod strict? type_vars self_name args constructor_args return_expr exs)
- (make_constructor_parser class_name args)
-
- (#StaticMethod strict? type_vars args return_type return_expr exs)
- (make_static_method_parser class_name method_name args)
-
- (^or (#VirtualMethod final? strict? type_vars self_name args return_type return_expr exs)
- (#OverridenMethod strict? owner_class type_vars self_name args return_type return_expr exs))
- (make_special_method_parser class_name method_name args)
-
- (#AbstractMethod type_vars args return_type exs)
- (make_virtual_method_parser class_name method_name args)
-
- (#NativeMethod type_vars args return_type exs)
- (make_virtual_method_parser class_name method_name args)))
-
-(def: privacy_modifier^
- (Parser Privacy)
- (let [(^open ".") <>.monad]
- ($_ <>.or
- (<code>.this! (' #public))
- (<code>.this! (' #private))
- (<code>.this! (' #protected))
- (wrap []))))
-
-(def: inheritance_modifier^
- (Parser InheritanceModifier)
- (let [(^open ".") <>.monad]
- ($_ <>.or
- (<code>.this! (' #final))
- (<code>.this! (' #abstract))
- (wrap []))))
-
-(exception: #export (class_names_cannot_contain_periods {name Text})
- (exception.report
- ["Name" (%.text name)]))
-
-(exception: #export (class_name_cannot_be_a_type_variable {name Text}
- {type_vars (List (Type Var))})
- (exception.report
- ["Name" (%.text name)]
- ["Type Variables" (exception.enumerate parser.name type_vars)]))
-
-(def: (assert exception payload test)
- (All [e] (-> (Exception e) e Bit (Parser Any)))
- (<>.assert (exception.construct exception payload)
- test))
-
-(def: (valid_class_name type_vars)
- (-> (List (Type Var)) (Parser External))
- (do <>.monad
- [name <code>.local_identifier
- _ (..assert ..class_names_cannot_contain_periods [name]
- (not (text.contains? name.external_separator name)))
- _ (..assert ..class_name_cannot_be_a_type_variable [name type_vars]
- (not (list.member? text.equivalence
- (list\map parser.name type_vars)
- name)))]
- (wrap name)))
-
-(def: (class^' parameter^ type_vars)
- (-> (-> (List (Type Var)) (Parser (Type Parameter)))
- (-> (List (Type Var)) (Parser (Type Class))))
- (do <>.monad
- [[name parameters] (: (Parser [External (List (Type Parameter))])
- ($_ <>.either
- (<>.and (valid_class_name type_vars)
- (<>\wrap (list)))
- (<code>.form (<>.and <code>.local_identifier
- (<>.some (parameter^ type_vars))))))]
- (wrap (type.class (name.sanitize name) parameters))))
-
-(exception: #export (unexpected_type_variable {name Text}
- {type_vars (List (Type Var))})
- (exception.report
- ["Unexpected Type Variable" (%.text name)]
- ["Expected Type Variables" (exception.enumerate parser.name type_vars)]))
-
-(def: (variable^ type_vars)
- (-> (List (Type Var)) (Parser (Type Parameter)))
- (do <>.monad
- [name <code>.local_identifier
- _ (..assert ..unexpected_type_variable [name type_vars]
- (list.member? text.equivalence (list\map parser.name type_vars) name))]
- (wrap (type.var name))))
-
-(def: wildcard^
- (Parser (Type Parameter))
- (do <>.monad
- [_ (<code>.this! (' ?))]
- (wrap type.wildcard)))
-
-(template [<name> <comparison> <constructor>]
- [(def: <name>
- (-> (Parser (Type Class)) (Parser (Type Parameter)))
- (|>> (<>.after (<code>.this! (' <comparison>)))
- (<>.after ..wildcard^)
- <code>.tuple
- (\ <>.monad map <constructor>)))]
-
- [upper^ < type.upper]
- [lower^ > type.lower]
- )
-
-(def: (parameter^ type_vars)
- (-> (List (Type Var)) (Parser (Type Parameter)))
- (<>.rec
- (function (_ recur^)
- (let [class^ (..class^' parameter^ type_vars)]
- ($_ <>.either
- (..variable^ type_vars)
- ..wildcard^
- (upper^ class^)
- (lower^ class^)
- class^
- )))))
-
-(def: (itself^ type)
- (All [category]
- (-> (Type (<| Return' Value' category))
- (Parser (Type (<| Return' Value' category)))))
- (do <>.monad
- [_ (<code>.identifier! ["" (..reflection type)])]
- (wrap type)))
-
-(def: primitive^
- (Parser (Type Primitive))
- ($_ <>.either
- (itself^ type.boolean)
- (itself^ type.byte)
- (itself^ type.short)
- (itself^ type.int)
- (itself^ type.long)
- (itself^ type.float)
- (itself^ type.double)
- (itself^ type.char)
- ))
-
-(def: array^
- (-> (Parser (Type Value)) (Parser (Type Array)))
- (|>> <code>.tuple
- (\ <>.monad map type.array)))
-
-(def: (type^ type_vars)
- (-> (List (Type Var)) (Parser (Type Value)))
- (<>.rec
- (function (_ type^)
- ($_ <>.either
- ..primitive^
- (..parameter^ type_vars)
- (..array^ type^)
- ))))
-
-(def: void^
- (Parser (Type Void))
- (do <>.monad
- [_ (<code>.identifier! ["" (reflection.reflection reflection.void)])]
- (wrap type.void)))
-
-(def: (return^ type_vars)
- (-> (List (Type Var)) (Parser (Type Return)))
- (<>.either ..void^
- (..type^ type_vars)))
-
-(def: var^
- (Parser (Type Var))
- (\ <>.monad map type.var <code>.local_identifier))
-
-(def: vars^
- (Parser (List (Type Var)))
- (<code>.tuple (<>.some var^)))
-
-(def: declaration^
- (Parser (Type Declaration))
- (do <>.monad
- [[name variables] (: (Parser [External (List (Type Var))])
- (<>.either (<>.and (..valid_class_name (list))
- (<>\wrap (list)))
- (<code>.form (<>.and (..valid_class_name (list))
- (<>.some var^)))
- ))]
- (wrap (type.declaration name variables))))
-
-(def: (class^ type_vars)
- (-> (List (Type Var)) (Parser (Type Class)))
- (class^' parameter^ type_vars))
-
-(def: annotation_parameters^
- (Parser (List Annotation_Parameter))
- (<code>.record (<>.some (<>.and <code>.local_tag <code>.any))))
-
-(def: annotation^
- (Parser Annotation)
- (<>.either (do <>.monad
- [ann_name <code>.local_identifier]
- (wrap [ann_name (list)]))
- (<code>.form (<>.and <code>.local_identifier
- annotation_parameters^))))
-
-(def: annotations^'
- (Parser (List Annotation))
- (do <>.monad
- [_ (<code>.this! (' #ann))]
- (<code>.tuple (<>.some ..annotation^))))
-
-(def: annotations^
- (Parser (List Annotation))
- (do <>.monad
- [anns?? (<>.maybe ..annotations^')]
- (wrap (maybe.default (list) anns??))))
-
-(def: (throws_decl^ type_vars)
- (-> (List (Type Var)) (Parser (List (Type Class))))
- (<| (<>.default (list))
- (do <>.monad
- [_ (<code>.this! (' #throws))]
- (<code>.tuple (<>.some (..class^ type_vars))))))
-
-(def: (method_decl^ type_vars)
- (-> (List (Type Var)) (Parser [Member_Declaration MethodDecl]))
- (<code>.form (do <>.monad
- [tvars (<>.default (list) ..vars^)
- name <code>.local_identifier
- anns ..annotations^
- inputs (<code>.tuple (<>.some (..type^ type_vars)))
- output (..return^ type_vars)
- exs (throws_decl^ type_vars)]
- (wrap [[name #PublicP anns] {#method_tvars tvars
- #method_inputs inputs
- #method_output output
- #method_exs exs}]))))
-
-(def: state_modifier^
- (Parser StateModifier)
- ($_ <>.or
- (<code>.this! (' #volatile))
- (<code>.this! (' #final))
- (\ <>.monad wrap [])))
-
-(def: (field_decl^ type_vars)
- (-> (List (Type Var)) (Parser [Member_Declaration FieldDecl]))
- (<>.either (<code>.form (do <>.monad
- [_ (<code>.this! (' #const))
- name <code>.local_identifier
- anns ..annotations^
- type (..type^ type_vars)
- body <code>.any]
- (wrap [[name #PublicP anns] (#ConstantField [type body])])))
- (<code>.form (do <>.monad
- [pm privacy_modifier^
- sm state_modifier^
- name <code>.local_identifier
- anns ..annotations^
- type (..type^ type_vars)]
- (wrap [[name pm anns] (#VariableField [sm type])])))))
-
-(def: (argument^ type_vars)
- (-> (List (Type Var)) (Parser Argument))
- (<code>.record (<>.and <code>.local_identifier
- (..type^ type_vars))))
-
-(def: (arguments^ type_vars)
- (-> (List (Type Var)) (Parser (List Argument)))
- (<>.some (..argument^ type_vars)))
-
-(def: (constructor_arg^ type_vars)
- (-> (List (Type Var)) (Parser (Typed Code)))
- (<code>.record (<>.and (..type^ type_vars) <code>.any)))
-
-(def: (constructor_args^ type_vars)
- (-> (List (Type Var)) (Parser (List (Typed Code))))
- (<code>.tuple (<>.some (..constructor_arg^ type_vars))))
-
-(def: (constructor_method^ class_vars)
- (-> (List (Type Var)) (Parser [Member_Declaration Method_Definition]))
- (<code>.form (do <>.monad
- [pm privacy_modifier^
- strict_fp? (<>.parses? (<code>.this! (' #strict)))
- method_vars (<>.default (list) ..vars^)
- #let [total_vars (list\compose class_vars method_vars)]
- [_ self_name arguments] (<code>.form ($_ <>.and
- (<code>.this! (' new))
- <code>.local_identifier
- (..arguments^ total_vars)))
- constructor_args (..constructor_args^ total_vars)
- exs (throws_decl^ total_vars)
- annotations ..annotations^
- body <code>.any]
- (wrap [{#member_name constructor_method_name
- #member_privacy pm
- #member_anns annotations}
- (#ConstructorMethod strict_fp? method_vars self_name arguments constructor_args body exs)]))))
-
-(def: (virtual_method_def^ class_vars)
- (-> (List (Type Var)) (Parser [Member_Declaration Method_Definition]))
- (<code>.form (do <>.monad
- [pm privacy_modifier^
- strict_fp? (<>.parses? (<code>.this! (' #strict)))
- final? (<>.parses? (<code>.this! (' #final)))
- method_vars (<>.default (list) ..vars^)
- #let [total_vars (list\compose class_vars method_vars)]
- [name self_name arguments] (<code>.form ($_ <>.and
- <code>.local_identifier
- <code>.local_identifier
- (..arguments^ total_vars)))
- return_type (..return^ total_vars)
- exs (throws_decl^ total_vars)
- annotations ..annotations^
- body <code>.any]
- (wrap [{#member_name name
- #member_privacy pm
- #member_anns annotations}
- (#VirtualMethod final? strict_fp? method_vars self_name arguments return_type body exs)]))))
-
-(def: overriden_method_def^
- (Parser [Member_Declaration Method_Definition])
- (<code>.form (do <>.monad
- [strict_fp? (<>.parses? (<code>.this! (' #strict)))
- owner_class ..declaration^
- method_vars (<>.default (list) ..vars^)
- #let [total_vars (list\compose (product.right (parser.declaration owner_class))
- method_vars)]
- [name self_name arguments] (<code>.form ($_ <>.and
- <code>.local_identifier
- <code>.local_identifier
- (..arguments^ total_vars)))
- return_type (..return^ total_vars)
- exs (throws_decl^ total_vars)
- annotations ..annotations^
- body <code>.any]
- (wrap [{#member_name name
- #member_privacy #PublicP
- #member_anns annotations}
- (#OverridenMethod strict_fp? owner_class method_vars self_name arguments return_type body exs)]))))
-
-(def: static_method_def^
- (Parser [Member_Declaration Method_Definition])
- (<code>.form (do <>.monad
- [pm privacy_modifier^
- strict_fp? (<>.parses? (<code>.this! (' #strict)))
- _ (<code>.this! (' #static))
- method_vars (<>.default (list) ..vars^)
- #let [total_vars method_vars]
- [name arguments] (<code>.form (<>.and <code>.local_identifier
- (..arguments^ total_vars)))
- return_type (..return^ total_vars)
- exs (throws_decl^ total_vars)
- annotations ..annotations^
- body <code>.any]
- (wrap [{#member_name name
- #member_privacy pm
- #member_anns annotations}
- (#StaticMethod strict_fp? method_vars arguments return_type body exs)]))))
-
-(def: abstract_method_def^
- (Parser [Member_Declaration Method_Definition])
- (<code>.form (do <>.monad
- [pm privacy_modifier^
- _ (<code>.this! (' #abstract))
- method_vars (<>.default (list) ..vars^)
- #let [total_vars method_vars]
- [name arguments] (<code>.form (<>.and <code>.local_identifier
- (..arguments^ total_vars)))
- return_type (..return^ total_vars)
- exs (throws_decl^ total_vars)
- annotations ..annotations^]
- (wrap [{#member_name name
- #member_privacy pm
- #member_anns annotations}
- (#AbstractMethod method_vars arguments return_type exs)]))))
-
-(def: native_method_def^
- (Parser [Member_Declaration Method_Definition])
- (<code>.form (do <>.monad
- [pm privacy_modifier^
- _ (<code>.this! (' #native))
- method_vars (<>.default (list) ..vars^)
- #let [total_vars method_vars]
- [name arguments] (<code>.form (<>.and <code>.local_identifier
- (..arguments^ total_vars)))
- return_type (..return^ total_vars)
- exs (throws_decl^ total_vars)
- annotations ..annotations^]
- (wrap [{#member_name name
- #member_privacy pm
- #member_anns annotations}
- (#NativeMethod method_vars arguments return_type exs)]))))
-
-(def: (method_def^ class_vars)
- (-> (List (Type Var)) (Parser [Member_Declaration Method_Definition]))
- ($_ <>.either
- (..constructor_method^ class_vars)
- (..virtual_method_def^ class_vars)
- ..overriden_method_def^
- ..static_method_def^
- ..abstract_method_def^
- ..native_method_def^))
-
-(def: partial_call^
- (Parser Partial_Call)
- (<code>.form (<>.and <code>.identifier (<>.some <code>.any))))
-
-(def: class_kind^
- (Parser Class_Kind)
- (<>.either (do <>.monad
- [_ (<code>.this! (' #class))]
- (wrap #Class))
- (do <>.monad
- [_ (<code>.this! (' #interface))]
- (wrap #Interface))
- ))
-
-(def: import_member_alias^
- (Parser (Maybe Text))
- (<>.maybe (do <>.monad
- [_ (<code>.this! (' #as))]
- <code>.local_identifier)))
-
-(def: (import_member_args^ type_vars)
- (-> (List (Type Var)) (Parser (List [Bit (Type Value)])))
- (<code>.tuple (<>.some (<>.and (<>.parses? (<code>.tag! ["" "?"]))
- (..type^ type_vars)))))
-
-(def: import_member_return_flags^
- (Parser [Bit Bit Bit])
- ($_ <>.and
- (<>.parses? (<code>.this! (' #io)))
- (<>.parses? (<code>.this! (' #try)))
- (<>.parses? (<code>.this! (' #?)))))
-
-(def: primitive_mode^
- (Parser Primitive_Mode)
- (<>.or (<code>.tag! ["" "manual"])
- (<code>.tag! ["" "auto"])))
-
-(def: (import_member_decl^ owner_vars)
- (-> (List (Type Var)) (Parser Import_Member_Declaration))
- ($_ <>.either
- (<code>.form (do <>.monad
- [_ (<code>.this! (' #enum))
- enum_members (<>.some <code>.local_identifier)]
- (wrap (#EnumDecl enum_members))))
- (<code>.form (do <>.monad
- [tvars (<>.default (list) ..vars^)
- _ (<code>.identifier! ["" "new"])
- ?alias import_member_alias^
- #let [total_vars (list\compose owner_vars tvars)]
- ?prim_mode (<>.maybe primitive_mode^)
- args (..import_member_args^ total_vars)
- [io? try? maybe?] import_member_return_flags^]
- (wrap (#ConstructorDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode)
- #import_member_alias (maybe.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?}
- {}]))
- ))
- (<code>.form (do <>.monad
- [kind (: (Parser ImportMethodKind)
- (<>.or (<code>.tag! ["" "static"])
- (wrap [])))
- tvars (<>.default (list) ..vars^)
- name <code>.local_identifier
- ?alias import_member_alias^
- #let [total_vars (list\compose owner_vars tvars)]
- ?prim_mode (<>.maybe primitive_mode^)
- args (..import_member_args^ total_vars)
- [io? try? maybe?] import_member_return_flags^
- return (..return^ total_vars)]
- (wrap (#MethodDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode)
- #import_member_alias (maybe.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}]))))
- (<code>.form (do <>.monad
- [static? (<>.parses? (<code>.this! (' #static)))
- name <code>.local_identifier
- ?prim_mode (<>.maybe primitive_mode^)
- gtype (..type^ owner_vars)
- maybe? (<>.parses? (<code>.this! (' #?)))
- setter? (<>.parses? (<code>.this! (' #!)))]
- (wrap (#FieldAccessDecl {#import_field_mode (maybe.default #AutoPrM ?prim_mode)
- #import_field_name name
- #import_field_static? static?
- #import_field_maybe? maybe?
- #import_field_setter? setter?
- #import_field_type gtype}))))
- ))
-
-(def: bundle
- (-> (List (Type Var)) (Parser [Text (List Import_Member_Declaration)]))
- (|>> ..import_member_decl^
- <>.some
- (<>.and <code>.text)
- <code>.tuple))
-
-(def: (privacy_modifier$ pm)
- (-> Privacy Code)
- (case pm
- #PublicP (code.text "public")
- #PrivateP (code.text "private")
- #ProtectedP (code.text "protected")
- #DefaultP (code.text "default")))
-
-(def: (inheritance_modifier$ im)
- (-> InheritanceModifier Code)
- (case im
- #FinalIM (code.text "final")
- #AbstractIM (code.text "abstract")
- #DefaultIM (code.text "default")))
-
-(def: (annotation_parameter$ [name value])
- (-> Annotation_Parameter Code)
- (` [(~ (code.text name)) (~ value)]))
-
-(def: (annotation$ [name params])
- (-> Annotation Code)
- (` ((~ (code.text name)) (~+ (list\map annotation_parameter$ params)))))
-
-(template [<name> <category>]
- [(def: <name>
- (-> (Type <category>) Code)
- (|>> ..signature code.text))]
-
- [var$ Var]
- [parameter$ Parameter]
- [value$ Value]
- [return$ Return]
- [declaration$ Declaration]
- [class$ Class]
- )
-
-(def: var$'
- (-> (Type Var) Code)
- (|>> ..signature code.local_identifier))
-
-(def: (method_decl$ [[name pm anns] method_decl])
- (-> [Member_Declaration MethodDecl] Code)
- (let [(^slots [#method_tvars #method_inputs #method_output #method_exs]) method_decl]
- (` ((~ (code.text name))
- [(~+ (list\map annotation$ anns))]
- [(~+ (list\map var$ method_tvars))]
- [(~+ (list\map class$ method_exs))]
- [(~+ (list\map value$ method_inputs))]
- (~ (return$ method_output))))))
-
-(def: (state_modifier$ sm)
- (-> StateModifier Code)
- (case sm
- #VolatileSM (' "volatile")
- #FinalSM (' "final")
- #DefaultSM (' "default")))
-
-(def: (field_decl$ [[name pm anns] field])
- (-> [Member_Declaration FieldDecl] Code)
- (case field
- (#ConstantField class value)
- (` ("constant" (~ (code.text name))
- [(~+ (list\map annotation$ anns))]
- (~ (value$ class))
- (~ value)
- ))
-
- (#VariableField sm class)
- (` ("variable" (~ (code.text name))
- (~ (privacy_modifier$ pm))
- (~ (state_modifier$ sm))
- [(~+ (list\map annotation$ anns))]
- (~ (value$ class))
- ))
- ))
-
-(def: (argument$ [name type])
- (-> Argument Code)
- (` [(~ (code.text name)) (~ (value$ type))]))
-
-(def: (constructor_arg$ [class term])
- (-> (Typed Code) Code)
- (` [(~ (value$ class)) (~ term)]))
-
-(def: (method_def$ replacer super_class [[name pm anns] method_def])
- (-> (-> Code Code) (Type Class) [Member_Declaration Method_Definition] Code)
- (case method_def
- (#ConstructorMethod strict_fp? type_vars self_name arguments constructor_args body exs)
- (` ("init"
- (~ (privacy_modifier$ pm))
- (~ (code.bit strict_fp?))
- [(~+ (list\map annotation$ anns))]
- [(~+ (list\map var$ type_vars))]
- [(~+ (list\map class$ exs))]
- (~ (code.text self_name))
- [(~+ (list\map argument$ arguments))]
- [(~+ (list\map constructor_arg$ constructor_args))]
- (~ (pre_walk_replace replacer body))
- ))
-
- (#VirtualMethod final? strict_fp? type_vars self_name arguments return_type body exs)
- (` ("virtual"
- (~ (code.text name))
- (~ (privacy_modifier$ pm))
- (~ (code.bit final?))
- (~ (code.bit strict_fp?))
- [(~+ (list\map annotation$ anns))]
- [(~+ (list\map var$ type_vars))]
- (~ (code.text self_name))
- [(~+ (list\map argument$ arguments))]
- (~ (return$ return_type))
- [(~+ (list\map class$ exs))]
- (~ (pre_walk_replace replacer body))))
-
- (#OverridenMethod strict_fp? declaration type_vars self_name arguments return_type body exs)
- (let [super_replacer (parser->replacer (<code>.form (do <>.monad
- [_ (<code>.this! (' ::super!))
- args (<code>.tuple (<>.exactly (list.size arguments) <code>.any))]
- (wrap (` ("jvm member invoke special"
- (~ (code.text (product.left (parser.read_class super_class))))
- (~ (code.text name))
- (~' _jvm_this)
- (~+ (|> args
- (list.zip/2 (list\map product.right arguments))
- (list\map ..decorate_input)))))))))]
- (` ("override"
- (~ (declaration$ declaration))
- (~ (code.text name))
- (~ (code.bit strict_fp?))
- [(~+ (list\map annotation$ anns))]
- [(~+ (list\map var$ type_vars))]
- (~ (code.text self_name))
- [(~+ (list\map argument$ arguments))]
- (~ (return$ return_type))
- [(~+ (list\map class$ exs))]
- (~ (|> body
- (pre_walk_replace replacer)
- (pre_walk_replace super_replacer)))
- )))
-
- (#StaticMethod strict_fp? type_vars arguments return_type body exs)
- (` ("static"
- (~ (code.text name))
- (~ (privacy_modifier$ pm))
- (~ (code.bit strict_fp?))
- [(~+ (list\map annotation$ anns))]
- [(~+ (list\map var$ type_vars))]
- [(~+ (list\map class$ exs))]
- [(~+ (list\map argument$ arguments))]
- (~ (return$ return_type))
- (~ (pre_walk_replace replacer body))))
-
- (#AbstractMethod type_vars arguments return_type exs)
- (` ("abstract"
- (~ (code.text name))
- (~ (privacy_modifier$ pm))
- [(~+ (list\map annotation$ anns))]
- [(~+ (list\map var$ type_vars))]
- [(~+ (list\map class$ exs))]
- [(~+ (list\map argument$ arguments))]
- (~ (return$ return_type))))
-
- (#NativeMethod type_vars arguments return_type exs)
- (` ("native"
- (~ (code.text name))
- (~ (privacy_modifier$ pm))
- [(~+ (list\map annotation$ anns))]
- [(~+ (list\map var$ type_vars))]
- [(~+ (list\map class$ exs))]
- [(~+ (list\map argument$ arguments))]
- (~ (return$ return_type))))
- ))
-
-(def: (complete_call$ g!obj [method args])
- (-> Code Partial_Call Code)
- (` ((~ (code.identifier method)) (~+ args) (~ g!obj))))
-
-(def: $Object
- (Type Class)
- (type.class "java.lang.Object" (list)))
-
-(syntax: #export (class:
- {#let [! <>.monad]}
- {im inheritance_modifier^}
- {[full_class_name class_vars] (\ ! map parser.declaration ..declaration^)}
- {super (<>.default $Object
- (class^ class_vars))}
- {interfaces (<>.default (list)
- (<code>.tuple (<>.some (class^ class_vars))))}
- {annotations ..annotations^}
- {fields (<>.some (..field_decl^ class_vars))}
- {methods (<>.some (..method_def^ class_vars))})
- {#.doc (doc "Allows defining JVM classes in Lux code."
- "For example:"
- (class: #final (TestClass A) [Runnable]
- ## Fields
- (#private foo boolean)
- (#private bar A)
- (#private baz java/lang/Object)
- ## Methods
- (#public [] (new [value A]) []
- (exec (:= ::foo #1)
- (:= ::bar value)
- (:= ::baz "")
- []))
- (#public (virtual) java/lang/Object
- "")
- (#public #static (static) java/lang/Object
- "")
- (Runnable [] (run) void
- [])
- )
-
- "The tuple corresponds to parent interfaces."
- "An optional super-class can be specified before the tuple. 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 #1) for modifying it."
- "(::new! []) for calling the class's constructor."
- "(::resolve! container [value]) for calling the 'resolve' method."
- )}
- (do meta.monad
- [current_module meta.current_module_name
- #let [fully_qualified_class_name (name.qualify current_module full_class_name)
- field_parsers (list\map (field->parser fully_qualified_class_name) fields)
- method_parsers (list\map (method->parser fully_qualified_class_name) methods)
- replacer (parser->replacer (list\fold <>.either
- (<>.fail "")
- (list\compose field_parsers method_parsers)))]]
- (wrap (list (` ("jvm class"
- (~ (declaration$ (type.declaration (name.qualify current_module full_class_name) class_vars)))
- (~ (class$ super))
- [(~+ (list\map class$ interfaces))]
- (~ (inheritance_modifier$ im))
- [(~+ (list\map annotation$ annotations))]
- [(~+ (list\map field_decl$ fields))]
- [(~+ (list\map (method_def$ replacer super) methods))]))))))
-
-(syntax: #export (interface:
- {#let [! <>.monad]}
- {[full_class_name class_vars] (\ ! map parser.declaration ..declaration^)}
- {supers (<>.default (list)
- (<code>.tuple (<>.some (class^ class_vars))))}
- {annotations ..annotations^}
- {members (<>.some (..method_decl^ class_vars))})
- {#.doc (doc "Allows defining JVM interfaces."
- (interface: TestInterface
- ([] foo [boolean String] void #throws [Exception])))}
- (do meta.monad
- [current_module meta.current_module_name]
- (wrap (list (` ("jvm class interface"
- (~ (declaration$ (type.declaration (name.qualify current_module full_class_name) class_vars)))
- [(~+ (list\map class$ supers))]
- [(~+ (list\map annotation$ annotations))]
- (~+ (list\map method_decl$ members))))))))
-
-(syntax: #export (object
- {class_vars ..vars^}
- {super (<>.default $Object
- (class^ class_vars))}
- {interfaces (<>.default (list)
- (<code>.tuple (<>.some (class^ class_vars))))}
- {constructor_args (..constructor_args^ class_vars)}
- {methods (<>.some ..overriden_method_def^)})
- {#.doc (doc "Allows defining anonymous classes."
- "The 1st tuple corresponds to class-level type-variables."
- "The 2nd tuple corresponds to parent interfaces."
- "The 3rd tuple corresponds to arguments to the super class constructor."
- "An optional super-class can be specified before the 1st tuple. If not specified, java.lang.Object will be assumed."
- (object [] [Runnable]
- []
- (Runnable [] (run self) void
- (exec (do_something some_value)
- [])))
- )}
- (wrap (list (` ("jvm class anonymous"
- [(~+ (list\map var$ class_vars))]
- (~ (class$ super))
- [(~+ (list\map class$ interfaces))]
- [(~+ (list\map constructor_arg$ constructor_args))]
- [(~+ (list\map (method_def$ function.identity super) methods))])))))
-
-(syntax: #export (null)
- {#.doc (doc "Null object reference."
- (null))}
- (wrap (list (` ("jvm object null")))))
-
-(def: #export (null? obj)
- {#.doc (doc "Test for null object reference."
- (= (null? (null))
- true)
- (= (null? "YOLO")
- false))}
- (-> (primitive "java.lang.Object") Bit)
- ("jvm object null?" obj))
-
-(syntax: #export (??? expr)
- {#.doc (doc "Takes a (potentially null) ObjectType reference and creates a (Maybe ObjectType) for it."
- (= (??? (: java/lang/String (null)))
- #.None)
- (= (??? "YOLO")
- (#.Some "YOLO")))}
- (with_gensyms [g!temp]
- (wrap (list (` (let [(~ g!temp) (~ expr)]
- (if ("jvm object null?" (~ g!temp))
- #.None
- (#.Some (~ g!temp)))))))))
-
-(syntax: #export (!!! expr)
- {#.doc (doc "Takes a (Maybe ObjectType) and returns a ObjectType."
- "A #.None would get translated into a (null)."
- (= (null)
- (!!! (??? (: java/lang/Thread (null)))))
- (= "foo"
- (!!! (??? "foo"))))}
- (with_gensyms [g!value]
- (wrap (list (` ({(#.Some (~ g!value))
- (~ g!value)
-
- #.None
- ("jvm object null")}
- (~ expr)))))))
-
-(syntax: #export (check {class (..type^ (list))}
- {unchecked (<>.maybe <code>.any)})
- {#.doc (doc "Checks whether an object is an instance of a particular class."
- "Caveat emptor: Cannot check for polymorphism, so avoid using parameterized classes."
- (case (check String "YOLO")
- (#.Some value_as_string)
- #.None))}
- (with_gensyms [g!_ g!unchecked]
- (let [class_name (..reflection class)
- class_type (` (.primitive (~ (code.text class_name))))
- check_type (` (.Maybe (~ class_type)))
- check_code (` (if ("jvm object instance?" (~ (code.text class_name)) (~ g!unchecked))
- (#.Some (.:as (~ class_type)
- (~ g!unchecked)))
- #.None))]
- (case unchecked
- (#.Some unchecked)
- (wrap (list (` (: (~ check_type)
- (let [(~ g!unchecked) (~ unchecked)]
- (~ check_code))))))
-
- #.None
- (wrap (list (` (: (-> (primitive "java.lang.Object") (~ check_type))
- (function ((~ g!_) (~ g!unchecked))
- (~ check_code))))))
- ))))
-
-(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 (` ("jvm object synchronized" (~ lock) (~ body))))))
-
-(syntax: #export (do_to obj {methods (<>.some partial_call^)})
- {#.doc (doc "Call a variety of methods on an object. Then, return the object."
- (do_to object
- (ClassName::method1 arg0 arg1 arg2)
- (ClassName::method2 arg3 arg4 arg5)))}
- (with_gensyms [g!obj]
- (wrap (list (` (let [(~ g!obj) (~ obj)]
- (exec (~+ (list\map (complete_call$ g!obj) methods))
- (~ g!obj))))))))
-
-(def: (class_import$ declaration)
- (-> (Type Declaration) Code)
- (let [[full_name params] (parser.declaration declaration)
- def_name (..internal full_name)
- params' (list\map ..var$' params)]
- (` (def: (~ (code.identifier ["" def_name]))
- {#..jvm_class (~ (code.text (..internal full_name)))}
- .Type
- (All [(~+ params')]
- (primitive (~ (code.text full_name))
- [(~+ params')]))))))
-
-(def: (member_type_vars class_tvars member)
- (-> (List (Type Var)) Import_Member_Declaration (List (Type Var)))
- (case member
- (#ConstructorDecl [commons _])
- (list\compose class_tvars (get@ #import_member_tvars commons))
-
- (#MethodDecl [commons _])
- (case (get@ #import_member_kind commons)
- #StaticIMK
- (get@ #import_member_tvars commons)
-
- _
- (list\compose class_tvars (get@ #import_member_tvars commons)))
-
- _
- class_tvars))
-
-(def: (member_def_arg_bindings vars member)
- (-> (List (Type Var)) Import_Member_Declaration (Meta [(List [Bit Code]) (List (Type Value)) (List Code)]))
- (case member
- (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
- (let [(^slots [#import_member_tvars #import_member_args]) commons]
- (do {! meta.monad}
- [arg_inputs (monad.map !
- (: (-> [Bit (Type Value)] (Meta [Bit Code]))
- (function (_ [maybe? _])
- (with_gensyms [arg_name]
- (wrap [maybe? arg_name]))))
- import_member_args)
- #let [input_jvm_types (list\map product.right import_member_args)
- arg_types (list\map (: (-> [Bit (Type Value)] Code)
- (function (_ [maybe? arg])
- (let [arg_type (value_type (get@ #import_member_mode commons) arg)]
- (if maybe?
- (` (Maybe (~ arg_type)))
- arg_type))))
- import_member_args)]]
- (wrap [arg_inputs input_jvm_types arg_types])))
-
- _
- (\ meta.monad wrap [(list) (list) (list)])))
-
-(def: (decorate_return_maybe member never_null? unboxed return_term)
- (-> Import_Member_Declaration Bit (Type Value) Code Code)
- (case member
- (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
- (cond (or never_null?
- (dictionary.key? ..boxes unboxed))
- return_term
-
- (get@ #import_member_maybe? commons)
- (` (??? (~ return_term)))
-
- ## else
- (let [g!temp (` ((~' ~') (~ (code.identifier ["" " Ω "]))))]
- (` (let [(~ g!temp) (~ return_term)]
- (if (not (..null? (:as (primitive "java.lang.Object")
- (~ g!temp))))
- (~ g!temp)
- (error! "Cannot produce null references from method calls."))))))
-
- _
- return_term))
-
-(template [<name> <tag> <term_trans>]
- [(def: (<name> member return_term)
- (-> Import_Member_Declaration Code Code)
- (case member
- (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
- (if (get@ <tag> commons)
- <term_trans>
- return_term)
-
- _
- return_term))]
-
- [decorate_return_try #import_member_try? (` (.try (~ return_term)))]
- [decorate_return_io #import_member_io? (` ((~! io.io) (~ return_term)))]
- )
-
-(def: $String
- (type.class "java.lang.String" (list)))
-
-(template [<input?> <name> <unbox/box> <special+>]
- [(def: (<name> mode [unboxed raw])
- (-> Primitive_Mode [(Type Value) Code] Code)
- (let [[unboxed refined post] (: [(Type Value) Code (List Code)]
- (case mode
- #ManualPrM
- [unboxed raw (list)]
-
- #AutoPrM
- (with_expansions [<special+>' (template.splice <special+>)
- <cond_cases> (template [<old> <new> <pre> <post>]
- [(\ type.equivalence = <old> unboxed)
- (with_expansions [<post>' (template.splice <post>)]
- [<new>
- (` (.|> (~ raw) (~+ <pre>)))
- (list <post>')])]
-
- <special+>')]
- (cond <cond_cases>
- ## else
- [unboxed
- (if <input?>
- (` ("jvm object cast" (~ raw)))
- raw)
- (list)]))))
- unboxed/boxed (case (dictionary.get unboxed ..boxes)
- (#.Some boxed)
- (<unbox/box> unboxed boxed refined)
-
- #.None
- refined)]
- (case post
- #.Nil
- unboxed/boxed
-
- _
- (` (.|> (~ unboxed/boxed) (~+ post))))))]
-
- [#1 auto_convert_input ..unbox
- [[type.boolean type.boolean (list (` (.: .Bit)) (` (.:as (.primitive (~ (code.text box.boolean)))))) []]
- [type.byte type.byte (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long))))) (` ..long_to_byte)) []]
- [type.short type.short (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long))))) (` ..long_to_short)) []]
- [type.int type.int (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long))))) (` ..long_to_int)) []]
- [type.long type.long (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long)))))) []]
- [type.float type.float (list (` (.: .Frac)) (` (.:as (.primitive (~ (code.text box.double))))) (` ..double_to_float)) []]
- [type.double type.double (list (` (.: .Frac)) (` (.:as (.primitive (~ (code.text box.double)))))) []]
- [..$String ..$String (list (` (.: .Text)) (` (.:as (.primitive (~ (code.text (..reflection ..$String))))))) []]
- [(type.class box.boolean (list)) (type.class box.boolean (list)) (list (` (.: .Bit)) (` (.:as (.primitive (~ (code.text box.boolean)))))) []]
- [(type.class box.long (list)) (type.class box.long (list)) (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long)))))) []]
- [(type.class box.double (list)) (type.class box.double (list)) (list (` (.: .Frac)) (` (.:as (.primitive (~ (code.text box.double)))))) []]]]
- [#0 auto_convert_output ..box
- [[type.boolean type.boolean (list) [(` (.: (.primitive (~ (code.text box.boolean))))) (` (.:as .Bit))]]
- [type.byte type.long (list (` "jvm conversion byte-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]]
- [type.short type.long (list (` "jvm conversion short-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]]
- [type.int type.long (list (` "jvm conversion int-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]]
- [type.long type.long (list) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]]
- [type.float type.double (list (` "jvm conversion float-to-double")) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:as .Frac))]]
- [type.double type.double (list) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:as .Frac))]]
- [..$String ..$String (list) [(` (.: (.primitive (~ (code.text (..reflection ..$String)))))) (` (.:as .Text))]]
- [(type.class box.boolean (list)) (type.class box.boolean (list)) (list) [(` (.: (.primitive (~ (code.text box.boolean))))) (` (.:as .Bit))]]
- [(type.class box.long (list)) (type.class box.long (list)) (list) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]]
- [(type.class box.double (list)) (type.class box.double (list)) (list) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:as .Frac))]]]]
- )
-
-(def: (un_quote quoted)
- (-> Code Code)
- (` ((~' ~) (~ quoted))))
-
-(def: (jvm_invoke_inputs mode classes inputs)
- (-> Primitive_Mode (List (Type Value)) (List [Bit Code]) (List Code))
- (|> inputs
- (list.zip/2 classes)
- (list\map (function (_ [class [maybe? input]])
- (|> (if maybe?
- (` (: (.primitive (~ (code.text (..reflection class))))
- ((~! !!!) (~ (un_quote input)))))
- (un_quote input))
- [class]
- (auto_convert_input mode))))))
-
-(def: (import_name format class member)
- (-> Text Text Text Text)
- (|> format
- (text.replace_all "#" class)
- (text.replace_all "." member)))
-
-(def: (member_def_interop vars kind class [arg_function_inputs input_jvm_types arg_types] member method_prefix import_format)
- (-> (List (Type Var)) Class_Kind (Type Declaration) [(List [Bit Code]) (List (Type Value)) (List Code)] Import_Member_Declaration Text Text (Meta (List Code)))
- (let [[full_name class_tvars] (parser.declaration class)]
- (case member
- (#EnumDecl enum_members)
- (do meta.monad
- [#let [enum_type (: Code
- (case class_tvars
- #.Nil
- (` (primitive (~ (code.text full_name))))
-
- _
- (let [=class_tvars (list\map ..var$' class_tvars)]
- (` (All [(~+ =class_tvars)] (primitive (~ (code.text full_name)) [(~+ =class_tvars)]))))))
- getter_interop (: (-> Text Code)
- (function (_ name)
- (let [getter_name (code.identifier ["" (..import_name import_format method_prefix name)])]
- (` (def: (~ getter_name)
- (~ enum_type)
- (~ (get_static_field full_name name)))))))]]
- (wrap (list\map getter_interop enum_members)))
-
- (#ConstructorDecl [commons _])
- (do meta.monad
- [#let [classT (type.class full_name (list))
- def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))])
- jvm_interop (|> [classT
- (` ("jvm member invoke constructor"
- [(~+ (list\map ..var$ class_tvars))]
- (~ (code.text full_name))
- [(~+ (list\map ..var$ (get@ #import_member_tvars commons)))]
- (~+ (|> (jvm_invoke_inputs (get@ #import_member_mode commons) input_jvm_types arg_function_inputs)
- (list.zip/2 input_jvm_types)
- (list\map ..decorate_input)))))]
- (auto_convert_output (get@ #import_member_mode commons))
- (decorate_return_maybe member true classT)
- (decorate_return_try member)
- (decorate_return_io member))]]
- (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs)))
- ((~' wrap) (.list (.` (~ jvm_interop)))))))))
-
- (#MethodDecl [commons method])
- (with_gensyms [g!obj]
- (do meta.monad
- [#let [def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))])
- (^slots [#import_member_kind]) commons
- (^slots [#import_method_name]) method
- [jvm_op object_ast] (: [Text (List Code)]
- (case import_member_kind
- #StaticIMK
- ["jvm member invoke static"
- (list)]
-
- #VirtualIMK
- (case kind
- #Class
- ["jvm member invoke virtual"
- (list g!obj)]
-
- #Interface
- ["jvm member invoke interface"
- (list g!obj)]
- )))
- method_return (get@ #import_method_return method)
- callC (: Code
- (` ((~ (code.text jvm_op))
- [(~+ (list\map ..var$ class_tvars))]
- (~ (code.text full_name))
- (~ (code.text import_method_name))
- [(~+ (list\map ..var$ (get@ #import_member_tvars commons)))]
- (~+ (|> object_ast
- (list\map ..un_quote)
- (list.zip/2 (list (type.class full_name (list))))
- (list\map (auto_convert_input (get@ #import_member_mode commons)))))
- (~+ (|> (jvm_invoke_inputs (get@ #import_member_mode commons) input_jvm_types arg_function_inputs)
- (list.zip/2 input_jvm_types)
- (list\map ..decorate_input))))))
- jvm_interop (: Code
- (case (type.void? method_return)
- (#.Left method_return)
- (|> [method_return
- callC]
- (auto_convert_output (get@ #import_member_mode commons))
- (decorate_return_maybe member false method_return)
- (decorate_return_try member)
- (decorate_return_io member))
-
-
- (#.Right method_return)
- (|> callC
- (decorate_return_try member)
- (decorate_return_io member))))]]
- (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs)) (~+ object_ast))
- ((~' wrap) (.list (.` (~ jvm_interop))))))))))
-
- (#FieldAccessDecl fad)
- (do meta.monad
- [#let [(^open ".") fad
- getter_name (code.identifier ["" (..import_name import_format method_prefix import_field_name)])
- setter_name (code.identifier ["" (..import_name import_format method_prefix (format import_field_name "!"))])]
- getter_interop (with_gensyms [g!obj]
- (let [getter_call (if import_field_static?
- (` ((~ getter_name)))
- (` ((~ getter_name) (~ g!obj))))
- getter_body (<| (auto_convert_output import_field_mode)
- [import_field_type
- (if import_field_static?
- (get_static_field full_name import_field_name)
- (get_virtual_field full_name import_field_name (un_quote g!obj)))])
- getter_body (if import_field_maybe?
- (` ((~! ???) (~ getter_body)))
- getter_body)
- getter_body (if import_field_setter?
- (` ((~! io.io) (~ getter_body)))
- getter_body)]
- (wrap (` ((~! syntax:) (~ getter_call)
- ((~' wrap) (.list (.` (~ getter_body)))))))))
- setter_interop (: (Meta (List Code))
- (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_value (|> [import_field_type (un_quote g!value)]
- (auto_convert_input import_field_mode))
- setter_value (if import_field_maybe?
- (` ((~! !!!) (~ setter_value)))
- setter_value)
- setter_command (format (if import_field_static? "jvm putstatic" "jvm putfield")
- ":" full_name ":" import_field_name)
- g!obj+ (: (List Code)
- (if import_field_static?
- (list)
- (list (un_quote g!obj))))]
- (wrap (list (` ((~! syntax:) (~ setter_call)
- ((~' wrap) (.list (.` ((~! io.io) ((~ (code.text setter_command)) (~+ g!obj+) (~ setter_value))))))))))))
- (wrap (list))))]
- (wrap (list& getter_interop setter_interop)))
- )))
-
-(def: (member_import$ vars kind class [import_format member])
- (-> (List (Type Var)) Class_Kind (Type Declaration) [Text Import_Member_Declaration] (Meta (List Code)))
- (let [[full_name _] (parser.declaration class)
- method_prefix (..internal full_name)]
- (do meta.monad
- [=args (member_def_arg_bindings vars member)]
- (member_def_interop vars kind class =args member method_prefix import_format))))
-
-(def: interface?
- (All [a] (-> (primitive "java.lang.Class" [a]) Bit))
- (|>> ("jvm member invoke virtual" [] "java.lang.Class" "isInterface" [])
- "jvm object cast"
- (: ..Boolean)
- (:as Bit)))
-
-(def: load_class
- (-> External (Try (primitive "java.lang.Class" [Any])))
- (|>> (:as (primitive "java.lang.String"))
- ["Ljava/lang/String;"]
- ("jvm member invoke static" [] "java.lang.Class" "forName" [])
- try))
-
-(def: (class_kind declaration)
- (-> (Type Declaration) (Meta Class_Kind))
- (let [[class_name _] (parser.declaration declaration)]
- (case (load_class class_name)
- (#.Right class)
- (\ meta.monad wrap (if (interface? class)
- #Interface
- #Class))
-
- (#.Left _)
- (meta.fail (format "Unknown class: " class_name)))))
-
-(syntax: #export (import:
- {declaration ..declaration^}
- {#let [[class_name class_type_vars] (parser.declaration declaration)]}
- {bundles (<>.some (..bundle class_type_vars))})
- {#.doc (doc "Allows importing JVM classes, and using them as types."
- "Their methods, fields and enum options can also be imported."
- (import: java/lang/Object
- ["#::."
- (new [])
- (equals [java/lang/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 Try 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)."
- (import: java/lang/String
- ["#::."
- (new [[byte]])
- (#static valueOf [char] java/lang/String)
- (#static valueOf #as int_valueOf [int] java/lang/String)])
-
- (import: (java/util/List e)
- ["#::."
- (size [] int)
- (get [int] e)])
-
- (import: (java/util/ArrayList a)
- ["#::."
- ([T] toArray [[T]] [T])])
-
- "The class-type that is generated is of the fully-qualified name."
- "This avoids a clash between the java.util.List type, and Lux's own List type."
- "All enum options to be imported must be specified."
- (import: java/lang/Character$UnicodeScript
- ["#::."
- (#enum ARABIC CYRILLIC LATIN)])
-
- "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-vars."
- "Lux types, such as Maybe cannot be named (otherwise, they'd be confused for Java classes)."
- (import: (lux/concurrency/promise/JvmPromise A)
- ["#::."
- (resolve [A] boolean)
- (poll [] A)
- (wasResolved [] boolean)
- (waitOn [lux/Function] void)
- (#static [A] make [A] (lux/concurrency/promise/JvmPromise A))])
-
- "Also, the names of the imported members will look like Class::member"
- (java/lang/Object::new [])
- (java/lang/Object::equals [other_object] my_object)
- (java/util/List::size [] my_list)
- java/lang/Character$UnicodeScript::LATIN
- )}
- (do {! meta.monad}
- [kind (class_kind declaration)
- =members (|> bundles
- (list\map (function (_ [import_format members])
- (list\map (|>> [import_format]) members)))
- list.concat
- (monad.map ! (member_import$ class_type_vars kind declaration)))]
- (wrap (list& (class_import$ declaration) (list\join =members)))))
-
-(syntax: #export (array {type (..type^ (list))}
- size)
- {#.doc (doc "Create an array of the given type, with the given size."
- (array java/lang/Object 10))}
- (let [g!size (` (|> (~ size)
- (.: .Nat)
- (.:as (.primitive (~ (code.text box.long))))
- "jvm object cast"
- "jvm conversion long-to-int"))]
- (`` (cond (~~ (template [<primitive> <array_op>]
- [(\ type.equivalence = <primitive> type)
- (wrap (list (` (<array_op> (~ g!size)))))]
-
- [type.boolean "jvm array new boolean"]
- [type.byte "jvm array new byte"]
- [type.short "jvm array new short"]
- [type.int "jvm array new int"]
- [type.long "jvm array new long"]
- [type.float "jvm array new float"]
- [type.double "jvm array new double"]
- [type.char "jvm array new char"]))
- ## else
- (wrap (list (` (: (~ (value_type #ManualPrM (type.array type)))
- ("jvm array new object" (~ g!size))))))))))
-
-(exception: #export (cannot_convert_to_jvm_type {type .Type})
- (exception.report
- ["Lux Type" (%.type type)]))
-
-(with_expansions [<failure> (as_is (meta.fail (exception.construct ..cannot_convert_to_jvm_type [type])))]
- (def: (lux_type->jvm_type type)
- (-> .Type (Meta (Type Value)))
- (if (lux_type\= .Any type)
- (\ meta.monad wrap $Object)
- (case type
- (#.Primitive name params)
- (`` (cond (~~ (template [<type>]
- [(text\= (..reflection <type>) name)
- (case params
- #.Nil
- (\ meta.monad wrap <type>)
-
- _
- <failure>)]
-
- [type.boolean]
- [type.byte]
- [type.short]
- [type.int]
- [type.long]
- [type.float]
- [type.double]
- [type.char]))
-
- (~~ (template [<type>]
- [(text\= (..reflection (type.array <type>)) name)
- (case params
- #.Nil
- (\ meta.monad wrap (type.array <type>))
-
- _
- <failure>)]
-
- [type.boolean]
- [type.byte]
- [type.short]
- [type.int]
- [type.long]
- [type.float]
- [type.double]
- [type.char]))
-
- (text\= array.type_name name)
- (case params
- (#.Cons elementLT #.Nil)
- (\ meta.monad map type.array
- (lux_type->jvm_type elementLT))
-
- _
- <failure>)
-
- (text.starts_with? descriptor.array_prefix name)
- (case params
- #.Nil
- (let [[_ unprefixed] (maybe.assume (text.split_with descriptor.array_prefix name))]
- (\ meta.monad map type.array
- (lux_type->jvm_type (#.Primitive unprefixed (list)))))
-
- _
- <failure>)
-
- ## else
- (\ meta.monad map (type.class name)
- (: (Meta (List (Type Parameter)))
- (monad.map meta.monad
- (function (_ paramLT)
- (do meta.monad
- [paramJT (lux_type->jvm_type paramLT)]
- (case (parser.parameter? paramJT)
- (#.Some paramJT)
- (wrap paramJT)
-
- #.None
- <failure>)))
- params)))))
-
- (#.Apply A F)
- (case (lux_type.apply (list A) F)
- #.None
- <failure>
-
- (#.Some type')
- (lux_type->jvm_type type'))
-
- (#.Named _ type')
- (lux_type->jvm_type type')
-
- _
- <failure>))))
-
-(syntax: #export (array_length array)
- {#.doc (doc "Gives the length of an array."
- (array_length my_array))}
- (case array
- [_ (#.Identifier array_name)]
- (do meta.monad
- [array_type (meta.find_type array_name)
- array_jvm_type (lux_type->jvm_type array_type)
- #let [g!extension (code.text (`` (cond (~~ (template [<primitive> <extension>]
- [(\ type.equivalence =
- (type.array <primitive>)
- array_jvm_type)
- <extension>]
-
- [type.boolean "jvm array length boolean"]
- [type.byte "jvm array length byte"]
- [type.short "jvm array length short"]
- [type.int "jvm array length int"]
- [type.long "jvm array length long"]
- [type.float "jvm array length float"]
- [type.double "jvm array length double"]
- [type.char "jvm array length char"]))
-
- ## else
- "jvm array length object")))]]
- (wrap (list (` (.|> ((~ g!extension) (~ array))
- "jvm conversion int-to-long"
- "jvm object cast"
- (.: (.primitive (~ (code.text box.long))))
- (.:as .Nat))))))
-
- _
- (with_gensyms [g!array]
- (wrap (list (` (let [(~ g!array) (~ array)]
- (..array_length (~ g!array)))))))))
-
-(syntax: #export (array_read idx array)
- {#.doc (doc "Loads an element from an array."
- (array_read 10 my_array))}
- (case array
- [_ (#.Identifier array_name)]
- (do meta.monad
- [array_type (meta.find_type array_name)
- array_jvm_type (lux_type->jvm_type array_type)
- #let [g!idx (` (.|> (~ idx)
- (.: .Nat)
- (.:as (.primitive (~ (code.text box.long))))
- "jvm object cast"
- "jvm conversion long-to-int"))]]
- (`` (cond (~~ (template [<primitive> <extension> <box>]
- [(\ type.equivalence =
- (type.array <primitive>)
- array_jvm_type)
- (wrap (list (` (.|> (<extension> (~ g!idx) (~ array))
- "jvm object cast"
- (.: (.primitive (~ (code.text <box>))))))))]
-
- [type.boolean "jvm array read boolean" box.boolean]
- [type.byte "jvm array read byte" box.byte]
- [type.short "jvm array read short" box.short]
- [type.int "jvm array read int" box.int]
- [type.long "jvm array read long" box.long]
- [type.float "jvm array read float" box.float]
- [type.double "jvm array read double" box.double]
- [type.char "jvm array read char" box.char]))
-
- ## else
- (wrap (list (` ("jvm array read object" (~ g!idx) (~ array))))))))
-
- _
- (with_gensyms [g!array]
- (wrap (list (` (let [(~ g!array) (~ array)]
- (..array_read (~ idx) (~ g!array)))))))))
-
-(syntax: #export (array_write idx value array)
- {#.doc (doc "Stores an element into an array."
- (array_write 10 my_object my_array))}
- (case array
- [_ (#.Identifier array_name)]
- (do meta.monad
- [array_type (meta.find_type array_name)
- array_jvm_type (lux_type->jvm_type array_type)
- #let [g!idx (` (.|> (~ idx)
- (.: .Nat)
- (.:as (.primitive (~ (code.text box.long))))
- "jvm object cast"
- "jvm conversion long-to-int"))]]
- (`` (cond (~~ (template [<primitive> <extension> <box>]
- [(\ type.equivalence =
- (type.array <primitive>)
- array_jvm_type)
- (let [g!value (` (.|> (~ value)
- (.:as (.primitive (~ (code.text <box>))))
- "jvm object cast"))]
- (wrap (list (` (<extension> (~ g!idx) (~ g!value) (~ array))))))]
-
- [type.boolean "jvm array write boolean" box.boolean]
- [type.byte "jvm array write byte" box.byte]
- [type.short "jvm array write short" box.short]
- [type.int "jvm array write int" box.int]
- [type.long "jvm array write long" box.long]
- [type.float "jvm array write float" box.float]
- [type.double "jvm array write double" box.double]
- [type.char "jvm array write char" box.char]))
-
- ## else
- (wrap (list (` ("jvm array write object" (~ g!idx) (~ value) (~ array))))))))
-
- _
- (with_gensyms [g!array]
- (wrap (list (` (let [(~ g!array) (~ array)]
- (..array_write (~ idx) (~ value) (~ g!array)))))))))
-
-(syntax: #export (class_for {type (..type^ (list))})
- {#.doc (doc "Loads the class as a java.lang.Class object."
- (class_for java/lang/String))}
- (wrap (list (` ("jvm object class" (~ (code.text (..reflection type))))))))
-
-(syntax: #export (type {type (..type^ (list))})
- (wrap (list (..value_type #ManualPrM type))))
-
-(exception: #export (cannot_cast_to_non_object {type (Type Value)})
- (exception.report
- ["Signature" (..signature type)]
- ["Reflection" (..reflection type)]))
-
-(syntax: #export (:cast {type (..type^ (list))}
- object)
- (case [(parser.array? type)
- (parser.class? type)]
- (^or [(#.Some _) _] [_ (#.Some _)])
- (wrap (list (` (.: (~ (..value_type #ManualPrM type))
- ("jvm object cast" (~ object))))))
-
- _
- (meta.fail (exception.construct ..cannot_cast_to_non_object [type]))))
diff --git a/stdlib/source/lux/ffi.lua.lux b/stdlib/source/lux/ffi.lua.lux
deleted file mode 100644
index 61ee5b35c..000000000
--- a/stdlib/source/lux/ffi.lua.lux
+++ /dev/null
@@ -1,309 +0,0 @@
-(.module:
- [lux #*
- ["." meta]
- ["@" target]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io]
- ["<>" parser ("#\." monad)
- ["<.>" code (#+ Parser)]]]
- [data
- ["." product]
- ["." maybe]
- ["." text
- ["%" format]]
- [collection
- ["." list ("#\." functor fold)]]]
- [type
- abstract]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]
- ["." template]]])
-
-(abstract: #export (Object brand) Any)
-
-(template [<name>]
- [(with_expansions [<brand> (template.identifier [<name> "'"])]
- (abstract: #export <brand> Any)
- (type: #export <name>
- (..Object <brand>)))]
-
- [Nil]
- [Function]
- [Table]
- )
-
-(template [<name> <type>]
- [(type: #export <name>
- <type>)]
-
- [Boolean Bit]
- [Integer Int]
- [Float Frac]
- [String Text]
- )
-
-(type: Nilable
- [Bit Code])
-
-(def: nilable
- (Parser Nilable)
- (let [token (' #?)]
- (<| (<>.and (<>.parses? (<code>.this! token)))
- (<>.after (<>.not (<code>.this! token)))
- <code>.any)))
-
-(type: Field
- [Bit Text Nilable])
-
-(def: static!
- (Parser Any)
- (<code>.this! (' #static)))
-
-(def: field
- (Parser Field)
- (<code>.form ($_ <>.and
- (<>.parses? ..static!)
- <code>.local_identifier
- ..nilable)))
-
-(def: constant
- (Parser Field)
- (<code>.form ($_ <>.and
- (<>\wrap true)
- <code>.local_identifier
- ..nilable)))
-
-(type: Common_Method
- {#name Text
- #alias (Maybe Text)
- #inputs (List Nilable)
- #io? Bit
- #try? Bit
- #output Nilable})
-
-(type: Static_Method Common_Method)
-(type: Virtual_Method Common_Method)
-
-(type: Method
- (#Static Static_Method)
- (#Virtual Virtual_Method))
-
-(def: common_method
- (Parser Common_Method)
- ($_ <>.and
- <code>.local_identifier
- (<>.maybe (<>.after (<code>.this! (' #as)) <code>.local_identifier))
- (<code>.tuple (<>.some ..nilable))
- (<>.parses? (<code>.this! (' #io)))
- (<>.parses? (<code>.this! (' #try)))
- ..nilable))
-
-(def: static_method
- (<>.after ..static! ..common_method))
-
-(def: method
- (Parser Method)
- (<code>.form (<>.or ..static_method
- ..common_method)))
-
-(type: Member
- (#Field Field)
- (#Method Method))
-
-(def: member
- (Parser Member)
- ($_ <>.or
- ..field
- ..method
- ))
-
-(def: input_variables
- (-> (List Nilable) (List [Bit Code]))
- (|>> list.enumeration
- (list\map (function (_ [idx [nilable? type]])
- [nilable? (|> idx %.nat code.local_identifier)]))))
-
-(def: (nilable_type [nilable? type])
- (-> Nilable Code)
- (if nilable?
- (` (.Maybe (~ type)))
- type))
-
-(def: (with_nil g!temp [nilable? input])
- (-> Code [Bit Code] Code)
- (if nilable?
- (` (case (~ input)
- (#.Some (~ g!temp))
- (~ g!temp)
-
- #.Nil
- ("lua object nil")))
- input))
-
-(def: (without_nil g!temp [nilable? outputT] output)
- (-> Code Nilable Code Code)
- (if nilable?
- (` (let [(~ g!temp) (~ output)]
- (if ("lua object nil?" (~ g!temp))
- #.None
- (#.Some (~ g!temp)))))
- (` (let [(~ g!temp) (~ output)]
- (if (not ("lua object nil?" (~ g!temp)))
- (~ g!temp)
- (.error! "Nil is an invalid value!"))))))
-
-(type: Import
- (#Class [Text Text (List Member)])
- (#Function Static_Method)
- (#Constant Field))
-
-(def: import
- ($_ <>.or
- (<>.and <code>.local_identifier
- (<>.default ["" (list)]
- (<code>.tuple (<>.and <code>.text
- (<>.some member)))))
- (<code>.form ..common_method)
- ..constant
- ))
-
-(def: (with_io with? without)
- (-> Bit Code Code)
- (if with?
- (` (io.io (~ without)))
- without))
-
-(def: (io_type io? rawT)
- (-> Bit Code Code)
- (if io?
- (` (io.IO (~ rawT)))
- rawT))
-
-(def: (with_try with? without_try)
- (-> Bit Code Code)
- (if with?
- (` (.try (~ without_try)))
- without_try))
-
-(def: (try_type try? rawT)
- (-> Bit Code Code)
- (if try?
- (` (.Either .Text (~ rawT)))
- rawT))
-
-(def: (make_function g!method g!temp source inputsT io? try? outputT)
- (-> Code Code Code (List Nilable) Bit Bit Nilable Code)
- (let [g!inputs (input_variables inputsT)]
- (` (def: ((~ g!method)
- [(~+ (list\map product.right g!inputs))])
- (-> [(~+ (list\map nilable_type inputsT))]
- (~ (|> (nilable_type outputT)
- (try_type try?)
- (io_type io?))))
- (:assume
- (~ (<| (with_io io?)
- (with_try try?)
- (without_nil g!temp outputT)
- (` ("lua apply"
- (:as ..Function (~ source))
- (~+ (list\map (with_nil g!temp) g!inputs)))))))))))
-
-(syntax: #export (import: {import ..import})
- (with_gensyms [g!temp]
- (case import
- (#Class [class format members])
- (with_gensyms [g!object]
- (let [qualify (: (-> Text Code)
- (function (_ member_name)
- (|> format
- (text.replace_all "#" class)
- (text.replace_all "." member_name)
- code.local_identifier)))
- g!type (code.local_identifier class)
- real_class (text.replace_all "/" "." class)
- imported (case (text.split_all_with "/" class)
- (#.Cons head tail)
- (list\fold (function (_ sub super)
- (` ("lua object get" (~ (code.text sub))
- (:as (..Object .Any) (~ super)))))
- (` ("lua import" (~ (code.text head))))
- tail)
-
- #.Nil
- (` ("lua import" (~ (code.text class)))))]
- (wrap (list& (` (type: (~ g!type)
- (..Object (primitive (~ (code.text real_class))))))
- (list\map (function (_ member)
- (case member
- (#Field [static? field fieldT])
- (if static?
- (` ((~! syntax:) ((~ (qualify field)))
- (\ (~! meta.monad) (~' wrap)
- (list (` (.:as (~ (nilable_type fieldT))
- ("lua object get" (~ (code.text field))
- (:as (..Object .Any) (~ imported)))))))))
- (` (def: ((~ (qualify field))
- (~ g!object))
- (-> (~ g!type)
- (~ (nilable_type fieldT)))
- (:assume
- (~ (without_nil g!temp fieldT (` ("lua object get" (~ (code.text field))
- (:as (..Object .Any) (~ g!object))))))))))
-
- (#Method method)
- (case method
- (#Static [method alias inputsT io? try? outputT])
- (..make_function (qualify (maybe.default method alias))
- g!temp
- (` ("lua object get" (~ (code.text method))
- (:as (..Object .Any) (~ imported))))
- inputsT
- io?
- try?
- outputT)
-
- (#Virtual [method alias inputsT io? try? outputT])
- (let [g!inputs (input_variables inputsT)]
- (` (def: ((~ (qualify (maybe.default method alias)))
- [(~+ (list\map product.right g!inputs))]
- (~ g!object))
- (-> [(~+ (list\map nilable_type inputsT))]
- (~ g!type)
- (~ (|> (nilable_type outputT)
- (try_type try?)
- (io_type io?))))
- (:assume
- (~ (<| (with_io io?)
- (with_try try?)
- (without_nil g!temp outputT)
- (` ("lua object do"
- (~ (code.text method))
- (~ g!object)
- (~+ (list\map (with_nil g!temp) g!inputs)))))))))))))
- members)))))
-
- (#Function [name alias inputsT io? try? outputT])
- (wrap (list (..make_function (code.local_identifier (maybe.default name alias))
- g!temp
- (` ("lua constant" (~ (code.text (text.replace_all "/" "." name)))))
- inputsT
- io?
- try?
- outputT)))
-
- (#Constant [_ name fieldT])
- (wrap (list (` ((~! syntax:) ((~ (code.local_identifier name)))
- (\ (~! meta.monad) (~' wrap)
- (list (` (.:as (~ (nilable_type fieldT))
- ("lua constant" (~ (code.text (text.replace_all "/" "." name))))))))))))
- )))
-
-(template: #export (closure <inputs> <output>)
- (.:as ..Function
- (`` ("lua function"
- (~~ (template.count <inputs>))
- (.function (_ [<inputs>])
- <output>)))))
diff --git a/stdlib/source/lux/ffi.old.lux b/stdlib/source/lux/ffi.old.lux
deleted file mode 100644
index 9e6a642ed..000000000
--- a/stdlib/source/lux/ffi.old.lux
+++ /dev/null
@@ -1,1828 +0,0 @@
-(.module:
- [lux (#- type interface:)
- ["." type ("#\." equivalence)]
- [abstract
- ["." monad (#+ Monad do)]
- ["." enum]]
- [control
- ["." function]
- ["." io]
- ["." try (#+ Try)]
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- ["." maybe]
- ["." product]
- ["." bit ("#\." codec)]
- ["." text ("#\." equivalence monoid)
- ["%" format (#+ format)]]
- [collection
- ["." array (#+ Array)]
- ["." list ("#\." monad fold monoid)]]]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]]
- ["." meta
- ["." annotation]]])
-
-(template [<name> <op> <from> <to>]
- [(def: #export (<name> value)
- {#.doc (doc "Type converter."
- (: <to>
- (<name> (: <from> foo))))}
- (-> (primitive <from>) (primitive <to>))
- (<op> value))]
-
- [byte_to_long "jvm convert byte-to-long" "java.lang.Byte" "java.lang.Long"]
-
- [short_to_long "jvm convert short-to-long" "java.lang.Short" "java.lang.Long"]
-
- [double_to_int "jvm convert double-to-int" "java.lang.Double" "java.lang.Integer"]
- [double_to_long "jvm convert double-to-long" "java.lang.Double" "java.lang.Long"]
- [double_to_float "jvm convert double-to-float" "java.lang.Double" "java.lang.Float"]
-
- [float_to_int "jvm convert float-to-int" "java.lang.Float" "java.lang.Integer"]
- [float_to_long "jvm convert float-to-long" "java.lang.Float" "java.lang.Long"]
- [float_to_double "jvm convert float-to-double" "java.lang.Float" "java.lang.Double"]
-
- [int_to_byte "jvm convert int-to-byte" "java.lang.Integer" "java.lang.Byte"]
- [int_to_short "jvm convert int-to-short" "java.lang.Integer" "java.lang.Short"]
- [int_to_long "jvm convert int-to-long" "java.lang.Integer" "java.lang.Long"]
- [int_to_float "jvm convert int-to-float" "java.lang.Integer" "java.lang.Float"]
- [int_to_double "jvm convert int-to-double" "java.lang.Integer" "java.lang.Double"]
- [int_to_char "jvm convert int-to-char" "java.lang.Integer" "java.lang.Character"]
-
- [long_to_byte "jvm convert long-to-byte" "java.lang.Long" "java.lang.Byte"]
- [long_to_short "jvm convert long-to-short" "java.lang.Long" "java.lang.Short"]
- [long_to_int "jvm convert long-to-int" "java.lang.Long" "java.lang.Integer"]
- [long_to_float "jvm convert long-to-float" "java.lang.Long" "java.lang.Float"]
- [long_to_double "jvm convert long-to-double" "java.lang.Long" "java.lang.Double"]
-
- [char_to_byte "jvm convert char-to-byte" "java.lang.Character" "java.lang.Byte"]
- [char_to_short "jvm convert char-to-short" "java.lang.Character" "java.lang.Short"]
- [char_to_int "jvm convert char-to-int" "java.lang.Character" "java.lang.Integer"]
- [char_to_long "jvm convert char-to-long" "java.lang.Character" "java.lang.Long"]
- )
-
-## [Utils]
-(def: constructor_method_name "<init>")
-(def: member_separator "::")
-
-## Types
-(type: JVM_Code Text)
-
-(type: BoundKind
- #UpperBound
- #LowerBound)
-
-(type: #rec GenericType
- (#GenericTypeVar Text)
- (#GenericClass [Text (List GenericType)])
- (#GenericArray GenericType)
- (#GenericWildcard (Maybe [BoundKind GenericType])))
-
-(type: Type_Parameter
- [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: Class_Kind
- #Class
- #Interface)
-
-(type: Class_Declaration
- {#class_name Text
- #class_params (List Type_Parameter)})
-
-(type: StackFrame (primitive "java/lang/StackTraceElement"))
-(type: StackTrace (Array StackFrame))
-
-(type: Super_Class_Decl
- {#super_class_name Text
- #super_class_params (List GenericType)})
-
-(type: AnnotationParam
- [Text Code])
-
-(type: Annotation
- {#ann_name Text
- #ann_params (List AnnotationParam)})
-
-(type: Member_Declaration
- {#member_name Text
- #member_privacy PrivacyModifier
- #member_anns (List Annotation)})
-
-(type: FieldDecl
- (#ConstantField GenericType Code)
- (#VariableField StateModifier GenericType))
-
-(type: MethodDecl
- {#method_tvars (List Type_Parameter)
- #method_inputs (List GenericType)
- #method_output GenericType
- #method_exs (List GenericType)})
-
-(type: ArgDecl
- {#arg_name Text
- #arg_type GenericType})
-
-(type: ConstructorArg
- [GenericType Code])
-
-(type: Method_Definition
- (#ConstructorMethod [Bit
- (List Type_Parameter)
- (List ArgDecl)
- (List ConstructorArg)
- Code
- (List GenericType)])
- (#VirtualMethod [Bit
- Bit
- (List Type_Parameter)
- Text
- (List ArgDecl)
- GenericType
- Code
- (List GenericType)])
- (#OverridenMethod [Bit
- Class_Declaration
- (List Type_Parameter)
- Text
- (List ArgDecl)
- GenericType
- Code
- (List GenericType)])
- (#StaticMethod [Bit
- (List Type_Parameter)
- (List ArgDecl)
- GenericType
- Code
- (List GenericType)])
- (#AbstractMethod [(List Type_Parameter)
- (List ArgDecl)
- GenericType
- (List GenericType)])
- (#NativeMethod [(List Type_Parameter)
- (List ArgDecl)
- GenericType
- (List GenericType)]))
-
-(type: Partial_Call
- {#pc_method Name
- #pc_args (List Code)})
-
-(type: ImportMethodKind
- #StaticIMK
- #VirtualIMK)
-
-(type: ImportMethodCommons
- {#import_member_mode Primitive_Mode
- #import_member_alias Text
- #import_member_kind ImportMethodKind
- #import_member_tvars (List Type_Parameter)
- #import_member_args (List [Bit GenericType])
- #import_member_maybe? Bit
- #import_member_try? Bit
- #import_member_io? Bit})
-
-(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? Bit
- #import_field_maybe? Bit
- #import_field_setter? Bit
- #import_field_type GenericType})
-
-(type: Import_Member_Declaration
- (#EnumDecl (List Text))
- (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl])
- (#MethodDecl [ImportMethodCommons ImportMethodDecl])
- (#FieldAccessDecl ImportFieldDecl))
-
-## Utils
-(def: (manual_primitive_to_type class)
- (-> Text (Maybe Code))
- (case class
- (^template [<prim> <type>]
- [<prim>
- (#.Some (' <type>))])
- (["boolean" (primitive "java.lang.Boolean")]
- ["byte" (primitive "java.lang.Byte")]
- ["short" (primitive "java.lang.Short")]
- ["int" (primitive "java.lang.Integer")]
- ["long" (primitive "java.lang.Long")]
- ["float" (primitive "java.lang.Float")]
- ["double" (primitive "java.lang.Double")]
- ["char" (primitive "java.lang.Character")]
- ["void" .Any])
-
- _
- #.None))
-
-(def: (auto_primitive_to_type class)
- (-> Text (Maybe Code))
- (case class
- (^template [<prim> <type>]
- [<prim>
- (#.Some (' <type>))])
- (["boolean" .Bit]
- ["byte" .Int]
- ["short" .Int]
- ["int" .Int]
- ["long" .Int]
- ["float" .Frac]
- ["double" .Frac]
- ["void" .Any])
-
- _
- #.None))
-
-(def: sanitize
- (-> Text Text)
- (text.replace_all "/" "."))
-
-(def: (generic_class_to_type' mode type_params in_array? name+params
- class_to_type')
- (-> Primitive_Mode (List Type_Parameter) Bit [Text (List GenericType)]
- (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code)
- Code)
- (case [name+params mode in_array?]
- (^multi [[prim #.Nil] #ManualPrM #0]
- [(manual_primitive_to_type prim) (#.Some output)])
- output
-
- (^multi [[prim #.Nil] #AutoPrM #0]
- [(auto_primitive_to_type prim) (#.Some output)])
- output
-
- [[name params] _ _]
- (let [name (sanitize name)
- =params (list\map (class_to_type' mode type_params in_array?) params)]
- (` (primitive (~ (code.text name)) [(~+ =params)])))))
-
-(def: (class_to_type' mode type_params in_array? class)
- (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code)
- (case class
- (#GenericTypeVar name)
- (case (list.find (function (_ [pname pbounds])
- (and (text\= name pname)
- (not (list.empty? pbounds))))
- type_params)
- #.None
- (code.identifier ["" name])
-
- (#.Some [pname pbounds])
- (class_to_type' mode type_params in_array? (maybe.assume (list.head pbounds))))
-
- (#GenericClass name+params)
- (generic_class_to_type' mode type_params in_array? name+params
- class_to_type')
-
- (#GenericArray param)
- (let [=param (class_to_type' mode type_params #1 param)]
- (` ((~! array.Array) (~ =param))))
-
- (^or (#GenericWildcard #.None) (#GenericWildcard (#.Some [#LowerBound _])))
- (` .Any)
-
- (#GenericWildcard (#.Some [#UpperBound upper_bound]))
- (class_to_type' mode type_params in_array? upper_bound)
- ))
-
-(def: (class_to_type mode type_params class)
- (-> Primitive_Mode (List Type_Parameter) GenericType Code)
- (class_to_type' mode type_params #0 class))
-
-(def: (type_param_type$ [name bounds])
- (-> Type_Parameter Code)
- (code.identifier ["" name]))
-
-(def: (class_decl_type$ (^slots [#class_name #class_params]))
- (-> Class_Declaration Code)
- (let [=params (list\map (: (-> Type_Parameter Code)
- (function (_ [pname pbounds])
- (case pbounds
- #.Nil
- (code.identifier ["" pname])
-
- (#.Cons bound1 _)
- (class_to_type #ManualPrM class_params bound1))))
- class_params)]
- (` (primitive (~ (code.text (sanitize class_name)))
- [(~+ =params)]))))
-
-(def: type_var_class Text "java.lang.Object")
-
-(def: (simple_class$ env class)
- (-> (List Type_Parameter) GenericType Text)
- (case class
- (#GenericTypeVar name)
- (case (list.find (function (_ [pname pbounds])
- (and (text\= name pname)
- (not (list.empty? pbounds))))
- env)
- #.None
- type_var_class
-
- (#.Some [pname pbounds])
- (simple_class$ env (maybe.assume (list.head pbounds))))
-
- (^or (#GenericWildcard #.None) (#GenericWildcard (#.Some [#LowerBound _])))
- type_var_class
-
- (#GenericWildcard (#.Some [#UpperBound upper_bound]))
- (simple_class$ env upper_bound)
-
- (#GenericClass name env)
- (sanitize name)
-
- (#GenericArray param')
- (case param'
- (#GenericArray param)
- (format "[" (simple_class$ env param))
-
- (^template [<prim> <class>]
- [(#GenericClass <prim> #.Nil)
- <class>])
- (["boolean" "[Z"]
- ["byte" "[B"]
- ["short" "[S"]
- ["int" "[I"]
- ["long" "[J"]
- ["float" "[F"]
- ["double" "[D"]
- ["char" "[C"])
-
- param
- (format "[L" (simple_class$ env param) ";"))
- ))
-
-(def: (make_get_const_parser class_name field_name)
- (-> Text Text (Parser Code))
- (do <>.monad
- [#let [dotted_name (format "::" field_name)]
- _ (<code>.this! (code.identifier ["" dotted_name]))]
- (wrap (`' ((~ (code.text (format "jvm getstatic" ":" class_name ":" field_name))))))))
-
-(def: (make_get_var_parser class_name field_name)
- (-> Text Text (Parser Code))
- (do <>.monad
- [#let [dotted_name (format "::" field_name)]
- _ (<code>.this! (code.identifier ["" dotted_name]))]
- (wrap (`' ((~ (code.text (format "jvm getfield" ":" class_name ":" field_name))) _jvm_this)))))
-
-(def: (make_put_var_parser class_name field_name)
- (-> Text Text (Parser Code))
- (do <>.monad
- [#let [dotted_name (format "::" field_name)]
- [_ _ value] (: (Parser [Any Any Code])
- (<code>.form ($_ <>.and (<code>.this! (' :=)) (<code>.this! (code.identifier ["" dotted_name])) <code>.any)))]
- (wrap (`' ((~ (code.text (format "jvm putfield" ":" class_name ":" field_name))) _jvm_this (~ value))))))
-
-(def: (pre_walk_replace f input)
- (-> (-> Code Code) Code Code)
- (case (f input)
- (^template [<tag>]
- [[meta (<tag> parts)]
- [meta (<tag> (list\map (pre_walk_replace f) parts))]])
- ([#.Form]
- [#.Tuple])
-
- [meta (#.Record pairs)]
- [meta (#.Record (list\map (: (-> [Code Code] [Code Code])
- (function (_ [key val])
- [(pre_walk_replace f key) (pre_walk_replace f val)]))
- pairs))]
-
- ast'
- ast'))
-
-(def: (parser->replacer p ast)
- (-> (Parser Code) (-> Code Code))
- (case (<>.run p (list ast))
- (#.Right [#.Nil ast'])
- ast'
-
- _
- ast
- ))
-
-(def: (field->parser class_name [[field_name _ _] field])
- (-> Text [Member_Declaration FieldDecl] (Parser Code))
- (case field
- (#ConstantField _)
- (make_get_const_parser class_name field_name)
-
- (#VariableField _)
- (<>.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 Type_Parameter) Text (List ArgDecl) (Parser Code))
- (do <>.monad
- [args (: (Parser (List Code))
- (<code>.form (<>.after (<code>.this! (' ::new!))
- (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any)))))
- #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ params)) arg_decls))]]
- (wrap (` ((~ (code.text (format "jvm new" ":" class_name ":" (text.join_with "," arg_decls'))))
- (~+ args))))))
-
-(def: (make_static_method_parser params class_name method_name arg_decls)
- (-> (List Type_Parameter) Text Text (List ArgDecl) (Parser Code))
- (do <>.monad
- [#let [dotted_name (format "::" method_name "!")]
- args (: (Parser (List Code))
- (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name]))
- (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any)))))
- #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ params)) arg_decls))]]
- (wrap (`' ((~ (code.text (format "jvm invokestatic" ":" class_name ":" method_name ":" (text.join_with "," arg_decls'))))
- (~+ args))))))
-
-(template [<name> <jvm_op>]
- [(def: (<name> params class_name method_name arg_decls)
- (-> (List Type_Parameter) Text Text (List ArgDecl) (Parser Code))
- (do <>.monad
- [#let [dotted_name (format "::" method_name "!")]
- args (: (Parser (List Code))
- (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name]))
- (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any)))))
- #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ params)) arg_decls))]]
- (wrap (`' ((~ (code.text (format <jvm_op> ":" class_name ":" method_name ":" (text.join_with "," arg_decls'))))
- (~' _jvm_this) (~+ args))))))]
-
- [make_special_method_parser "jvm invokespecial"]
- [make_virtual_method_parser "jvm invokevirtual"]
- )
-
-(def: (method->parser params class_name [[method_name _ _] meth_def])
- (-> (List Type_Parameter) Text [Member_Declaration Method_Definition] (Parser Code))
- (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 self_name args return_type return_expr exs)
- (#OverridenMethod strict? owner_class type_vars self_name 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)))
-
-## Parsers
-(def: privacy_modifier^
- (Parser PrivacyModifier)
- (let [(^open ".") <>.monad]
- ($_ <>.or
- (<code>.this! (' #public))
- (<code>.this! (' #private))
- (<code>.this! (' #protected))
- (wrap []))))
-
-(def: inheritance_modifier^
- (Parser InheritanceModifier)
- (let [(^open ".") <>.monad]
- ($_ <>.or
- (<code>.this! (' #final))
- (<code>.this! (' #abstract))
- (wrap []))))
-
-(def: bound_kind^
- (Parser BoundKind)
- (<>.or (<code>.this! (' <))
- (<code>.this! (' >))))
-
-(def: (assert_no_periods name)
- (-> Text (Parser Any))
- (<>.assert "Names in class declarations cannot contain periods."
- (not (text.contains? "." name))))
-
-(def: (generic_type^ type_vars)
- (-> (List Type_Parameter) (Parser GenericType))
- (<>.rec
- (function (_ recur^)
- ($_ <>.either
- (do <>.monad
- [_ (<code>.this! (' ?))]
- (wrap (#GenericWildcard #.None)))
- (<code>.tuple (do <>.monad
- [_ (<code>.this! (' ?))
- bound_kind bound_kind^
- bound recur^]
- (wrap (#GenericWildcard (#.Some [bound_kind bound])))))
- (do <>.monad
- [name <code>.local_identifier
- _ (assert_no_periods name)]
- (if (list.member? text.equivalence (list\map product.left type_vars) name)
- (wrap (#GenericTypeVar name))
- (wrap (#GenericClass name (list)))))
- (<code>.tuple (do <>.monad
- [component recur^]
- (case component
- (^template [<class> <name>]
- [(#GenericClass <name> #.Nil)
- (wrap (#GenericClass <class> (list)))])
- (["[Z" "boolean"]
- ["[B" "byte"]
- ["[S" "short"]
- ["[I" "int"]
- ["[J" "long"]
- ["[F" "float"]
- ["[D" "double"]
- ["[C" "char"])
-
- _
- (wrap (#GenericArray component)))))
- (<code>.form (do <>.monad
- [name <code>.local_identifier
- _ (assert_no_periods name)
- params (<>.some recur^)
- _ (<>.assert (format name " cannot be a type-parameter!")
- (not (list.member? text.equivalence (list\map product.left type_vars) name)))]
- (wrap (#GenericClass name params))))
- ))))
-
-(def: type_param^
- (Parser Type_Parameter)
- (<>.either (do <>.monad
- [param_name <code>.local_identifier]
- (wrap [param_name (list)]))
- (<code>.tuple (do <>.monad
- [param_name <code>.local_identifier
- _ (<code>.this! (' <))
- bounds (<>.many (..generic_type^ (list)))]
- (wrap [param_name bounds])))))
-
-(def: type_params^
- (Parser (List Type_Parameter))
- (|> ..type_param^
- <>.some
- <code>.tuple
- (<>.default (list))))
-
-(def: class_decl^
- (Parser Class_Declaration)
- (<>.either (do <>.monad
- [name <code>.local_identifier
- _ (assert_no_periods name)]
- (wrap [name (list)]))
- (<code>.form (do <>.monad
- [name <code>.local_identifier
- _ (assert_no_periods name)
- params (<>.some ..type_param^)]
- (wrap [name params])))
- ))
-
-(def: (super_class_decl^ type_vars)
- (-> (List Type_Parameter) (Parser Super_Class_Decl))
- (<>.either (do <>.monad
- [name <code>.local_identifier
- _ (assert_no_periods name)]
- (wrap [name (list)]))
- (<code>.form (do <>.monad
- [name <code>.local_identifier
- _ (assert_no_periods name)
- params (<>.some (..generic_type^ type_vars))]
- (wrap [name params])))))
-
-(def: annotation_params^
- (Parser (List AnnotationParam))
- (<code>.record (<>.some (<>.and <code>.local_tag <code>.any))))
-
-(def: annotation^
- (Parser Annotation)
- (<>.either (do <>.monad
- [ann_name <code>.local_identifier]
- (wrap [ann_name (list)]))
- (<code>.form (<>.and <code>.local_identifier
- annotation_params^))))
-
-(def: annotations^'
- (Parser (List Annotation))
- (do <>.monad
- [_ (<code>.this! (' #ann))]
- (<code>.tuple (<>.some ..annotation^))))
-
-(def: annotations^
- (Parser (List Annotation))
- (do <>.monad
- [anns?? (<>.maybe ..annotations^')]
- (wrap (maybe.default (list) anns??))))
-
-(def: (throws_decl'^ type_vars)
- (-> (List Type_Parameter) (Parser (List GenericType)))
- (do <>.monad
- [_ (<code>.this! (' #throws))]
- (<code>.tuple (<>.some (..generic_type^ type_vars)))))
-
-(def: (throws_decl^ type_vars)
- (-> (List Type_Parameter) (Parser (List GenericType)))
- (do <>.monad
- [exs? (<>.maybe (throws_decl'^ type_vars))]
- (wrap (maybe.default (list) exs?))))
-
-(def: (method_decl^ type_vars)
- (-> (List Type_Parameter) (Parser [Member_Declaration MethodDecl]))
- (<code>.form (do <>.monad
- [tvars ..type_params^
- name <code>.local_identifier
- anns ..annotations^
- inputs (<code>.tuple (<>.some (..generic_type^ type_vars)))
- output (..generic_type^ type_vars)
- exs (..throws_decl^ type_vars)]
- (wrap [[name #PublicPM anns] {#method_tvars tvars
- #method_inputs inputs
- #method_output output
- #method_exs exs}]))))
-
-(def: state_modifier^
- (Parser StateModifier)
- ($_ <>.or
- (<code>.this! (' #volatile))
- (<code>.this! (' #final))
- (\ <>.monad wrap [])))
-
-(def: (field_decl^ type_vars)
- (-> (List Type_Parameter) (Parser [Member_Declaration FieldDecl]))
- (<>.either (<code>.form (do <>.monad
- [_ (<code>.this! (' #const))
- name <code>.local_identifier
- anns ..annotations^
- type (..generic_type^ type_vars)
- body <code>.any]
- (wrap [[name #PublicPM anns] (#ConstantField [type body])])))
- (<code>.form (do <>.monad
- [pm privacy_modifier^
- sm state_modifier^
- name <code>.local_identifier
- anns ..annotations^
- type (..generic_type^ type_vars)]
- (wrap [[name pm anns] (#VariableField [sm type])])))))
-
-(def: (arg_decl^ type_vars)
- (-> (List Type_Parameter) (Parser ArgDecl))
- (<code>.record (<>.and <code>.local_identifier
- (..generic_type^ type_vars))))
-
-(def: (arg_decls^ type_vars)
- (-> (List Type_Parameter) (Parser (List ArgDecl)))
- (<>.some (arg_decl^ type_vars)))
-
-(def: (constructor_arg^ type_vars)
- (-> (List Type_Parameter) (Parser ConstructorArg))
- (<code>.record (<>.and (..generic_type^ type_vars) <code>.any)))
-
-(def: (constructor_args^ type_vars)
- (-> (List Type_Parameter) (Parser (List ConstructorArg)))
- (<code>.tuple (<>.some (constructor_arg^ type_vars))))
-
-(def: (constructor_method^ class_vars)
- (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition]))
- (<code>.form (do <>.monad
- [pm privacy_modifier^
- strict_fp? (<>.parses? (<code>.this! (' #strict)))
- method_vars ..type_params^
- #let [total_vars (list\compose class_vars method_vars)]
- [_ arg_decls] (<code>.form (<>.and (<code>.this! (' new))
- (..arg_decls^ total_vars)))
- constructor_args (..constructor_args^ total_vars)
- exs (..throws_decl^ total_vars)
- annotations ..annotations^
- body <code>.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^ class_vars)
- (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition]))
- (<code>.form (do <>.monad
- [pm privacy_modifier^
- strict_fp? (<>.parses? (<code>.this! (' #strict)))
- final? (<>.parses? (<code>.this! (' #final)))
- method_vars ..type_params^
- #let [total_vars (list\compose class_vars method_vars)]
- [name this_name arg_decls] (<code>.form ($_ <>.and
- <code>.local_identifier
- <code>.local_identifier
- (..arg_decls^ total_vars)))
- return_type (..generic_type^ total_vars)
- exs (..throws_decl^ total_vars)
- annotations ..annotations^
- body <code>.any]
- (wrap [{#member_name name
- #member_privacy pm
- #member_anns annotations}
- (#VirtualMethod final? strict_fp?
- method_vars
- this_name arg_decls return_type
- body exs)]))))
-
-(def: overriden_method_def^
- (Parser [Member_Declaration Method_Definition])
- (<code>.form (do <>.monad
- [strict_fp? (<>.parses? (<code>.this! (' #strict)))
- owner_class ..class_decl^
- method_vars ..type_params^
- #let [total_vars (list\compose (product.right owner_class) method_vars)]
- [name this_name arg_decls] (<code>.form ($_ <>.and
- <code>.local_identifier
- <code>.local_identifier
- (..arg_decls^ total_vars)))
- return_type (..generic_type^ total_vars)
- exs (..throws_decl^ total_vars)
- annotations ..annotations^
- body <code>.any]
- (wrap [{#member_name name
- #member_privacy #PublicPM
- #member_anns annotations}
- (#OverridenMethod strict_fp?
- owner_class method_vars
- this_name arg_decls return_type
- body exs)]))))
-
-(def: static_method_def^
- (Parser [Member_Declaration Method_Definition])
- (<code>.form (do <>.monad
- [pm privacy_modifier^
- strict_fp? (<>.parses? (<code>.this! (' #strict)))
- _ (<code>.this! (' #static))
- method_vars ..type_params^
- #let [total_vars method_vars]
- [name arg_decls] (<code>.form (<>.and <code>.local_identifier
- (..arg_decls^ total_vars)))
- return_type (..generic_type^ total_vars)
- exs (..throws_decl^ total_vars)
- annotations ..annotations^
- body <code>.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^
- (Parser [Member_Declaration Method_Definition])
- (<code>.form (do <>.monad
- [pm privacy_modifier^
- _ (<code>.this! (' #abstract))
- method_vars ..type_params^
- #let [total_vars method_vars]
- [name arg_decls] (<code>.form (<>.and <code>.local_identifier
- (..arg_decls^ total_vars)))
- return_type (..generic_type^ total_vars)
- exs (..throws_decl^ total_vars)
- annotations ..annotations^]
- (wrap [{#member_name name
- #member_privacy pm
- #member_anns annotations}
- (#AbstractMethod method_vars arg_decls return_type exs)]))))
-
-(def: native_method_def^
- (Parser [Member_Declaration Method_Definition])
- (<code>.form (do <>.monad
- [pm privacy_modifier^
- _ (<code>.this! (' #native))
- method_vars ..type_params^
- #let [total_vars method_vars]
- [name arg_decls] (<code>.form (<>.and <code>.local_identifier
- (..arg_decls^ total_vars)))
- return_type (..generic_type^ total_vars)
- exs (..throws_decl^ total_vars)
- annotations ..annotations^]
- (wrap [{#member_name name
- #member_privacy pm
- #member_anns annotations}
- (#NativeMethod method_vars arg_decls return_type exs)]))))
-
-(def: (method_def^ class_vars)
- (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition]))
- ($_ <>.either
- (..constructor_method^ class_vars)
- (..virtual_method_def^ class_vars)
- ..overriden_method_def^
- ..static_method_def^
- ..abstract_method_def^
- ..native_method_def^))
-
-(def: partial_call^
- (Parser Partial_Call)
- (<code>.form (<>.and <code>.identifier (<>.some <code>.any))))
-
-(def: class_kind^
- (Parser Class_Kind)
- (<>.either (do <>.monad
- [_ (<code>.this! (' #class))]
- (wrap #Class))
- (do <>.monad
- [_ (<code>.this! (' #interface))]
- (wrap #Interface))
- ))
-
-(def: import_member_alias^
- (Parser (Maybe Text))
- (<>.maybe (do <>.monad
- [_ (<code>.this! (' #as))]
- <code>.local_identifier)))
-
-(def: (import_member_args^ type_vars)
- (-> (List Type_Parameter) (Parser (List [Bit GenericType])))
- (<code>.tuple (<>.some (<>.and (<>.parses? (<code>.this! (' #?))) (..generic_type^ type_vars)))))
-
-(def: import_member_return_flags^
- (Parser [Bit Bit Bit])
- ($_ <>.and (<>.parses? (<code>.this! (' #io))) (<>.parses? (<code>.this! (' #try))) (<>.parses? (<code>.this! (' #?)))))
-
-(def: primitive_mode^
- (Parser Primitive_Mode)
- (<>.or (<code>.this! (' #manual))
- (<code>.this! (' #auto))))
-
-(def: (import_member_decl^ owner_vars)
- (-> (List Type_Parameter) (Parser Import_Member_Declaration))
- ($_ <>.either
- (<code>.form (do <>.monad
- [_ (<code>.this! (' #enum))
- enum_members (<>.some <code>.local_identifier)]
- (wrap (#EnumDecl enum_members))))
- (<code>.form (do <>.monad
- [tvars ..type_params^
- _ (<code>.this! (' new))
- ?alias import_member_alias^
- #let [total_vars (list\compose owner_vars tvars)]
- ?prim_mode (<>.maybe primitive_mode^)
- args (..import_member_args^ total_vars)
- [io? try? maybe?] import_member_return_flags^]
- (wrap (#ConstructorDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode)
- #import_member_alias (maybe.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?}
- {}]))
- ))
- (<code>.form (do <>.monad
- [kind (: (Parser ImportMethodKind)
- (<>.or (<code>.this! (' #static))
- (wrap [])))
- tvars ..type_params^
- name <code>.local_identifier
- ?alias import_member_alias^
- #let [total_vars (list\compose owner_vars tvars)]
- ?prim_mode (<>.maybe primitive_mode^)
- args (..import_member_args^ total_vars)
- [io? try? maybe?] import_member_return_flags^
- return (..generic_type^ total_vars)]
- (wrap (#MethodDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode)
- #import_member_alias (maybe.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
- }]))))
- (<code>.form (do <>.monad
- [static? (<>.parses? (<code>.this! (' #static)))
- name <code>.local_identifier
- ?prim_mode (<>.maybe primitive_mode^)
- gtype (..generic_type^ owner_vars)
- maybe? (<>.parses? (<code>.this! (' #?)))
- setter? (<>.parses? (<code>.this! (' #!)))]
- (wrap (#FieldAccessDecl {#import_field_mode (maybe.default #AutoPrM ?prim_mode)
- #import_field_name name
- #import_field_static? static?
- #import_field_maybe? maybe?
- #import_field_setter? setter?
- #import_field_type gtype}))))
- ))
-
-(def: bundle
- (-> (List Type_Parameter) (Parser [Text (List Import_Member_Declaration)]))
- (|>> ..import_member_decl^
- <>.some
- (<>.and <code>.text)
- <code>.tuple))
-
-## Generators
-(def: with_parens
- (-> JVM_Code JVM_Code)
- (text.enclose ["(" ")"]))
-
-(def: with_brackets
- (-> JVM_Code JVM_Code)
- (text.enclose ["[" "]"]))
-
-(def: spaced
- (-> (List JVM_Code) JVM_Code)
- (text.join_with " "))
-
-(def: (privacy_modifier$ pm)
- (-> PrivacyModifier JVM_Code)
- (case pm
- #PublicPM "public"
- #PrivatePM "private"
- #ProtectedPM "protected"
- #DefaultPM "default"))
-
-(def: (inheritance_modifier$ im)
- (-> InheritanceModifier JVM_Code)
- (case im
- #FinalIM "final"
- #AbstractIM "abstract"
- #DefaultIM "default"))
-
-(def: (annotation_param$ [name value])
- (-> AnnotationParam JVM_Code)
- (format name "=" (code.format value)))
-
-(def: (annotation$ [name params])
- (-> Annotation JVM_Code)
- (format "(" name " " "{" (text.join_with text.tab (list\map annotation_param$ params)) "}" ")"))
-
-(def: (bound_kind$ kind)
- (-> BoundKind JVM_Code)
- (case kind
- #UpperBound "<"
- #LowerBound ">"))
-
-(def: (generic_type$ gtype)
- (-> GenericType JVM_Code)
- (case gtype
- (#GenericTypeVar name)
- name
-
- (#GenericClass name params)
- (format "(" (sanitize name) " " (spaced (list\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])
- (-> Type_Parameter JVM_Code)
- (format "(" name " " (spaced (list\map generic_type$ bounds)) ")"))
-
-(def: (class_decl$ (^open "."))
- (-> Class_Declaration JVM_Code)
- (format "(" (sanitize class_name) " " (spaced (list\map type_param$ class_params)) ")"))
-
-(def: (super_class_decl$ (^slots [#super_class_name #super_class_params]))
- (-> Super_Class_Decl JVM_Code)
- (format "(" (sanitize super_class_name) " " (spaced (list\map generic_type$ super_class_params)) ")"))
-
-(def: (method_decl$ [[name pm anns] method_decl])
- (-> [Member_Declaration MethodDecl] JVM_Code)
- (let [(^slots [#method_tvars #method_inputs #method_output #method_exs]) method_decl]
- (with_parens
- (spaced (list name
- (with_brackets (spaced (list\map annotation$ anns)))
- (with_brackets (spaced (list\map type_param$ method_tvars)))
- (with_brackets (spaced (list\map generic_type$ method_exs)))
- (with_brackets (spaced (list\map generic_type$ method_inputs)))
- (generic_type$ method_output))
- ))))
-
-(def: (state_modifier$ sm)
- (-> StateModifier JVM_Code)
- (case sm
- #VolatileSM "volatile"
- #FinalSM "final"
- #DefaultSM "default"))
-
-(def: (field_decl$ [[name pm anns] field])
- (-> [Member_Declaration FieldDecl] JVM_Code)
- (case field
- (#ConstantField class value)
- (with_parens
- (spaced (list "constant" name
- (with_brackets (spaced (list\map annotation$ anns)))
- (generic_type$ class)
- (code.format value))
- ))
-
- (#VariableField sm class)
- (with_parens
- (spaced (list "variable" name
- (privacy_modifier$ pm)
- (state_modifier$ sm)
- (with_brackets (spaced (list\map annotation$ anns)))
- (generic_type$ class))
- ))
- ))
-
-(def: (arg_decl$ [name type])
- (-> ArgDecl JVM_Code)
- (with_parens
- (spaced (list name (generic_type$ type)))))
-
-(def: (constructor_arg$ [class term])
- (-> ConstructorArg JVM_Code)
- (with_brackets
- (spaced (list (generic_type$ class) (code.format term)))))
-
-(def: (method_def$ replacer super_class [[name pm anns] method_def])
- (-> (-> Code Code) Super_Class_Decl [Member_Declaration Method_Definition] JVM_Code)
- (case method_def
- (#ConstructorMethod strict_fp? type_vars arg_decls constructor_args body exs)
- (with_parens
- (spaced (list "init"
- (privacy_modifier$ pm)
- (bit\encode strict_fp?)
- (with_brackets (spaced (list\map annotation$ anns)))
- (with_brackets (spaced (list\map type_param$ type_vars)))
- (with_brackets (spaced (list\map generic_type$ exs)))
- (with_brackets (spaced (list\map arg_decl$ arg_decls)))
- (with_brackets (spaced (list\map constructor_arg$ constructor_args)))
- (code.format (pre_walk_replace replacer body))
- )))
-
- (#VirtualMethod final? strict_fp? type_vars this_name arg_decls return_type body exs)
- (with_parens
- (spaced (list "virtual"
- name
- (privacy_modifier$ pm)
- (bit\encode final?)
- (bit\encode strict_fp?)
- (with_brackets (spaced (list\map annotation$ anns)))
- (with_brackets (spaced (list\map type_param$ type_vars)))
- (with_brackets (spaced (list\map generic_type$ exs)))
- (with_brackets (spaced (list\map arg_decl$ arg_decls)))
- (generic_type$ return_type)
- (code.format (pre_walk_replace replacer (` (let [(~ (code.local_identifier this_name)) (~' _jvm_this)]
- (~ body))))))))
-
- (#OverridenMethod strict_fp? class_decl type_vars this_name arg_decls return_type body exs)
- (let [super_replacer (parser->replacer (<code>.form (do <>.monad
- [_ (<code>.this! (' ::super!))
- args (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any))
- #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ (list)))
- arg_decls))]]
- (wrap (`' ((~ (code.text (format "jvm 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
- (bit\encode strict_fp?)
- (with_brackets (spaced (list\map annotation$ anns)))
- (with_brackets (spaced (list\map type_param$ type_vars)))
- (with_brackets (spaced (list\map generic_type$ exs)))
- (with_brackets (spaced (list\map arg_decl$ arg_decls)))
- (generic_type$ return_type)
- (|> (` (let [(~ (code.local_identifier this_name)) (~' _jvm_this)]
- (~ body)))
- (pre_walk_replace replacer)
- (pre_walk_replace super_replacer)
- (code.format))
- ))))
-
- (#StaticMethod strict_fp? type_vars arg_decls return_type body exs)
- (with_parens
- (spaced (list "static"
- name
- (privacy_modifier$ pm)
- (bit\encode strict_fp?)
- (with_brackets (spaced (list\map annotation$ anns)))
- (with_brackets (spaced (list\map type_param$ type_vars)))
- (with_brackets (spaced (list\map generic_type$ exs)))
- (with_brackets (spaced (list\map arg_decl$ arg_decls)))
- (generic_type$ return_type)
- (code.format (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 (list\map annotation$ anns)))
- (with_brackets (spaced (list\map type_param$ type_vars)))
- (with_brackets (spaced (list\map generic_type$ exs)))
- (with_brackets (spaced (list\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 (list\map annotation$ anns)))
- (with_brackets (spaced (list\map type_param$ type_vars)))
- (with_brackets (spaced (list\map generic_type$ exs)))
- (with_brackets (spaced (list\map arg_decl$ arg_decls)))
- (generic_type$ return_type))))
- ))
-
-(def: (complete_call$ g!obj [method args])
- (-> Code Partial_Call Code)
- (` ((~ (code.identifier method)) (~+ args) (~ g!obj))))
-
-## [Syntax]
-(def: object_super_class
- Super_Class_Decl
- {#super_class_name "java/lang/Object"
- #super_class_params (list)})
-
-(syntax: #export (class:
- {im inheritance_modifier^}
- {class_decl ..class_decl^}
- {#let [full_class_name (product.left class_decl)]}
- {#let [class_vars (product.right class_decl)]}
- {super (<>.default object_super_class
- (..super_class_decl^ class_vars))}
- {interfaces (<>.default (list)
- (<code>.tuple (<>.some (..super_class_decl^ class_vars))))}
- {annotations ..annotations^}
- {fields (<>.some (..field_decl^ class_vars))}
- {methods (<>.some (..method_def^ class_vars))})
- {#.doc (doc "Allows defining JVM classes in Lux code."
- "For example:"
- (class: #final (TestClass A) [Runnable]
- ## Fields
- (#private foo boolean)
- (#private bar A)
- (#private baz java/lang/Object)
- ## Methods
- (#public [] (new [value A]) []
- (exec (:= ::foo #1)
- (:= ::bar value)
- (:= ::baz "")
- []))
- (#public (virtual) java/lang/Object
- "")
- (#public #static (static) java/lang/Object
- "")
- (Runnable [] (run) void
- [])
- )
-
- "The tuple corresponds to parent interfaces."
- "An optional super-class can be specified before the tuple. 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 #1) for modifying it."
- "(::new! []) for calling the class's constructor."
- "(::resolve! container [value]) for calling the 'resolve' method."
- )}
- (do meta.monad
- [current_module meta.current_module_name
- #let [fully_qualified_class_name (format (sanitize current_module) "." full_class_name)
- field_parsers (list\map (field->parser fully_qualified_class_name) fields)
- method_parsers (list\map (method->parser (product.right class_decl) fully_qualified_class_name) methods)
- replacer (parser->replacer (list\fold <>.either
- (<>.fail "")
- (list\compose field_parsers method_parsers)))
- def_code (format "jvm class:"
- (spaced (list (class_decl$ class_decl)
- (super_class_decl$ super)
- (with_brackets (spaced (list\map super_class_decl$ interfaces)))
- (inheritance_modifier$ im)
- (with_brackets (spaced (list\map annotation$ annotations)))
- (with_brackets (spaced (list\map field_decl$ fields)))
- (with_brackets (spaced (list\map (method_def$ replacer super) methods))))))]]
- (wrap (list (` ((~ (code.text def_code))))))))
-
-(syntax: #export (interface:
- {class_decl ..class_decl^}
- {#let [class_vars (product.right class_decl)]}
- {supers (<>.default (list)
- (<code>.tuple (<>.some (..super_class_decl^ class_vars))))}
- {annotations ..annotations^}
- {members (<>.some (..method_decl^ class_vars))})
- {#.doc (doc "Allows defining JVM interfaces."
- (interface: TestInterface
- ([] foo [boolean String] void #throws [Exception])))}
- (let [def_code (format "jvm interface:"
- (spaced (list (class_decl$ class_decl)
- (with_brackets (spaced (list\map super_class_decl$ supers)))
- (with_brackets (spaced (list\map annotation$ annotations)))
- (spaced (list\map method_decl$ members)))))]
- (wrap (list (` ((~ (code.text def_code))))))
- ))
-
-(syntax: #export (object
- {class_vars (<code>.tuple (<>.some ..type_param^))}
- {super (<>.default object_super_class
- (..super_class_decl^ class_vars))}
- {interfaces (<>.default (list)
- (<code>.tuple (<>.some (..super_class_decl^ class_vars))))}
- {constructor_args (..constructor_args^ class_vars)}
- {methods (<>.some ..overriden_method_def^)})
- {#.doc (doc "Allows defining anonymous classes."
- "The 1st tuple corresponds to class-level type-variables."
- "The 2nd tuple corresponds to parent interfaces."
- "The 3rd tuple corresponds to arguments to the super class constructor."
- "An optional super-class can be specified before the 1st tuple. If not specified, java.lang.Object will be assumed."
- (object [] [Runnable]
- []
- (Runnable [] (run self) void
- (exec (do_something some_value)
- [])))
- )}
- (let [def_code (format "jvm anon-class:"
- (spaced (list (super_class_decl$ super)
- (with_brackets (spaced (list\map super_class_decl$ interfaces)))
- (with_brackets (spaced (list\map constructor_arg$ constructor_args)))
- (with_brackets (spaced (list\map (method_def$ function.identity super) methods))))))]
- (wrap (list (` ((~ (code.text def_code))))))))
-
-(syntax: #export (null)
- {#.doc (doc "Null object reference."
- (null))}
- (wrap (list (` ("jvm object null")))))
-
-(def: #export (null? obj)
- {#.doc (doc "Test for null object reference."
- (= (null? (null))
- true)
- (= (null? "YOLO")
- false))}
- (-> (primitive "java.lang.Object") Bit)
- ("jvm object null?" obj))
-
-(syntax: #export (??? expr)
- {#.doc (doc "Takes a (potentially null) ObjectType reference and creates a (Maybe ObjectType) for it."
- (= (??? (: java/lang/String (null)))
- #.None)
- (= (??? "YOLO")
- (#.Some "YOLO")))}
- (with_gensyms [g!temp]
- (wrap (list (` (let [(~ g!temp) (~ expr)]
- (if ("jvm object null?" (~ g!temp))
- #.None
- (#.Some (~ g!temp)))))))))
-
-(syntax: #export (!!! expr)
- {#.doc (doc "Takes a (Maybe ObjectType) and returns a ObjectType."
- "A #.None would get translated into a (null)."
- (= (null)
- (!!! (??? (: java/lang/Thread (null)))))
- (= "foo"
- (!!! (??? "foo"))))}
- (with_gensyms [g!value]
- (wrap (list (` ({(#.Some (~ g!value))
- (~ g!value)
-
- #.None
- ("jvm object null")}
- (~ expr)))))))
-
-(syntax: #export (check {class (..generic_type^ (list))}
- {unchecked (<>.maybe <code>.any)})
- {#.doc (doc "Checks whether an object is an instance of a particular class."
- "Caveat emptor: Cannot check for polymorphism, so avoid using parameterized classes."
- (case (check java/lang/String "YOLO")
- (#.Some value_as_string)
- #.None))}
- (with_gensyms [g!_ g!unchecked]
- (let [class_name (simple_class$ (list) class)
- class_type (` (.primitive (~ (code.text class_name))))
- check_type (` (.Maybe (~ class_type)))
- check_code (` (if ((~ (code.text (format "jvm instanceof" ":" class_name))) (~ g!unchecked))
- (#.Some (.:as (~ class_type)
- (~ g!unchecked)))
- #.None))]
- (case unchecked
- (#.Some unchecked)
- (wrap (list (` (: (~ check_type)
- (let [(~ g!unchecked) (~ unchecked)]
- (~ check_code))))))
-
- #.None
- (wrap (list (` (: (-> (primitive "java.lang.Object") (~ check_type))
- (function ((~ g!_) (~ g!unchecked))
- (~ check_code))))))
- ))))
-
-(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 (` ("jvm object synchronized" (~ lock) (~ body))))))
-
-(syntax: #export (do_to obj {methods (<>.some partial_call^)})
- {#.doc (doc "Call a variety of methods on an object. Then, return the object."
- (do_to object
- (ClassName::method1 arg0 arg1 arg2)
- (ClassName::method2 arg3 arg4 arg5)))}
- (with_gensyms [g!obj]
- (wrap (list (` (let [(~ g!obj) (~ obj)]
- (exec (~+ (list\map (complete_call$ g!obj) methods))
- (~ g!obj))))))))
-
-(def: (class_import$ [full_name params])
- (-> Class_Declaration Code)
- (let [params' (list\map (|>> product.left code.local_identifier) params)]
- (` (def: (~ (code.identifier ["" full_name]))
- {#..jvm_class (~ (code.text full_name))}
- Type
- (All [(~+ params')]
- (primitive (~ (code.text (sanitize full_name)))
- [(~+ params')]))))))
-
-(def: (member_type_vars class_tvars member)
- (-> (List Type_Parameter) Import_Member_Declaration (List Type_Parameter))
- (case member
- (#ConstructorDecl [commons _])
- (list\compose class_tvars (get@ #import_member_tvars commons))
-
- (#MethodDecl [commons _])
- (case (get@ #import_member_kind commons)
- #StaticIMK
- (get@ #import_member_tvars commons)
-
- _
- (list\compose class_tvars (get@ #import_member_tvars commons)))
-
- _
- class_tvars))
-
-(def: (member_def_arg_bindings type_params class member)
- (-> (List Type_Parameter) Class_Declaration Import_Member_Declaration (Meta [(List [Bit Code]) (List Text) (List Code)]))
- (case member
- (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
- (let [(^slots [#import_member_tvars #import_member_args]) commons]
- (do {! meta.monad}
- [arg_inputs (monad.map !
- (: (-> [Bit GenericType] (Meta [Bit Code]))
- (function (_ [maybe? _])
- (with_gensyms [arg_name]
- (wrap [maybe? arg_name]))))
- import_member_args)
- #let [arg_classes (: (List Text)
- (list\map (|>> product.right (simple_class$ (list\compose type_params import_member_tvars)))
- import_member_args))
- arg_types (list\map (: (-> [Bit GenericType] Code)
- (function (_ [maybe? arg])
- (let [arg_type (class_to_type (get@ #import_member_mode commons) type_params arg)]
- (if maybe?
- (` (Maybe (~ arg_type)))
- arg_type))))
- import_member_args)]]
- (wrap [arg_inputs arg_classes arg_types])))
-
- _
- (\ meta.monad wrap [(list) (list) (list)])))
-
-(def: (decorate_return_maybe class member return_term)
- (-> Class_Declaration Import_Member_Declaration Code Code)
- (case member
- (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
- (if (get@ #import_member_maybe? commons)
- (` (??? (~ return_term)))
- (let [g!temp (` ((~' ~') (~ (code.identifier ["" " Ω "]))))]
- (` (let [(~ g!temp) (~ return_term)]
- (if (not (..null? (:as (primitive "java.lang.Object")
- (~ g!temp))))
- (~ g!temp)
- (error! (~ (code.text (format "Cannot produce null references from method calls @ "
- (get@ #class_name class)
- "." (get@ #import_member_alias commons))))))))))
-
- _
- return_term))
-
-(template [<name> <tag> <term_trans>]
- [(def: (<name> member return_term)
- (-> Import_Member_Declaration Code Code)
- (case member
- (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
- (if (get@ <tag> commons)
- <term_trans>
- return_term)
-
- _
- return_term))]
-
- [decorate_return_try #import_member_try? (` (.try (~ return_term)))]
- [decorate_return_io #import_member_io? (` ((~! io.io) (~ return_term)))]
- )
-
-(def: (free_type_param? [name bounds])
- (-> Type_Parameter Bit)
- (case bounds
- #.Nil #1
- _ #0))
-
-(def: (type_param->type_arg [name _])
- (-> Type_Parameter Code)
- (code.identifier ["" name]))
-
-(template [<name> <byte> <short> <int> <float>]
- [(def: (<name> mode [class expression])
- (-> Primitive_Mode [Text Code] Code)
- (case mode
- #ManualPrM
- expression
-
- #AutoPrM
- (case class
- "byte" (` (<byte> (~ expression)))
- "short" (` (<short> (~ expression)))
- "int" (` (<int> (~ expression)))
- "float" (` (<float> (~ expression)))
- _ expression)))]
-
- [auto_convert_input long_to_byte long_to_short long_to_int double_to_float]
- [auto_convert_output byte_to_long short_to_long int_to_long float_to_double]
- )
-
-(def: (un_quote quoted)
- (-> Code Code)
- (` ((~' ~) (~ quoted))))
-
-(def: (jvm_extension_inputs mode classes inputs)
- (-> Primitive_Mode (List Text) (List [Bit Code]) (List Code))
- (|> inputs
- (list\map (function (_ [maybe? input])
- (if maybe?
- (` ((~! !!!) (~ (un_quote input))))
- (un_quote input))))
- (list.zip/2 classes)
- (list\map (auto_convert_input mode))))
-
-(def: (import_name format class member)
- (-> Text Text Text Text)
- (|> format
- (text.replace_all "#" class)
- (text.replace_all "." member)))
-
-(def: (member_def_interop type_params kind class [arg_function_inputs arg_classes arg_types] member method_prefix import_format)
- (-> (List Type_Parameter) Class_Kind Class_Declaration [(List [Bit Code]) (List Text) (List Code)] Import_Member_Declaration Text Text (Meta (List Code)))
- (let [[full_name class_tvars] class
- full_name (sanitize full_name)
- all_params (|> (member_type_vars class_tvars member)
- (list.filter free_type_param?)
- (list\map type_param->type_arg))]
- (case member
- (#EnumDecl enum_members)
- (do {! meta.monad}
- [#let [enum_type (: Code
- (case class_tvars
- #.Nil
- (` (primitive (~ (code.text full_name))))
-
- _
- (let [=class_tvars (|> class_tvars
- (list.filter free_type_param?)
- (list\map type_param->type_arg))]
- (` (All [(~+ =class_tvars)] (primitive (~ (code.text full_name)) [(~+ =class_tvars)]))))))
- getter_interop (: (-> Text Code)
- (function (_ name)
- (let [getter_name (code.identifier ["" (..import_name import_format method_prefix name)])]
- (` (def: (~ getter_name)
- (~ enum_type)
- ((~ (code.text (format "jvm getstatic" ":" full_name ":" name)))))))))]]
- (wrap (list\map getter_interop enum_members)))
-
- (#ConstructorDecl [commons _])
- (do meta.monad
- [#let [def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))])
- jvm_extension (code.text (format "jvm new" ":" full_name ":" (text.join_with "," arg_classes)))
- jvm_interop (|> (` ((~ jvm_extension)
- (~+ (jvm_extension_inputs (get@ #import_member_mode commons) arg_classes arg_function_inputs))))
- (decorate_return_maybe class member)
- (decorate_return_try member)
- (decorate_return_io member))]]
- (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs)))
- ((~' wrap) (.list (.` (~ jvm_interop)))))))))
-
- (#MethodDecl [commons method])
- (with_gensyms [g!obj]
- (do meta.monad
- [#let [def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))])
- (^slots [#import_member_kind]) commons
- (^slots [#import_method_name]) method
- [jvm_op object_ast] (: [Text (List Code)]
- (case import_member_kind
- #StaticIMK
- ["invokestatic"
- (list)]
-
- #VirtualIMK
- (case kind
- #Class
- ["invokevirtual"
- (list g!obj)]
-
- #Interface
- ["invokeinterface"
- (list g!obj)]
- )))
- jvm_extension (code.text (format "jvm " jvm_op ":" full_name ":" import_method_name ":" (text.join_with "," arg_classes)))
- jvm_interop (|> [(simple_class$ (list) (get@ #import_method_return method))
- (` ((~ jvm_extension) (~+ (list\map un_quote object_ast))
- (~+ (jvm_extension_inputs (get@ #import_member_mode commons) arg_classes arg_function_inputs))))]
- (auto_convert_output (get@ #import_member_mode commons))
- (decorate_return_maybe class member)
- (decorate_return_try member)
- (decorate_return_io member))]]
- (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs)) (~+ object_ast))
- ((~' wrap) (.list (.` (~ jvm_interop))))))))))
-
- (#FieldAccessDecl fad)
- (do meta.monad
- [#let [(^open ".") fad
- base_gtype (class_to_type import_field_mode type_params import_field_type)
- classC (class_decl_type$ class)
- typeC (if import_field_maybe?
- (` (Maybe (~ base_gtype)))
- base_gtype)
- tvar_asts (: (List Code)
- (|> class_tvars
- (list.filter free_type_param?)
- (list\map type_param->type_arg)))
- getter_name (code.identifier ["" (..import_name import_format method_prefix import_field_name)])
- setter_name (code.identifier ["" (..import_name import_format method_prefix (format import_field_name "!"))])]
- getter_interop (with_gensyms [g!obj]
- (let [getter_call (if import_field_static?
- (` ((~ getter_name)))
- (` ((~ getter_name) (~ g!obj))))
- getter_body (<| (auto_convert_output import_field_mode)
- [(simple_class$ (list) import_field_type)
- (if import_field_static?
- (let [jvm_extension (code.text (format "jvm getstatic" ":" full_name ":" import_field_name))]
- (` ((~ jvm_extension))))
- (let [jvm_extension (code.text (format "jvm getfield" ":" full_name ":" import_field_name))]
- (` ((~ jvm_extension) (~ (un_quote g!obj))))))])
- getter_body (if import_field_maybe?
- (` ((~! ???) (~ getter_body)))
- getter_body)
- getter_body (if import_field_setter?
- (` ((~! io.io) (~ getter_body)))
- getter_body)]
- (wrap (` ((~! syntax:) (~ getter_call)
- ((~' wrap) (.list (.` (~ getter_body)))))))))
- setter_interop (: (Meta (List Code))
- (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_value (auto_convert_input import_field_mode
- [(simple_class$ (list) import_field_type) (un_quote g!value)])
- setter_value (if import_field_maybe?
- (` ((~! !!!) (~ setter_value)))
- setter_value)
- setter_command (format (if import_field_static? "jvm putstatic" "jvm putfield")
- ":" full_name ":" import_field_name)
- g!obj+ (: (List Code)
- (if import_field_static?
- (list)
- (list (un_quote g!obj))))]
- (wrap (list (` ((~! syntax:) (~ setter_call)
- ((~' wrap) (.list (.` ((~! io.io) ((~ (code.text setter_command)) (~+ g!obj+) (~ setter_value))))))))))))
- (wrap (list))))]
- (wrap (list& getter_interop setter_interop)))
- )))
-
-(def: (member_import$ type_params kind class [import_format member])
- (-> (List Type_Parameter) Class_Kind Class_Declaration [Text Import_Member_Declaration] (Meta (List Code)))
- (let [[method_prefix _] class]
- (do meta.monad
- [=args (member_def_arg_bindings type_params class member)]
- (member_def_interop type_params kind class =args member method_prefix import_format))))
-
-(type: (java/lang/Class a)
- (primitive "java.lang.Class" [a]))
-
-(def: interface?
- (All [a] (-> (java/lang/Class a) Bit))
- (|>> "jvm invokevirtual:java.lang.Class:isInterface:"))
-
-(def: (load_class class_name)
- (-> Text (Try (java/lang/Class Any)))
- (try ("jvm invokestatic:java.lang.Class:forName:java.lang.String" class_name)))
-
-(def: (class_kind [class_name _])
- (-> Class_Declaration (Meta Class_Kind))
- (let [class_name (..sanitize class_name)]
- (case (..load_class class_name)
- (#try.Success class)
- (\ meta.monad wrap (if (interface? class)
- #Interface
- #Class))
-
- (#try.Failure error)
- (meta.fail (format "Cannot load class: " class_name text.new_line
- error)))))
-
-(syntax: #export (import:
- {class_decl ..class_decl^}
- {bundles (<>.some (..bundle (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."
- (import: java/lang/Object
- ["#::."
- (new [])
- (equals [java/lang/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 Try 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)."
- (import: java/lang/String
- ["#::."
- (new [[byte]])
- (#static valueOf [char] java/lang/String)
- (#static valueOf #as int_valueOf [int] java/lang/String)])
-
- (import: (java/util/List e)
- ["#::."
- (size [] int)
- (get [int] e)])
-
- (import: (java/util/ArrayList a)
- ["#::."
- ([T] toArray [[T]] [T])])
-
- "The class-type that is generated is of the fully-qualified name."
- "This avoids a clash between the java.util.List type, and Lux's own List type."
- "All enum options to be imported must be specified."
- (import: java/lang/Character$UnicodeScript
- ["#::."
- (#enum ARABIC CYRILLIC LATIN)])
-
- "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 cannot be named (otherwise, they'd be confused for Java classes)."
- (import: (lux/concurrency/promise/JvmPromise A)
- ["#::."
- (resolve [A] boolean)
- (poll [] A)
- (wasResolved [] boolean)
- (waitOn [lux/Function] void)
- (#static [A] make [A] (lux/concurrency/promise/JvmPromise A))])
-
- "Also, the names of the imported members will look like Class::member"
- (java/lang/Object::new [])
- (java/lang/Object::equals [other_object] my_object)
- (java/util/List::size [] my_list)
- java/lang/Character$UnicodeScript::LATIN
- )}
- (do {! meta.monad}
- [kind (class_kind class_decl)
- =members (|> bundles
- (list\map (function (_ [import_format members])
- (list\map (|>> [import_format]) members)))
- list.concat
- (monad.map ! (member_import$ (product.right class_decl) kind class_decl)))]
- (wrap (list& (class_import$ class_decl) (list\join =members)))))
-
-(syntax: #export (array {type (..generic_type^ (list))}
- size)
- {#.doc (doc "Create an array of the given type, with the given size."
- (array java/lang/Object 10))}
- (case type
- (^template [<type> <array_op>]
- [(^ (#GenericClass <type> (list)))
- (wrap (list (` (<array_op> (~ size)))))])
- (["boolean" "jvm znewarray"]
- ["byte" "jvm bnewarray"]
- ["short" "jvm snewarray"]
- ["int" "jvm inewarray"]
- ["long" "jvm lnewarray"]
- ["float" "jvm fnewarray"]
- ["double" "jvm dnewarray"]
- ["char" "jvm cnewarray"])
-
- _
- (wrap (list (` ("jvm anewarray" (~ (code.text (generic_type$ type))) (~ size)))))))
-
-(syntax: #export (array_length array)
- {#.doc (doc "Gives the length of an array."
- (array_length my_array))}
- (wrap (list (` ("jvm arraylength" (~ array))))))
-
-(def: (type->class_name type)
- (-> Type (Meta Text))
- (if (type\= Any type)
- (\ meta.monad wrap "java.lang.Object")
- (case type
- (#.Primitive name params)
- (\ meta.monad wrap name)
-
- (#.Apply A F)
- (case (type.apply (list A) F)
- #.None
- (meta.fail (format "Cannot apply type: " (type.format F) " to " (type.format A)))
-
- (#.Some type')
- (type->class_name type'))
-
- (#.Named _ type')
- (type->class_name type')
-
- _
- (meta.fail (format "Cannot convert to JvmType: " (type.format type))))))
-
-(syntax: #export (array_read idx array)
- {#.doc (doc "Loads an element from an array."
- (array_read 10 my_array))}
- (case array
- [_ (#.Identifier array_name)]
- (do meta.monad
- [array_type (meta.find_type array_name)
- array_jvm_type (type->class_name array_type)]
- (case array_jvm_type
- (^template [<type> <array_op>]
- [<type>
- (wrap (list (` (<array_op> (~ array) (~ idx)))))])
- (["[Z" "jvm zaload"]
- ["[B" "jvm baload"]
- ["[S" "jvm saload"]
- ["[I" "jvm iaload"]
- ["[J" "jvm jaload"]
- ["[F" "jvm faload"]
- ["[D" "jvm daload"]
- ["[C" "jvm caload"])
-
- _
- (wrap (list (` ("jvm aaload" (~ array) (~ idx)))))))
-
- _
- (with_gensyms [g!array]
- (wrap (list (` (let [(~ g!array) (~ array)]
- (..array_read (~ idx) (~ g!array)))))))))
-
-(syntax: #export (array_write idx value array)
- {#.doc (doc "Stores an element into an array."
- (array_write 10 my_object my_array))}
- (case array
- [_ (#.Identifier array_name)]
- (do meta.monad
- [array_type (meta.find_type array_name)
- array_jvm_type (type->class_name array_type)]
- (case array_jvm_type
- (^template [<type> <array_op>]
- [<type>
- (wrap (list (` (<array_op> (~ array) (~ idx) (~ value)))))])
- (["[Z" "jvm zastore"]
- ["[B" "jvm bastore"]
- ["[S" "jvm sastore"]
- ["[I" "jvm iastore"]
- ["[J" "jvm jastore"]
- ["[F" "jvm fastore"]
- ["[D" "jvm dastore"]
- ["[C" "jvm castore"])
-
- _
- (wrap (list (` ("jvm aastore" (~ array) (~ idx) (~ value)))))))
-
- _
- (with_gensyms [g!array]
- (wrap (list (` (let [(~ g!array) (~ array)]
- (..array_write (~ idx) (~ value) (~ g!array)))))))))
-
-(syntax: #export (class_for {type (..generic_type^ (list))})
- {#.doc (doc "Loads the class as a java.lang.Class object."
- (class_for java/lang/String))}
- (wrap (list (` ("jvm object class" (~ (code.text (simple_class$ (list) type))))))))
-
-(syntax: #export (type {type (..generic_type^ (list))})
- (wrap (list (..class_to_type #ManualPrM (list) type))))
diff --git a/stdlib/source/lux/ffi.php.lux b/stdlib/source/lux/ffi.php.lux
deleted file mode 100644
index 08a837c44..000000000
--- a/stdlib/source/lux/ffi.php.lux
+++ /dev/null
@@ -1,313 +0,0 @@
-(.module:
- [lux (#- Alias)
- ["." meta]
- ["@" target]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io]
- ["<>" parser ("#\." monad)
- ["<.>" code (#+ Parser)]]]
- [data
- ["." product]
- ["." maybe]
- ["." text
- ["%" format]]
- [collection
- ["." list ("#\." functor fold)]]]
- [type
- abstract]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]
- ["." template]]])
-
-(abstract: #export (Object brand) Any)
-
-(template [<name>]
- [(with_expansions [<brand> (template.identifier [<name> "'"])]
- (abstract: #export <brand> Any)
- (type: #export <name>
- (..Object <brand>)))]
-
- [Null]
- [Function]
- )
-
-(template [<name> <type>]
- [(type: #export <name>
- <type>)]
-
- [Boolean Bit]
- [Integer Int]
- [Float Frac]
- [String Text]
- )
-
-(type: Nullable
- [Bit Code])
-
-(def: nullable
- (Parser Nullable)
- (let [token (' #?)]
- (<| (<>.and (<>.parses? (<code>.this! token)))
- (<>.after (<>.not (<code>.this! token)))
- <code>.any)))
-
-(type: Alias
- Text)
-
-(def: alias
- (Parser Alias)
- (<>.after (<code>.this! (' #as)) <code>.local_identifier))
-
-(type: Field
- [Bit Text (Maybe Alias) Nullable])
-
-(def: static!
- (Parser Any)
- (<code>.this! (' #static)))
-
-(def: field
- (Parser Field)
- (<code>.form ($_ <>.and
- (<>.parses? ..static!)
- <code>.local_identifier
- (<>.maybe ..alias)
- ..nullable)))
-
-(def: constant
- (Parser Field)
- (<code>.form ($_ <>.and
- (<>\wrap true)
- <code>.local_identifier
- (<>.maybe ..alias)
- ..nullable)))
-
-(type: Common_Method
- {#name Text
- #alias (Maybe Alias)
- #inputs (List Nullable)
- #io? Bit
- #try? Bit
- #output Nullable})
-
-(type: Static_Method Common_Method)
-(type: Virtual_Method Common_Method)
-
-(type: Method
- (#Static Static_Method)
- (#Virtual Virtual_Method))
-
-(def: common_method
- (Parser Common_Method)
- ($_ <>.and
- <code>.local_identifier
- (<>.maybe ..alias)
- (<code>.tuple (<>.some ..nullable))
- (<>.parses? (<code>.this! (' #io)))
- (<>.parses? (<code>.this! (' #try)))
- ..nullable))
-
-(def: static_method
- (<>.after ..static! ..common_method))
-
-(def: method
- (Parser Method)
- (<code>.form (<>.or ..static_method
- ..common_method)))
-
-(type: Member
- (#Field Field)
- (#Method Method))
-
-(def: member
- (Parser Member)
- ($_ <>.or
- ..field
- ..method
- ))
-
-(def: input_variables
- (-> (List Nullable) (List [Bit Code]))
- (|>> list.enumeration
- (list\map (function (_ [idx [nullable? type]])
- [nullable? (|> idx %.nat code.local_identifier)]))))
-
-(def: (nullable_type [nullable? type])
- (-> Nullable Code)
- (if nullable?
- (` (.Maybe (~ type)))
- type))
-
-(def: (with_null g!temp [nullable? input])
- (-> Code [Bit Code] Code)
- (if nullable?
- (` (case (~ input)
- (#.Some (~ g!temp))
- (~ g!temp)
-
- #.Null
- ("php object null")))
- input))
-
-(def: (without_null g!temp [nullable? outputT] output)
- (-> Code Nullable Code Code)
- (if nullable?
- (` (let [(~ g!temp) (~ output)]
- (if ("php object null?" (~ g!temp))
- #.None
- (#.Some (~ g!temp)))))
- (` (let [(~ g!temp) (~ output)]
- (if (not ("php object null?" (~ g!temp)))
- (~ g!temp)
- (.error! "Null is an invalid value!"))))))
-
-(type: Import
- (#Class Text (Maybe Alias) Text (List Member))
- (#Function Static_Method)
- (#Constant Field))
-
-(def: import
- (Parser Import)
- ($_ <>.or
- ($_ <>.and
- <code>.local_identifier
- (<>.maybe ..alias)
- (<>.default ["" (list)]
- (<code>.tuple (<>.and <code>.text
- (<>.some member)))))
- (<code>.form ..common_method)
- ..constant
- ))
-
-(syntax: #export (try expression)
- {#.doc (doc (case (try (risky_computation input))
- (#.Right success)
- (do_something success)
-
- (#.Left error)
- (recover_from_failure error)))}
- (wrap (list (` ("lux try" ((~! io.io) (~ expression)))))))
-
-(def: (with_io with? without)
- (-> Bit Code Code)
- (if with?
- (` (io.io (~ without)))
- without))
-
-(def: (io_type io? rawT)
- (-> Bit Code Code)
- (if io?
- (` (io.IO (~ rawT)))
- rawT))
-
-(def: (with_try with? without_try)
- (-> Bit Code Code)
- (if with?
- (` (..try (~ without_try)))
- without_try))
-
-(def: (try_type try? rawT)
- (-> Bit Code Code)
- (if try?
- (` (.Either .Text (~ rawT)))
- rawT))
-
-(def: (make_function g!method g!temp source inputsT io? try? outputT)
- (-> Code Code Code (List Nullable) Bit Bit Nullable Code)
- (let [g!inputs (input_variables inputsT)]
- (` (def: ((~ g!method)
- [(~+ (list\map product.right g!inputs))])
- (-> [(~+ (list\map nullable_type inputsT))]
- (~ (|> (nullable_type outputT)
- (try_type try?)
- (io_type io?))))
- (:assume
- (~ (<| (with_io io?)
- (with_try try?)
- (without_null g!temp outputT)
- (` ("php apply"
- (:as ..Function (~ source))
- (~+ (list\map (with_null g!temp) g!inputs)))))))))))
-
-(syntax: #export (import: {import ..import})
- (with_gensyms [g!temp]
- (case import
- (#Class [class alias format members])
- (with_gensyms [g!object]
- (let [qualify (: (-> Text Code)
- (function (_ member_name)
- (|> format
- (text.replace_all "#" (maybe.default class alias))
- (text.replace_all "." member_name)
- code.local_identifier)))
- g!type (code.local_identifier (maybe.default class alias))
- class_import (` ("php constant" (~ (code.text class))))]
- (wrap (list& (` (type: (~ g!type)
- (..Object (primitive (~ (code.text class))))))
- (list\map (function (_ member)
- (case member
- (#Field [static? field alias fieldT])
- (if static?
- (` ((~! syntax:) ((~ (qualify (maybe.default field alias))))
- (\ (~! meta.monad) (~' wrap)
- (list (` (.:as (~ (nullable_type fieldT))
- ("php constant" (~ (code.text (%.format class "::" field))))))))))
- (` (def: ((~ (qualify field))
- (~ g!object))
- (-> (~ g!type)
- (~ (nullable_type fieldT)))
- (:assume
- (~ (without_null g!temp fieldT (` ("php object get" (~ (code.text field))
- (:as (..Object .Any) (~ g!object))))))))))
-
- (#Method method)
- (case method
- (#Static [method alias inputsT io? try? outputT])
- (..make_function (qualify (maybe.default method alias))
- g!temp
- (` ("php object get" (~ (code.text method))
- (:as (..Object .Any)
- ("php constant" (~ (code.text (%.format class "::" method)))))))
- inputsT
- io?
- try?
- outputT)
-
- (#Virtual [method alias inputsT io? try? outputT])
- (let [g!inputs (input_variables inputsT)]
- (` (def: ((~ (qualify (maybe.default method alias)))
- [(~+ (list\map product.right g!inputs))]
- (~ g!object))
- (-> [(~+ (list\map nullable_type inputsT))]
- (~ g!type)
- (~ (|> (nullable_type outputT)
- (try_type try?)
- (io_type io?))))
- (:assume
- (~ (<| (with_io io?)
- (with_try try?)
- (without_null g!temp outputT)
- (` ("php object do"
- (~ (code.text method))
- (~ g!object)
- (~+ (list\map (with_null g!temp) g!inputs)))))))))))))
- members)))))
-
- (#Function [name alias inputsT io? try? outputT])
- (let [imported (` ("php constant" (~ (code.text name))))]
- (wrap (list (..make_function (code.local_identifier (maybe.default name alias))
- g!temp
- imported
- inputsT
- io?
- try?
- outputT))))
-
- (#Constant [_ name alias fieldT])
- (let [imported (` ("php constant" (~ (code.text name))))]
- (wrap (list (` ((~! syntax:) ((~ (code.local_identifier (maybe.default name alias))))
- (\ (~! meta.monad) (~' wrap)
- (list (` (.:as (~ (nullable_type fieldT)) (~ imported))))))))))
- )))
diff --git a/stdlib/source/lux/ffi.py.lux b/stdlib/source/lux/ffi.py.lux
deleted file mode 100644
index 396cebf5c..000000000
--- a/stdlib/source/lux/ffi.py.lux
+++ /dev/null
@@ -1,314 +0,0 @@
-(.module:
- [lux #*
- ["." meta]
- ["@" target]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io]
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- ["." product]
- ["." maybe]
- ["." text
- ["%" format]]
- [collection
- ["." list ("#\." functor fold)]]]
- [type
- abstract]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]
- ["." template]]])
-
-(abstract: #export (Object brand) Any)
-
-(template [<name>]
- [(with_expansions [<brand> (template.identifier [<name> "'"])]
- (abstract: #export <brand> Any)
- (type: #export <name>
- (..Object <brand>)))]
-
- [None]
- [Function]
- [Dict]
- )
-
-(template [<name> <type>]
- [(type: #export <name>
- <type>)]
-
- [Boolean Bit]
- [Integer Int]
- [Float Frac]
- [String Text]
- )
-
-(type: Noneable
- [Bit Code])
-
-(def: noneable
- (Parser Noneable)
- (let [token (' #?)]
- (<| (<>.and (<>.parses? (<code>.this! token)))
- (<>.after (<>.not (<code>.this! token)))
- <code>.any)))
-
-(type: Constructor
- (List Noneable))
-
-(def: constructor
- (Parser Constructor)
- (<code>.form (<>.after (<code>.this! (' new))
- (<code>.tuple (<>.some ..noneable)))))
-
-(type: Field
- [Bit Text Noneable])
-
-(def: static!
- (Parser Any)
- (<code>.this! (' #static)))
-
-(def: field
- (Parser Field)
- (<code>.form ($_ <>.and
- (<>.parses? ..static!)
- <code>.local_identifier
- ..noneable)))
-
-(type: Common_Method
- {#name Text
- #alias (Maybe Text)
- #inputs (List Noneable)
- #io? Bit
- #try? Bit
- #output Noneable})
-
-(type: Static_Method Common_Method)
-(type: Virtual_Method Common_Method)
-
-(type: Method
- (#Static Static_Method)
- (#Virtual Virtual_Method))
-
-(def: common_method
- (Parser Common_Method)
- ($_ <>.and
- <code>.local_identifier
- (<>.maybe (<>.after (<code>.this! (' #as)) <code>.local_identifier))
- (<code>.tuple (<>.some ..noneable))
- (<>.parses? (<code>.this! (' #io)))
- (<>.parses? (<code>.this! (' #try)))
- ..noneable))
-
-(def: static_method
- (<>.after ..static! ..common_method))
-
-(def: method
- (Parser Method)
- (<code>.form (<>.or ..static_method
- ..common_method)))
-
-(type: Member
- (#Constructor Constructor)
- (#Field Field)
- (#Method Method))
-
-(def: member
- (Parser Member)
- ($_ <>.or
- ..constructor
- ..field
- ..method
- ))
-
-(def: input_variables
- (-> (List Noneable) (List [Bit Code]))
- (|>> list.enumeration
- (list\map (function (_ [idx [noneable? type]])
- [noneable? (|> idx %.nat code.local_identifier)]))))
-
-(def: (noneable_type [noneable? type])
- (-> Noneable Code)
- (if noneable?
- (` (.Maybe (~ type)))
- type))
-
-(def: (with_none g!temp [noneable? input])
- (-> Code [Bit Code] Code)
- (if noneable?
- (` (case (~ input)
- (#.Some (~ g!temp))
- (~ g!temp)
-
- #.None
- ("python object none")))
- input))
-
-(def: (without_none g!temp [noneable? outputT] output)
- (-> Code Noneable Code Code)
- (if noneable?
- (` (let [(~ g!temp) (~ output)]
- (if ("python object none?" (~ g!temp))
- #.None
- (#.Some (~ g!temp)))))
- (` (let [(~ g!temp) (~ output)]
- (if (not ("python object none?" (~ g!temp)))
- (~ g!temp)
- (.error! "None is an invalid value!"))))))
-
-(type: Import
- (#Class [Text Text (List Member)])
- (#Function Static_Method))
-
-(def: import
- (Parser Import)
- (<>.or (<>.and <code>.local_identifier
- (<>.default ["" (list)]
- (<code>.tuple (<>.and <code>.text
- (<>.some member)))))
- (<code>.form ..common_method)))
-
-(def: (with_io with? without)
- (-> Bit Code Code)
- (if with?
- (` (io.io (~ without)))
- without))
-
-(def: (io_type io? rawT)
- (-> Bit Code Code)
- (if io?
- (` (io.IO (~ rawT)))
- rawT))
-
-(def: (with_try with? without_try)
- (-> Bit Code Code)
- (if with?
- (` (.try (~ without_try)))
- without_try))
-
-(def: (try_type try? rawT)
- (-> Bit Code Code)
- (if try?
- (` (.Either .Text (~ rawT)))
- rawT))
-
-(def: (make_function g!method g!temp source inputsT io? try? outputT)
- (-> Code Code Code (List Noneable) Bit Bit Noneable Code)
- (let [g!inputs (input_variables inputsT)]
- (` (def: ((~ g!method)
- [(~+ (list\map product.right g!inputs))])
- (-> [(~+ (list\map noneable_type inputsT))]
- (~ (|> (noneable_type outputT)
- (try_type try?)
- (io_type io?))))
- (:assume
- (~ (<| (with_io io?)
- (with_try try?)
- (without_none g!temp outputT)
- (` ("python apply"
- (:as ..Function (~ source))
- (~+ (list\map (with_none g!temp) g!inputs)))))))))))
-
-(syntax: #export (import: {import ..import})
- (with_gensyms [g!temp]
- (case import
- (#Class [class format members])
- (with_gensyms [g!object]
- (let [qualify (: (-> Text Code)
- (function (_ member_name)
- (|> format
- (text.replace_all "#" class)
- (text.replace_all "." member_name)
- code.local_identifier)))
- g!type (code.local_identifier class)
- real_class (text.replace_all "/" "." class)
- imported (case (text.split_all_with "/" class)
- (#.Cons head tail)
- (list\fold (function (_ sub super)
- (` ("python object get" (~ (code.text sub))
- (:as (..Object .Any) (~ super)))))
- (` ("python import" (~ (code.text head))))
- tail)
-
- #.Nil
- (` ("python import" (~ (code.text class)))))]
- (wrap (list& (` (type: (~ g!type)
- (..Object (primitive (~ (code.text real_class))))))
- (list\map (function (_ member)
- (case member
- (#Constructor inputsT)
- (let [g!inputs (input_variables inputsT)]
- (` (def: ((~ (qualify "new"))
- [(~+ (list\map product.right g!inputs))])
- (-> [(~+ (list\map noneable_type inputsT))]
- (~ g!type))
- (:assume
- ("python apply"
- (:as ..Function (~ imported))
- (~+ (list\map (with_none g!temp) g!inputs)))))))
-
- (#Field [static? field fieldT])
- (if static?
- (` ((~! syntax:) ((~ (qualify field)))
- (\ (~! meta.monad) (~' wrap)
- (list (` (.:as (~ (noneable_type fieldT))
- ("python object get" (~ (code.text field))
- (:as (..Object .Any) (~ imported)))))))))
- (` (def: ((~ (qualify field))
- (~ g!object))
- (-> (~ g!type)
- (~ (noneable_type fieldT)))
- (:assume
- (~ (without_none g!temp fieldT (` ("python object get" (~ (code.text field))
- (:as (..Object .Any) (~ g!object))))))))))
-
- (#Method method)
- (case method
- (#Static [method alias inputsT io? try? outputT])
- (..make_function (qualify (maybe.default method alias))
- g!temp
- (` ("python object get" (~ (code.text method))
- (:as (..Object .Any) (~ imported))))
- inputsT
- io?
- try?
- outputT)
-
- (#Virtual [method alias inputsT io? try? outputT])
- (let [g!inputs (input_variables inputsT)]
- (` (def: ((~ (qualify (maybe.default method alias)))
- [(~+ (list\map product.right g!inputs))]
- (~ g!object))
- (-> [(~+ (list\map noneable_type inputsT))]
- (~ g!type)
- (~ (|> (noneable_type outputT)
- (try_type try?)
- (io_type io?))))
- (:assume
- (~ (<| (with_io io?)
- (with_try try?)
- (without_none g!temp outputT)
- (` ("python object do"
- (~ (code.text method))
- (~ g!object)
- (~+ (list\map (with_none g!temp) g!inputs)))))))))))))
- members)))))
-
- (#Function [name alias inputsT io? try? outputT])
- (wrap (list (..make_function (code.local_identifier (maybe.default name alias))
- g!temp
- (` ("python constant" (~ (code.text name))))
- inputsT
- io?
- try?
- outputT)))
- )))
-
-(template: #export (lambda <inputs> <output>)
- (.:as ..Function
- (`` ("python function"
- (~~ (template.count <inputs>))
- (.function (_ [<inputs>])
- <output>)))))
diff --git a/stdlib/source/lux/ffi.rb.lux b/stdlib/source/lux/ffi.rb.lux
deleted file mode 100644
index df71dcc18..000000000
--- a/stdlib/source/lux/ffi.rb.lux
+++ /dev/null
@@ -1,331 +0,0 @@
-(.module:
- [lux (#- Alias)
- ["@" target]
- ["." meta]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io]
- ["<>" parser ("#\." monad)
- ["<.>" code (#+ Parser)]]]
- [data
- ["." product]
- ["." maybe]
- ["." text
- ["%" format]]
- [collection
- ["." list ("#\." functor fold)]]]
- [type
- abstract]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]
- ["." template]]])
-
-(abstract: #export (Object brand) Any)
-
-(template [<name>]
- [(with_expansions [<brand> (template.identifier [<name> "'"])]
- (abstract: #export <brand> Any)
- (type: #export <name>
- (..Object <brand>)))]
-
- [Nil]
- [Function]
- )
-
-(template [<name> <type>]
- [(type: #export <name>
- <type>)]
-
- [Boolean Bit]
- [Integer Int]
- [Float Frac]
- [String Text]
- )
-
-(type: Nilable
- [Bit Code])
-
-(def: nilable
- (Parser Nilable)
- (let [token (' #?)]
- (<| (<>.and (<>.parses? (<code>.this! token)))
- (<>.after (<>.not (<code>.this! token)))
- <code>.any)))
-
-(type: Alias
- Text)
-
-(def: alias
- (Parser Alias)
- (<>.after (<code>.this! (' #as)) <code>.local_identifier))
-
-(type: Field
- [Bit Text (Maybe Alias) Nilable])
-
-(def: static!
- (Parser Any)
- (<code>.this! (' #static)))
-
-(def: field
- (Parser Field)
- (<code>.form ($_ <>.and
- (<>.parses? ..static!)
- <code>.local_identifier
- (<>.maybe ..alias)
- ..nilable)))
-
-(def: constant
- (Parser Field)
- (<code>.form ($_ <>.and
- (<>\wrap true)
- <code>.local_identifier
- (<>.maybe ..alias)
- ..nilable)))
-
-(type: Common_Method
- {#name Text
- #alias (Maybe Alias)
- #inputs (List Nilable)
- #io? Bit
- #try? Bit
- #output Nilable})
-
-(type: Static_Method Common_Method)
-(type: Virtual_Method Common_Method)
-
-(type: Method
- (#Static Static_Method)
- (#Virtual Virtual_Method))
-
-(def: common_method
- (Parser Common_Method)
- ($_ <>.and
- <code>.local_identifier
- (<>.maybe ..alias)
- (<code>.tuple (<>.some ..nilable))
- (<>.parses? (<code>.this! (' #io)))
- (<>.parses? (<code>.this! (' #try)))
- ..nilable))
-
-(def: static_method
- (<>.after ..static! ..common_method))
-
-(def: method
- (Parser Method)
- (<code>.form (<>.or ..static_method
- ..common_method)))
-
-(type: Member
- (#Field Field)
- (#Method Method))
-
-(def: member
- (Parser Member)
- ($_ <>.or
- ..field
- ..method
- ))
-
-(def: input_variables
- (-> (List Nilable) (List [Bit Code]))
- (|>> list.enumeration
- (list\map (function (_ [idx [nilable? type]])
- [nilable? (|> idx %.nat code.local_identifier)]))))
-
-(def: (nilable_type [nilable? type])
- (-> Nilable Code)
- (if nilable?
- (` (.Maybe (~ type)))
- type))
-
-(def: (with_nil g!temp [nilable? input])
- (-> Code [Bit Code] Code)
- (if nilable?
- (` (case (~ input)
- (#.Some (~ g!temp))
- (~ g!temp)
-
- #.Nil
- ("ruby object nil")))
- input))
-
-(def: (without_nil g!temp [nilable? outputT] output)
- (-> Code Nilable Code Code)
- (if nilable?
- (` (let [(~ g!temp) (~ output)]
- (if ("ruby object nil?" (~ g!temp))
- #.None
- (#.Some (~ g!temp)))))
- (` (let [(~ g!temp) (~ output)]
- (if (not ("ruby object nil?" (~ g!temp)))
- (~ g!temp)
- (.error! "Nil is an invalid value!"))))))
-
-(type: Import
- (#Class Text (Maybe Alias) Text (List Member))
- (#Function Static_Method)
- (#Constant Field))
-
-(def: import
- (Parser [(Maybe Text) Import])
- ($_ <>.and
- (<>.maybe <code>.text)
- ($_ <>.or
- ($_ <>.and
- <code>.local_identifier
- (<>.maybe ..alias)
- (<>.default ["" (list)]
- (<code>.tuple (<>.and <code>.text
- (<>.some member)))))
- (<code>.form ..common_method)
- ..constant
- )))
-
-(def: (with_io with? without)
- (-> Bit Code Code)
- (if with?
- (` (io.io (~ without)))
- without))
-
-(def: (io_type io? rawT)
- (-> Bit Code Code)
- (if io?
- (` (io.IO (~ rawT)))
- rawT))
-
-(def: (with_try with? without_try)
- (-> Bit Code Code)
- (if with?
- (` (.try (~ without_try)))
- without_try))
-
-(def: (try_type try? rawT)
- (-> Bit Code Code)
- (if try?
- (` (.Either .Text (~ rawT)))
- rawT))
-
-(def: (make_function g!method g!temp source inputsT io? try? outputT)
- (-> Code Code Code (List Nilable) Bit Bit Nilable Code)
- (let [g!inputs (input_variables inputsT)]
- (` (def: ((~ g!method)
- [(~+ (list\map product.right g!inputs))])
- (-> [(~+ (list\map nilable_type inputsT))]
- (~ (|> (nilable_type outputT)
- (try_type try?)
- (io_type io?))))
- (:assume
- (~ (<| (with_io io?)
- (with_try try?)
- (without_nil g!temp outputT)
- (` ("ruby apply"
- (:as ..Function (~ source))
- (~+ (list\map (with_nil g!temp) g!inputs)))))))))))
-
-(syntax: #export (import: {[?module import] ..import})
- (with_gensyms [g!temp]
- (case import
- (#Class [class alias format members])
- (with_gensyms [g!object]
- (let [qualify (: (-> Text Code)
- (function (_ member_name)
- (|> format
- (text.replace_all "#" (maybe.default class alias))
- (text.replace_all "." member_name)
- code.local_identifier)))
- g!type (code.local_identifier (maybe.default class alias))
- module_import (: (List Code)
- (case ?module
- (#.Some module)
- (list (` ("ruby import" (~ (code.text module)))))
-
- #.None
- (list)))
- class_import (` ("ruby constant" (~ (code.text class))))]
- (wrap (list& (` (type: (~ g!type)
- (..Object (primitive (~ (code.text class))))))
- (list\map (function (_ member)
- (case member
- (#Field [static? field alias fieldT])
- (if static?
- (` ((~! syntax:) ((~ (qualify (maybe.default field alias))))
- (\ (~! meta.monad) (~' wrap)
- (list (` (.:as (~ (nilable_type fieldT))
- (.exec
- (~+ module_import)
- ("ruby constant" (~ (code.text (%.format class "::" field)))))))))))
- (` (def: ((~ (qualify field))
- (~ g!object))
- (-> (~ g!type)
- (~ (nilable_type fieldT)))
- (:assume
- (~ (without_nil g!temp fieldT (` ("ruby object get" (~ (code.text field))
- (:as (..Object .Any) (~ g!object))))))))))
-
- (#Method method)
- (case method
- (#Static [method alias inputsT io? try? outputT])
- (..make_function (qualify (maybe.default method alias))
- g!temp
- (` ("ruby object get" (~ (code.text method))
- (:as (..Object .Any)
- (.exec
- (~+ module_import)
- ("ruby constant" (~ (code.text (%.format class "::" method))))))))
- inputsT
- io?
- try?
- outputT)
-
- (#Virtual [method alias inputsT io? try? outputT])
- (let [g!inputs (input_variables inputsT)]
- (` (def: ((~ (qualify (maybe.default method alias)))
- [(~+ (list\map product.right g!inputs))]
- (~ g!object))
- (-> [(~+ (list\map nilable_type inputsT))]
- (~ g!type)
- (~ (|> (nilable_type outputT)
- (try_type try?)
- (io_type io?))))
- (:assume
- (~ (<| (with_io io?)
- (with_try try?)
- (without_nil g!temp outputT)
- (` ("ruby object do"
- (~ (code.text method))
- (~ g!object)
- (~+ (list\map (with_nil g!temp) g!inputs)))))))))))))
- members)))))
-
- (#Function [name alias inputsT io? try? outputT])
- (let [imported (` (.exec
- (~+ (case ?module
- (#.Some module)
- (list (` ("ruby import" (~ (code.text module)))))
-
- #.None
- (list)))
- ("ruby constant" (~ (code.text name)))))]
- (wrap (list (..make_function (code.local_identifier (maybe.default name alias))
- g!temp
- imported
- inputsT
- io?
- try?
- outputT))))
-
- (#Constant [_ name alias fieldT])
- (let [imported (` (.exec
- (~+ (case ?module
- (#.Some module)
- (list (` ("ruby import" (~ (code.text module)))))
-
- #.None
- (list)))
- ("ruby constant" (~ (code.text name)))))]
- (wrap (list (` ((~! syntax:) ((~ (code.local_identifier (maybe.default name alias))))
- (\ (~! meta.monad) (~' wrap)
- (list (` (.:as (~ (nilable_type fieldT)) (~ imported))))))))))
- )))
diff --git a/stdlib/source/lux/ffi.scm.lux b/stdlib/source/lux/ffi.scm.lux
deleted file mode 100644
index c6c447b72..000000000
--- a/stdlib/source/lux/ffi.scm.lux
+++ /dev/null
@@ -1,219 +0,0 @@
-(.module:
- [lux (#- Alias)
- ["@" target]
- ["." meta]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io]
- ["<>" parser ("#\." monad)
- ["<.>" code (#+ Parser)]]]
- [data
- ["." product]
- ["." maybe]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [type
- abstract]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]
- ["." template]]])
-
-(abstract: #export (Object brand) Any)
-
-(template [<name>]
- [(with_expansions [<brand> (template.identifier [<name> "'"])]
- (abstract: #export <brand> Any)
- (type: #export <name>
- (..Object <brand>)))]
-
- [Nil]
- [Function]
- )
-
-(template [<name> <type>]
- [(type: #export <name>
- <type>)]
-
- [Boolean Bit]
- [Integer Int]
- [Float Frac]
- [String Text]
- )
-
-(type: Nilable
- [Bit Code])
-
-(def: nilable
- (Parser Nilable)
- (let [token (' #?)]
- (<| (<>.and (<>.parses? (<code>.this! token)))
- (<>.after (<>.not (<code>.this! token)))
- <code>.any)))
-
-(type: Alias
- Text)
-
-(def: alias
- (Parser Alias)
- (<>.after (<code>.this! (' #as)) <code>.local_identifier))
-
-(type: Field
- [Bit Text (Maybe Alias) Nilable])
-
-(def: static!
- (Parser Any)
- (<code>.this! (' #static)))
-
-(def: field
- (Parser Field)
- (<code>.form ($_ <>.and
- (<>.parses? ..static!)
- <code>.local_identifier
- (<>.maybe ..alias)
- ..nilable)))
-
-(def: constant
- (Parser Field)
- (<code>.form ($_ <>.and
- (<>\wrap true)
- <code>.local_identifier
- (<>.maybe ..alias)
- ..nilable)))
-
-(type: Common_Method
- {#name Text
- #alias (Maybe Alias)
- #inputs (List Nilable)
- #io? Bit
- #try? Bit
- #output Nilable})
-
-(def: common_method
- (Parser Common_Method)
- ($_ <>.and
- <code>.local_identifier
- (<>.maybe ..alias)
- (<code>.tuple (<>.some ..nilable))
- (<>.parses? (<code>.this! (' #io)))
- (<>.parses? (<code>.this! (' #try)))
- ..nilable))
-
-(def: input_variables
- (-> (List Nilable) (List [Bit Code]))
- (|>> list.enumeration
- (list\map (function (_ [idx [nilable? type]])
- [nilable? (|> idx %.nat code.local_identifier)]))))
-
-(def: (nilable_type [nilable? type])
- (-> Nilable Code)
- (if nilable?
- (` (.Maybe (~ type)))
- type))
-
-(def: (with_nil g!temp [nilable? input])
- (-> Code [Bit Code] Code)
- (if nilable?
- (` (case (~ input)
- (#.Some (~ g!temp))
- (~ g!temp)
-
- #.Nil
- ("scheme object nil")))
- input))
-
-(def: (without_nil g!temp [nilable? outputT] output)
- (-> Code Nilable Code Code)
- (if nilable?
- (` (let [(~ g!temp) (~ output)]
- (if ("scheme object nil?" (~ g!temp))
- #.None
- (#.Some (~ g!temp)))))
- (` (let [(~ g!temp) (~ output)]
- (if (not ("scheme object nil?" (~ g!temp)))
- (~ g!temp)
- (.error! "Nil is an invalid value!"))))))
-
-(type: Import
- (#Function Common_Method)
- (#Constant Field))
-
-(def: import
- (Parser Import)
- ($_ <>.or
- (<code>.form ..common_method)
- ..constant
- ))
-
-(syntax: #export (try expression)
- {#.doc (doc (case (try (risky_computation input))
- (#.Right success)
- (do_something success)
-
- (#.Left error)
- (recover_from_failure error)))}
- (wrap (list (` ("lux try" ((~! io.io) (~ expression)))))))
-
-(def: (with_io with? without)
- (-> Bit Code Code)
- (if with?
- (` (io.io (~ without)))
- without))
-
-(def: (io_type io? rawT)
- (-> Bit Code Code)
- (if io?
- (` (io.IO (~ rawT)))
- rawT))
-
-(def: (with_try with? without_try)
- (-> Bit Code Code)
- (if with?
- (` (..try (~ without_try)))
- without_try))
-
-(def: (try_type try? rawT)
- (-> Bit Code Code)
- (if try?
- (` (.Either .Text (~ rawT)))
- rawT))
-
-(def: (make_function g!method g!temp source inputsT io? try? outputT)
- (-> Code Code Code (List Nilable) Bit Bit Nilable Code)
- (let [g!inputs (input_variables inputsT)]
- (` (def: ((~ g!method)
- [(~+ (list\map product.right g!inputs))])
- (-> [(~+ (list\map nilable_type inputsT))]
- (~ (|> (nilable_type outputT)
- (try_type try?)
- (io_type io?))))
- (:assume
- (~ (<| (with_io io?)
- (with_try try?)
- (without_nil g!temp outputT)
- (` ("scheme apply"
- (:as ..Function (~ source))
- (~+ (list\map (with_nil g!temp) g!inputs)))))))))))
-
-(syntax: #export (import: {import ..import})
- (with_gensyms [g!temp]
- (case import
- (#Function [name alias inputsT io? try? outputT])
- (let [imported (` ("scheme constant" (~ (code.text name))))]
- (wrap (list (..make_function (code.local_identifier (maybe.default name alias))
- g!temp
- imported
- inputsT
- io?
- try?
- outputT))))
-
- (#Constant [_ name alias fieldT])
- (let [imported (` ("scheme constant" (~ (code.text name))))]
- (wrap (list (` ((~! syntax:) ((~ (code.local_identifier (maybe.default name alias))))
- (\ (~! meta.monad) (~' wrap)
- (list (` (.:as (~ (nilable_type fieldT)) (~ imported))))))))))
- )))
diff --git a/stdlib/source/lux/locale.lux b/stdlib/source/lux/locale.lux
deleted file mode 100644
index 38b11fd6b..000000000
--- a/stdlib/source/lux/locale.lux
+++ /dev/null
@@ -1,44 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- ["." hash (#+ Hash)]]
- [data
- ["." maybe ("#\." functor)]
- ["." text
- ["%" format (#+ format)]
- ["." encoding (#+ Encoding)]]]
- [type
- abstract]]
- [/
- ["." language (#+ Language)]
- ["." territory (#+ Territory)]])
-
-(abstract: #export Locale
- Text
-
- (def: territory_separator "_")
- (def: encoding_separator ".")
-
- (def: #export (locale language territory encoding)
- (-> Language (Maybe Territory) (Maybe Encoding) Locale)
- (:abstraction (format (language.code language)
- (|> territory
- (maybe\map (|>> territory.long_code (format ..territory_separator)))
- (maybe.default ""))
- (|> encoding
- (maybe\map (|>> encoding.name (format ..encoding_separator)))
- (maybe.default "")))))
-
- (def: #export code
- (-> Locale Text)
- (|>> :representation))
-
- (def: #export hash
- (Hash Locale)
- (\ hash.functor map ..code text.hash))
-
- (def: #export equivalence
- (Equivalence Locale)
- (\ ..hash &equivalence))
- )
diff --git a/stdlib/source/lux/locale/language.lux b/stdlib/source/lux/locale/language.lux
deleted file mode 100644
index 7dd4b22e0..000000000
--- a/stdlib/source/lux/locale/language.lux
+++ /dev/null
@@ -1,572 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]]
- [data
- ["." text]]
- [type
- abstract]
- [macro
- ["." template]]])
-
-## https://en.wikipedia.org/wiki/List_of_ISO_639-2_codes
-(abstract: #export Language
- {#name Text
- #code Text}
-
- (template [<name> <tag>]
- [(def: #export <name>
- (-> Language Text)
- (|>> :representation (get@ <tag>)))]
-
- [name #name]
- [code #code]
- )
-
- (template [<bundle>]
- [(with_expansions [<bundle>' (template.splice <bundle>)]
- (template [<code> <name> <definition> <alias>+]
- [(def: #export <definition>
- Language
- (:abstraction {#name <name>
- #code <code>}))
- (`` (template [<alias>]
- [(def: #export <alias>
- Language
- <definition>)]
-
- (~~ (template.splice <alias>+))))]
-
- <bundle>'
- ))]
-
- [[["mis" "uncoded languages" uncoded []]
- ["mul" "multiple languages" multiple []]
- ["und" "undetermined" undetermined []]
- ["zxx" "no linguistic content; not applicable" not_applicable []]]]
-
- [[["aar" "Afar" afar []]
- ["abk" "Abkhazian" abkhazian []]
- ["ace" "Achinese" achinese []]
- ["ach" "Acoli" acoli []]
- ["ada" "Adangme" adangme []]
- ["ady" "Adyghe; Adygei" adyghe []]
- ["afa" "Afro-Asiatic languages" afro_asiatic []]
- ["afh" "Afrihili" afrihili []]
- ["afr" "Afrikaans" afrikaans []]
- ["ain" "Ainu" ainu []]
- ["aka" "Akan" akan []]
- ["akk" "Akkadian" akkadian []]
- ["ale" "Aleut" aleut []]
- ["alg" "Algonquian languages" algonquian []]
- ["alt" "Southern Altai" southern_altai []]
- ["amh" "Amharic" amharic []]
- ["ang" "Old English (ca.450–1100)" old_english []]
- ["anp" "Angika" angika []]
- ["apa" "Apache languages" apache []]
- ["ara" "Arabic" arabic []]
- ["arc" "Official Aramaic (700–300 BCE); Imperial Aramaic (700–300 BCE)" official_aramaic [[imperial_aramaic]]]
- ["arg" "Aragonese" aragonese []]
- ["arn" "Mapudungun; Mapuche" mapudungun []]
- ["arp" "Arapaho" arapaho []]
- ["art" "Artificial languages" artificial []]
- ["arw" "Arawak" arawak []]
- ["asm" "Assamese" assamese []]
- ["ast" "Asturian; Bable; Leonese; Asturleonese" asturian [[bable] [leonese] [asturleonese]]]
- ["ath" "Athapascan languages" athapascan []]
- ["aus" "Australian languages" australian []]
- ["ava" "Avaric" avaric []]
- ["ave" "Avestan" avestan []]
- ["awa" "Awadhi" awadhi []]
- ["aym" "Aymara" aymara []]
- ["aze" "Azerbaijani" azerbaijani []]]]
-
- [[["bad" "Banda languages" banda []]
- ["bai" "Bamileke languages" bamileke []]
- ["bak" "Bashkir" bashkir []]
- ["bal" "Baluchi" baluchi []]
- ["bam" "Bambara" bambara []]
- ["ban" "Balinese" balinese []]
- ["bas" "Basa" basa []]
- ["bat" "Baltic languages" baltic []]
- ["bej" "Beja; Bedawiyet" beja []]
- ["bel" "Belarusian" belarusian []]
- ["bem" "Bemba" bemba []]
- ["ben" "Bengali" bengali []]
- ["ber" "Berber languages" berber []]
- ["bho" "Bhojpuri" bhojpuri []]
- ["bih" "Bihari languages" bihari []]
- ["bik" "Bikol" bikol []]
- ["bin" "Bini; Edo" bini [[edo]]]
- ["bis" "Bislama" bislama []]
- ["bla" "Siksika" siksika []]
- ["bnt" "Bantu languages" bantu []]
- ["bod" "Tibetan" tibetan []]
- ["bos" "Bosnian" bosnian []]
- ["bra" "Braj" braj []]
- ["bre" "Breton" breton []]
- ["btk" "Batak languages" batak []]
- ["bua" "Buriat" buriat []]
- ["bug" "Buginese" buginese []]
- ["bul" "Bulgarian" bulgarian []]
- ["byn" "Blin; Bilin" blin [[bilin]]]]]
-
- [[["cad" "Caddo" caddo []]
- ["cai" "Central American Indian languages" central_american_indian []]
- ["car" "Galibi Carib" galibi_carib []]
- ["cat" "Catalan; Valencian" catalan [[valencian]]]
- ["cau" "Caucasian languages" caucasian []]
- ["ceb" "Cebuano" cebuano []]
- ["cel" "Celtic languages" celtic []]
- ["ces" "Czech" czech []]
- ["cha" "Chamorro" chamorro []]
- ["chb" "Chibcha" chibcha []]
- ["che" "Chechen" chechen []]
- ["chg" "Chagatai" chagatai []]
- ["chk" "Chuukese" chuukese []]
- ["chm" "Mari" mari []]
- ["chn" "Chinook jargon" chinook []]
- ["cho" "Choctaw" choctaw []]
- ["chp" "Chipewyan; Dene Suline" chipewyan []]
- ["chr" "Cherokee" cherokee []]
- ["chu" "Church Slavic; Old Slavonic; Church Slavonic; Old Bulgarian; Old Church Slavonic" church_slavic [[old_slavonic] [church_slavonic] [old_bulgarian] [old_church_slavonic]]]
- ["chv" "Chuvash" chuvash []]
- ["chy" "Cheyenne" cheyenne []]
- ["cmc" "Chamic languages" chamic []]
- ["cnr" "Montenegrin" montenegrin []]
- ["cop" "Coptic" coptic []]
- ["cor" "Cornish" cornish []]
- ["cos" "Corsican" corsican []]
- ["cpe" "Creoles and pidgins, English based" creoles_and_pidgins/english []]
- ["cpf" "Creoles and pidgins, French-based" creoles_and_pidgins/french []]
- ["cpp" "Creoles and pidgins, Portuguese-based" creoles_and_pidgins/portuguese []]
- ["cre" "Cree" cree []]
- ["crh" "Crimean Tatar; Crimean Turkish" crimean []]
- ["crp" "Creoles and pidgins" creoles_and_pidgins []]
- ["csb" "Kashubian" kashubian []]
- ["cus" "Cushitic languages" cushitic []]
- ["cym" "Welsh" welsh []]]]
-
- [[["dak" "Dakota" dakota []]
- ["dan" "Danish" danish []]
- ["dar" "Dargwa" dargwa []]
- ["day" "Land Dayak languages" land_dayak []]
- ["del" "Delaware" delaware []]
- ["den" "Slave (Athapascan)" slavey []]
- ["deu" "German" german []]
- ["dgr" "Dogrib" dogrib []]
- ["din" "Dinka" dinka []]
- ["div" "Divehi; Dhivehi; Maldivian" dhivehi [[maldivian]]]
- ["doi" "Dogri" dogri []]
- ["dra" "Dravidian languages" dravidian []]
- ["dsb" "Lower Sorbian" lower_sorbian []]
- ["dua" "Duala" duala []]
- ["dum" "Middle Dutch (ca. 1050–1350)" middle_dutch []]
- ["dyu" "Dyula" dyula []]
- ["dzo" "Dzongkha" dzongkha []]]]
-
- [[["efi" "Efik" efik []]
- ["egy" "Ancient Egyptian" egyptian []]
- ["eka" "Ekajuk" ekajuk []]
- ["ell" "Modern Greek (1453–)" greek []]
- ["elx" "Elamite" elamite []]
- ["eng" "English" english []]
- ["enm" "Middle English (1100–1500)" middle_english []]
- ["epo" "Esperanto" esperanto []]
- ["est" "Estonian" estonian []]
- ["eus" "Basque" basque []]
- ["ewe" "Ewe" ewe []]
- ["ewo" "Ewondo" ewondo []]]]
-
- [[["fan" "Fang" fang []]
- ["fao" "Faroese" faroese []]
- ["fas" "Persian" persian []]
- ["fat" "Fanti" fanti []]
- ["fij" "Fijian" fijian []]
- ["fil" "Filipino; Pilipino" filipino []]
- ["fin" "Finnish" finnish []]
- ["fiu" "Finno-Ugrian languages" finno_ugrian []]
- ["fon" "Fon" fon []]
- ["fra" "French" french []]
- ["frm" "Middle French (ca. 1400–1600)" middle_french []]
- ["fro" "Old French (ca. 842–1400)" old_french []]
- ["frr" "Northern Frisian" northern_frisian []]
- ["frs" "Eastern Frisian" eastern_frisian []]
- ["fry" "Western Frisian" western_frisian []]
- ["ful" "Fulah" fulah []]
- ["fur" "Friulian" friulian []]]]
-
- [[["gaa" "Ga" ga []]
- ["gay" "Gayo" gayo []]
- ["gba" "Gbaya" gbaya []]
- ["gem" "Germanic languages" germanic []]
- ["gez" "Geez" geez []]
- ["gil" "Gilbertese" gilbertese []]
- ["gla" "Gaelic; Scottish Gaelic" gaelic []]
- ["gle" "Irish" irish []]
- ["glg" "Galician" galician []]
- ["glv" "Manx" manx []]
- ["gmh" "Middle High German (ca. 1050–1500)" middle_high_german []]
- ["goh" "Old High German (ca. 750–1050)" old_high_german []]
- ["gon" "Gondi" gondi []]
- ["gor" "Gorontalo" gorontalo []]
- ["got" "Gothic" gothic []]
- ["grb" "Grebo" grebo []]
- ["grc" "Ancient Greek (to 1453)" ancient_greek []]
- ["grn" "Guarani" guarani []]
- ["gsw" "Swiss German; Alemannic; Alsatian" swiss_german [[alemannic] [alsatian]]]
- ["guj" "Gujarati" gujarati []]
- ["gwi" "Gwich'in" gwich'in []]]]
-
- [[["hai" "Haida" haida []]
- ["hat" "Haitian; Haitian Creole" haitian []]
- ["hau" "Hausa" hausa []]
- ["haw" "Hawaiian" hawaiian []]
- ["heb" "Hebrew" hebrew []]
- ["her" "Herero" herero []]
- ["hil" "Hiligaynon" hiligaynon []]
- ["him" "Himachali languages; Pahari languages" himachali []]
- ["hin" "Hindi" hindi []]
- ["hit" "Hittite" hittite []]
- ["hmn" "Hmong; Mong" hmong []]
- ["hmo" "Hiri Motu" hiri_motu []]
- ["hrv" "Croatian" croatian []]
- ["hsb" "Upper Sorbian" upper_sorbian []]
- ["hun" "Hungarian" hungarian []]
- ["hup" "Hupa" hupa []]
- ["hye" "Armenian" armenian []]]]
-
- [[["iba" "Iban" iban []]
- ["ibo" "Igbo" igbo []]
- ["ido" "Ido" ido []]
- ["iii" "Sichuan Yi; Nuosu" sichuan_yi [[nuosu]]]
- ["ijo" "Ijo languages" ijo []]
- ["iku" "Inuktitut" inuktitut []]
- ["ile" "Interlingue; Occidental" interlingue []]
- ["ilo" "Iloko" iloko []]
- ["ina" "Interlingua (International Auxiliary Language Association)" interlingua []]
- ["inc" "Indic languages" indic []]
- ["ind" "Indonesian" indonesian []]
- ["ine" "Indo-European languages" indo_european []]
- ["inh" "Ingush" ingush []]
- ["ipk" "Inupiaq" inupiaq []]
- ["ira" "Iranian languages" iranian []]
- ["iro" "Iroquoian languages" iroquoian []]
- ["isl" "Icelandic" icelandic []]
- ["ita" "Italian" italian []]]]
-
- [[["jav" "Javanese" javanese []]
- ["jbo" "Lojban" lojban []]
- ["jpn" "Japanese" japanese []]
- ["jpr" "Judeo-Persian" judeo_persian []]
- ["jrb" "Judeo-Arabic" judeo_arabic []]]]
-
- [[["kaa" "Kara-Kalpak" kara_kalpak []]
- ["kab" "Kabyle" kabyle []]
- ["kac" "Kachin; Jingpho" kachin [[jingpho]]]
- ["kal" "Kalaallisut; Greenlandic" kalaallisut [[greenlandic]]]
- ["kam" "Kamba" kamba []]
- ["kan" "Kannada" kannada []]
- ["kar" "Karen languages" karen []]
- ["kas" "Kashmiri" kashmiri []]
- ["kat" "Georgian" georgian []]
- ["kau" "Kanuri" kanuri []]
- ["kaw" "Kawi" kawi []]
- ["kaz" "Kazakh" kazakh []]
- ["kbd" "Kabardian" kabardian []]
- ["kha" "Khasi" khasi []]
- ["khi" "Khoisan languages" khoisan []]
- ["khm" "Central Khmer" central_khmer []]
- ["kho" "Khotanese; Sakan" khotanese [[sakan]]]
- ["kik" "Kikuyu; Gikuyu" gikuyu []]
- ["kin" "Kinyarwanda" kinyarwanda []]
- ["kir" "Kirghiz; Kyrgyz" kyrgyz []]
- ["kmb" "Kimbundu" kimbundu []]
- ["kok" "Konkani" konkani []]
- ["kom" "Komi" komi []]
- ["kon" "Kongo" kongo []]
- ["kor" "Korean" korean []]
- ["kos" "Kosraean" kosraean []]
- ["kpe" "Kpelle" kpelle []]
- ["krc" "Karachay-Balkar" karachay_balkar []]
- ["krl" "Karelian" karelian []]
- ["kro" "Kru languages" kru []]
- ["kru" "Kurukh" kurukh []]
- ["kua" "Kuanyama; Kwanyama" kwanyama []]
- ["kum" "Kumyk" kumyk []]
- ["kur" "Kurdish" kurdish []]
- ["kut" "Kutenai" kutenai []]]]
-
- [[["lad" "Ladino" ladino []]
- ["lah" "Lahnda" lahnda []]
- ["lam" "Lamba" lamba []]
- ["lao" "Lao" lao []]
- ["lat" "Latin" latin []]
- ["lav" "Latvian" latvian []]
- ["lez" "Lezghian" lezghian []]
- ["lim" "Limburgan; Limburger; Limburgish" limburgan []]
- ["lin" "Lingala" lingala []]
- ["lit" "Lithuanian" lithuanian []]
- ["lol" "Mongo" mongo []]
- ["loz" "Lozi" lozi []]
- ["ltz" "Luxembourgish; Letzeburgesch" luxembourgish []]
- ["lua" "Luba-Lulua" luba_lulua []]
- ["lub" "Luba-Katanga" luba_katanga []]
- ["lug" "Ganda" ganda []]
- ["lui" "Luiseno" luiseno []]
- ["lun" "Lunda" lunda []]
- ["luo" "Luo (Kenya and Tanzania)" luo []]
- ["lus" "Lushai" lushai []]]]
-
- [[["mad" "Madurese" madurese []]
- ["mag" "Magahi" magahi []]
- ["mah" "Marshallese" marshallese []]
- ["mai" "Maithili" maithili []]
- ["mak" "Makasar" makasar []]
- ["mal" "Malayalam" malayalam []]
- ["man" "Mandingo" mandingo []]
- ["map" "Austronesian languages" austronesian []]
- ["mar" "Marathi" marathi []]
- ["mas" "Masai" masai []]
- ["mdf" "Moksha" moksha []]
- ["mdr" "Mandar" mandar []]
- ["men" "Mende" mende []]
- ["mga" "Middle Irish (900–1200)" middle_irish []]
- ["mic" "Mi'kmaq; Micmac" mi'kmaq [[micmac]]]
- ["min" "Minangkabau" minangkabau []]
- ["mkd" "Macedonian" macedonian []]
- ["mkh" "Mon-Khmer languages" mon_khmer []]
- ["mlg" "Malagasy" malagasy []]
- ["mlt" "Maltese" maltese []]
- ["mnc" "Manchu" manchu []]
- ["mni" "Manipuri" manipuri []]
- ["mno" "Manobo languages" manobo []]
- ["moh" "Mohawk" mohawk []]
- ["mon" "Mongolian" mongolian []]
- ["mos" "Mossi" mossi []]
- ["mri" "Maori" maori []]
- ["msa" "Malay" malay []]
- ["mun" "Munda languages" munda []]
- ["mus" "Creek" creek []]
- ["mwl" "Mirandese" mirandese []]
- ["mwr" "Marwari" marwari []]
- ["mya" "Burmese" burmese []]
- ["myn" "Mayan languages" mayan []]
- ["myv" "Erzya" erzya []]]]
-
- [[["nah" "Nahuatl languages" nahuatl []]
- ["nai" "North American Indian languages" north_american_indian []]
- ["nap" "Neapolitan" neapolitan []]
- ["nau" "Nauru" nauru []]
- ["nav" "Navajo; Navaho" navajo []]
- ["nbl" "South Ndebele" south_ndebele []]
- ["nde" "North Ndebele" north_ndebele []]
- ["ndo" "Ndonga" ndonga []]
- ["nds" "Low German; Low Saxon" low_german []]
- ["nep" "Nepali" nepali []]
- ["new" "Nepal Bhasa; Newari" newari [[nepal_bhasa]]]
- ["nia" "Nias" nias []]
- ["nic" "Niger-Kordofanian languages" niger_kordofanian []]
- ["niu" "Niuean" niuean []]
- ["nld" "Dutch; Flemish" dutch [[flemish]]]
- ["nno" "Norwegian Nynorsk" nynorsk []]
- ["nob" "Norwegian Bokmål" bokmal []]
- ["nog" "Nogai" nogai []]
- ["non" "Old Norse" old_norse []]
- ["nor" "Norwegian" norwegian []]
- ["nqo" "N'Ko" n'ko []]
- ["nso" "Pedi; Sepedi; Northern Sotho" northern_sotho [[pedi] [sepedi]]]
- ["nub" "Nubian languages" nubian []]
- ["nwc" "Classical Newari; Old Newari; Classical Nepal Bhasa" old_newari [[classical_newari] [classical_nepal_bhasa]]]
- ["nya" "Chichewa; Chewa; Nyanja" nyanja [[chichewa] [chewa]]]
- ["nym" "Nyamwezi" nyamwezi []]
- ["nyn" "Nyankole" nyankole []]
- ["nyo" "Nyoro" nyoro []]
- ["nzi" "Nzima" nzima []]]]
-
- [[["oci" "Occitan (post 1500); Provençal" occitan [[provencal]]]
- ["oji" "Ojibwa" ojibwa []]
- ["ori" "Oriya" oriya []]
- ["orm" "Oromo" oromo []]
- ["osa" "Osage" osage []]
- ["oss" "Ossetian; Ossetic" ossetic []]
- ["ota" "Ottoman Turkish (1500–1928)" ottoman_turkish []]
- ["oto" "Otomian languages" otomian []]]]
-
- [[["paa" "Papuan languages" papuan []]
- ["pag" "Pangasinan" pangasinan []]
- ["pal" "Pahlavi" pahlavi []]
- ["pam" "Pampanga; Kapampangan" pampanga [[kapampangan]]]
- ["pan" "Panjabi; Punjabi" punjabi []]
- ["pap" "Papiamento" papiamento []]
- ["pau" "Palauan" palauan []]
- ["peo" "Old Persian (ca. 600–400 B.C.)" old_persian []]
- ["phi" "Philippine languages" philippine []]
- ["phn" "Phoenician" phoenician []]
- ["pli" "Pali" pali []]
- ["pol" "Polish" polish []]
- ["pon" "Pohnpeian" pohnpeian []]
- ["por" "Portuguese" portuguese []]
- ["pra" "Prakrit languages" prakrit []]
- ["pro" "Old Provençal (to 1500); Old Occitan (to 1500)" old_provencal []]
- ["pus" "Pushto; Pashto" pashto []]]]
-
- [[["que" "Quechua" quechua []]]]
-
- [[["raj" "Rajasthani" rajasthani []]
- ["rap" "Rapanui" rapanui []]
- ["rar" "Rarotongan; Cook Islands Maori" rarotongan [[cook_islands_maori]]]
- ["roa" "Romance languages" romance []]
- ["roh" "Romansh" romansh []]
- ["rom" "Romany" romany []]
- ["ron" "Romanian; Moldavian; Moldovan" romanian [[moldavian] [moldovan]]]
- ["run" "Rundi" rundi []]
- ["rup" "Aromanian; Arumanian; Macedo-Romanian" aromanian [[arumanian] [macedo_romanian]]]
- ["rus" "Russian" russian []]]]
-
- [[["sad" "Sandawe" sandawe []]
- ["sag" "Sango" sango []]
- ["sah" "Yakut" yakut []]
- ["sai" "South American Indian (Other)" south_american_indian []]
- ["sal" "Salishan languages" salishan []]
- ["sam" "Samaritan Aramaic" samaritan_aramaic []]
- ["san" "Sanskrit" sanskrit []]
- ["sas" "Sasak" sasak []]
- ["sat" "Santali" santali []]
- ["scn" "Sicilian" sicilian []]
- ["sco" "Scots" scots []]
- ["sel" "Selkup" selkup []]
- ["sem" "Semitic languages" semitic []]
- ["sga" "Old Irish (to 900)" old_irish []]
- ["sgn" "Sign Languages" sign []]
- ["shn" "Shan" shan []]
- ["sid" "Sidamo" sidamo []]
- ["sin" "Sinhala; Sinhalese" sinhalese []]
- ["sio" "Siouan languages" siouan []]
- ["sit" "Sino-Tibetan languages" sino_tibetan []]
- ["sla" "Slavic languages" slavic []]
- ["slk" "Slovak" slovak []]
- ["slv" "Slovenian" slovenian []]
- ["sma" "Southern Sami" southern_sami []]
- ["sme" "Northern Sami" northern_sami []]
- ["smi" "Sami languages" sami []]
- ["smj" "Lule Sami" lule []]
- ["smn" "Inari Sami" inari []]
- ["smo" "Samoan" samoan []]
- ["sms" "Skolt Sami" skolt_sami []]
- ["sna" "Shona" shona []]
- ["snd" "Sindhi" sindhi []]
- ["snk" "Soninke" soninke []]
- ["sog" "Sogdian" sogdian []]
- ["som" "Somali" somali []]
- ["son" "Songhai languages" songhai []]
- ["sot" "Southern Sotho" southern_sotho []]
- ["spa" "Spanish; Castilian" spanish [[castilian]]]
- ["sqi" "Albanian" albanian []]
- ["srd" "Sardinian" sardinian []]
- ["srn" "Sranan Tongo" sranan_tongo []]
- ["srp" "Serbian" serbian []]
- ["srr" "Serer" serer []]
- ["ssa" "Nilo-Saharan languages" nilo_saharan []]
- ["ssw" "Swati" swati []]
- ["suk" "Sukuma" sukuma []]
- ["sun" "Sundanese" sundanese []]
- ["sus" "Susu" susu []]
- ["sux" "Sumerian" sumerian []]
- ["swa" "Swahili" swahili []]
- ["swe" "Swedish" swedish []]
- ["syc" "Classical Syriac" classical_syriac []]
- ["syr" "Syriac" syriac []]]]
-
- [[["tah" "Tahitian" tahitian []]
- ["tai" "Tai languages" tai []]
- ["tam" "Tamil" tamil []]
- ["tat" "Tatar" tatar []]
- ["tel" "Telugu" telugu []]
- ["tem" "Timne" timne []]
- ["ter" "Tereno" tereno []]
- ["tet" "Tetum" tetum []]
- ["tgk" "Tajik" tajik []]
- ["tgl" "Tagalog" tagalog []]
- ["tha" "Thai" thai []]
- ["tig" "Tigre" tigre []]
- ["tir" "Tigrinya" tigrinya []]
- ["tiv" "Tiv" tiv []]
- ["tkl" "Tokelau" tokelau []]
- ["tlh" "Klingon; tlhIngan-Hol" klingon []]
- ["tli" "Tlingit" tlingit []]
- ["tmh" "Tamashek" tamashek []]
- ["tog" "Tonga (Nyasa)" tonga []]
- ["ton" "Tonga (Tonga Islands)" tongan []]
- ["tpi" "Tok Pisin" tok_pisin []]
- ["tsi" "Tsimshian" tsimshian []]
- ["tsn" "Tswana" tswana []]
- ["tso" "Tsonga" tsonga []]
- ["tuk" "Turkmen" turkmen []]
- ["tum" "Tumbuka" tumbuka []]
- ["tup" "Tupi languages" tupi []]
- ["tur" "Turkish" turkish []]
- ["tut" "Altaic languages" altaic []]
- ["tvl" "Tuvalu" tuvalu []]
- ["twi" "Twi" twi []]
- ["tyv" "Tuvinian" tuvinian []]]]
-
- [[["udm" "Udmurt" udmurt []]
- ["uga" "Ugaritic" ugaritic []]
- ["uig" "Uighur; Uyghur" uyghur []]
- ["ukr" "Ukrainian" ukrainian []]
- ["umb" "Umbundu" umbundu []]
- ["urd" "Urdu" urdu []]
- ["uzb" "Uzbek" uzbek []]]]
-
- [[["vai" "Vai" vai []]
- ["ven" "Venda" venda []]
- ["vie" "Vietnamese" vietnamese []]
- ["vol" "Volapük" volapük []]
- ["vot" "Votic" votic []]]]
-
- [[["wak" "Wakashan languages" wakashan []]
- ["wal" "Wolaitta; Wolaytta" walamo []]
- ["war" "Waray" waray []]
- ["was" "Washo" washo []]
- ["wen" "Sorbian languages" sorbian []]
- ["wln" "Walloon" walloon []]
- ["wol" "Wolof" wolof []]]]
-
- [[["xal" "Kalmyk; Oirat" kalmyk [[oirat]]]
- ["xho" "Xhosa" xhosa []]]]
-
- [[["yao" "Yao" yao []]
- ["yap" "Yapese" yapese []]
- ["yid" "Yiddish" yiddish []]
- ["yor" "Yoruba" yoruba []]
- ["ypk" "Yupik languages" yupik []]]]
-
- [[["zap" "Zapotec" zapotec []]
- ["zbl" "Blissymbols; Blissymbolics; Bliss" blissymbols []]
- ["zen" "Zenaga" zenaga []]
- ["zgh" "Standard Moroccan Tamazight" standard_moroccan_tamazight []]
- ["zha" "Zhuang; Chuang" zhuang []]
- ["zho" "Chinese" chinese []]
- ["znd" "Zande languages" zande []]
- ["zul" "Zulu" zulu []]
- ["zun" "Zuni" zuni []]
- ["zza" "Zaza; Dimili; Dimli; Kirdki; Kirmanjki; Zazaki" zaza [[dimili] [dimli] [kirdki] [kirmanjki] [zazaki]]]]])
-
- (implementation: #export equivalence
- (Equivalence Language)
-
- (def: (= reference sample)
- (is? reference sample)))
-
- (implementation: #export hash
- (Hash Language)
-
- (def: &equivalence
- ..equivalence)
-
- (def: hash
- (|>> ..code
- (\ text.hash hash))))
- )
diff --git a/stdlib/source/lux/locale/territory.lux b/stdlib/source/lux/locale/territory.lux
deleted file mode 100644
index dfb20896c..000000000
--- a/stdlib/source/lux/locale/territory.lux
+++ /dev/null
@@ -1,311 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]]
- [data
- ["." text]]
- [type
- abstract]
- [macro
- ["." template]]])
-
-## https://en.wikipedia.org/wiki/ISO_3166-1
-(abstract: #export Territory
- {#name Text
- #short Text
- #long Text
- #code Nat}
-
- (template [<name> <field> <type>]
- [(def: #export <name>
- (-> Territory <type>)
- (|>> :representation
- (get@ <field>)))]
-
- [name #name Text]
- [short_code #short Text]
- [long_code #long Text]
- [numeric_code #code Nat]
- )
-
- (template [<short> <long> <number> <name> <main> <neighbor>+]
- [(def: #export <main>
- Territory
- (:abstraction {#name <name>
- #short <short>
- #long <long>
- #code <number>}))
-
- (`` (template [<neighbor>]
- [(def: #export <neighbor> Territory <main>)]
-
- (~~ (template.splice <neighbor>+))))]
-
- ["AF" "AFG" 004 "Afghanistan" afghanistan []]
- ["AX" "ALA" 248 "Ã…land Islands" aland_islands []]
- ["AL" "ALB" 008 "Albania" albania []]
- ["DZ" "DZA" 012 "Algeria" algeria []]
- ["AS" "ASM" 016 "American Samoa" american_samoa []]
- ["AD" "AND" 020 "Andorra" andorra []]
- ["AO" "AGO" 024 "Angola" angola []]
- ["AI" "AIA" 660 "Anguilla" anguilla []]
- ["AQ" "ATA" 010 "Antarctica" antarctica []]
- ["AG" "ATG" 028 "Antigua and Barbuda" antigua [[barbuda]]]
- ["AR" "ARG" 032 "Argentina" argentina []]
- ["AM" "ARM" 051 "Armenia" armenia []]
- ["AW" "ABW" 533 "Aruba" aruba []]
- ["AU" "AUS" 036 "Australia" australia []]
- ["AT" "AUT" 040 "Austria" austria []]
- ["AZ" "AZE" 031 "Azerbaijan" azerbaijan []]
- ["BS" "BHS" 044 "The Bahamas" the_bahamas []]
- ["BH" "BHR" 048 "Bahrain" bahrain []]
- ["BD" "BGD" 050 "Bangladesh" bangladesh []]
- ["BB" "BRB" 052 "Barbados" barbados []]
- ["BY" "BLR" 112 "Belarus" belarus []]
- ["BE" "BEL" 056 "Belgium" belgium []]
- ["BZ" "BLZ" 084 "Belize" belize []]
- ["BJ" "BEN" 204 "Benin" benin []]
- ["BM" "BMU" 060 "Bermuda" bermuda []]
- ["BT" "BTN" 064 "Bhutan" bhutan []]
- ["BO" "BOL" 068 "Bolivia" bolivia []]
- ["BQ" "BES" 535 "Bonaire, Sint Eustatius and Saba" bonaire [[sint_eustatius] [saba]]]
- ["BA" "BIH" 070 "Bosnia and Herzegovina" bosnia [[herzegovina]]]
- ["BW" "BWA" 072 "Botswana" botswana []]
- ["BV" "BVT" 074 "Bouvet Island" bouvet_island []]
- ["BR" "BRA" 076 "Brazil" brazil []]
- ["IO" "IOT" 086 "British Indian Ocean Territory" british_indian_ocean_territory []]
- ["BN" "BRN" 096 "Brunei Darussalam" brunei_darussalam []]
- ["BG" "BGR" 100 "Bulgaria" bulgaria []]
- ["BF" "BFA" 854 "Burkina Faso" burkina_faso []]
- ["BI" "BDI" 108 "Burundi" burundi []]
- ["CV" "CPV" 132 "Cape Verde" cape_verde []]
- ["KH" "KHM" 116 "Cambodia" cambodia []]
- ["CM" "CMR" 120 "Cameroon" cameroon []]
- ["CA" "CAN" 124 "Canada" canada []]
- ["KY" "CYM" 136 "Cayman Islands" cayman_islands []]
- ["CF" "CAF" 140 "Central African Republic" central_african_republic []]
- ["TD" "TCD" 148 "Chad" chad []]
- ["CL" "CHL" 152 "Chile" chile []]
- ["CN" "CHN" 156 "China" china []]
- ["CX" "CXR" 162 "Christmas Island" christmas_island []]
- ["CC" "CCK" 166 "Cocos (Keeling) Islands" cocos_islands []]
- ["CO" "COL" 170 "Colombia" colombia []]
- ["KM" "COM" 174 "Comoros" comoros []]
- ["CG" "COG" 178 "Congo" congo []]
- ["CD" "COD" 180 "Democratic Republic of the Congo" democratic_republic_of_the_congo []]
- ["CK" "COK" 184 "Cook Islands" cook_islands []]
- ["CR" "CRI" 188 "Costa Rica" costa_rica []]
- ["CI" "CIV" 384 "Ivory Coast" ivory_coast []]
- ["HR" "HRV" 191 "Croatia" croatia []]
- ["CU" "CUB" 192 "Cuba" cuba []]
- ["CW" "CUW" 531 "Curacao" curacao []]
- ["CY" "CYP" 196 "Cyprus" cyprus []]
- ["CZ" "CZE" 203 "Czech Republic" czech_republic []]
- ["DK" "DNK" 208 "Denmark" denmark []]
- ["DJ" "DJI" 262 "Djibouti" djibouti []]
- ["DM" "DMA" 212 "Dominica" dominica []]
- ["DO" "DOM" 214 "Dominican Republic" dominican_republic []]
- ["EC" "ECU" 218 "Ecuador" ecuador []]
- ["EG" "EGY" 818 "Egypt" egypt []]
- ["SV" "SLV" 222 "El Salvador" el_salvador []]
- ["GQ" "GNQ" 226 "Equatorial Guinea" equatorial_guinea []]
- ["ER" "ERI" 232 "Eritrea" eritrea []]
- ["EE" "EST" 233 "Estonia" estonia []]
- ["SZ" "SWZ" 748 "Eswatini" eswatini []]
- ["ET" "ETH" 231 "Ethiopia" ethiopia []]
- ["FK" "FLK" 238 "Falkland Islands" falkland_islands []]
- ["FO" "FRO" 234 "Faroe Islands" faroe_islands []]
- ["FJ" "FJI" 242 "Fiji" fiji []]
- ["FI" "FIN" 246 "Finland" finland []]
- ["FR" "FRA" 250 "France" france []]
- ["GF" "GUF" 254 "French Guiana" french_guiana []]
- ["PF" "PYF" 258 "French Polynesia" french_polynesia []]
- ["TF" "ATF" 260 "French Southern Territories" french_southern_territories []]
- ["GA" "GAB" 266 "Gabon" gabon []]
- ["GM" "GMB" 270 "The Gambia" the_gambia []]
- ["GE" "GEO" 268 "Georgia" georgia []]
- ["DE" "DEU" 276 "Germany" germany []]
- ["GH" "GHA" 288 "Ghana" ghana []]
- ["GI" "GIB" 292 "Gibraltar" gibraltar []]
- ["GR" "GRC" 300 "Greece" greece []]
- ["GL" "GRL" 304 "Greenland" greenland []]
- ["GD" "GRD" 308 "Grenada" grenada []]
- ["GP" "GLP" 312 "Guadeloupe" guadeloupe []]
- ["GU" "GUM" 316 "Guam" guam []]
- ["GT" "GTM" 320 "Guatemala" guatemala []]
- ["GG" "GGY" 831 "Guernsey" guernsey []]
- ["GN" "GIN" 324 "Guinea" guinea []]
- ["GW" "GNB" 624 "Guinea-Bissau" guinea_bissau []]
- ["GY" "GUY" 328 "Guyana" guyana []]
- ["HT" "HTI" 332 "Haiti" haiti []]
- ["HM" "HMD" 334 "Heard Island and McDonald Islands" heard_island [[mcdonald_islands]]]
- ["VA" "VAT" 336 "Vatican City" vatican_city []]
- ["HN" "HND" 340 "Honduras" honduras []]
- ["HK" "HKG" 344 "Hong Kong" hong_kong []]
- ["HU" "HUN" 348 "Hungary" hungary []]
- ["IS" "ISL" 352 "Iceland" iceland []]
- ["IN" "IND" 356 "India" india []]
- ["ID" "IDN" 360 "Indonesia" indonesia []]
- ["IR" "IRN" 364 "Iran" iran []]
- ["IQ" "IRQ" 368 "Iraq" iraq []]
- ["IE" "IRL" 372 "Ireland" ireland []]
- ["IM" "IMN" 833 "Isle of Man" isle_of_man []]
- ["IL" "ISR" 376 "Israel" israel []]
- ["IT" "ITA" 380 "Italy" italy []]
- ["JM" "JAM" 388 "Jamaica" jamaica []]
- ["JP" "JPN" 392 "Japan" japan []]
- ["JE" "JEY" 832 "Jersey" jersey []]
- ["JO" "JOR" 400 "Jordan" jordan []]
- ["KZ" "KAZ" 398 "Kazakhstan" kazakhstan []]
- ["KE" "KEN" 404 "Kenya" kenya []]
- ["KI" "KIR" 296 "Kiribati" kiribati []]
- ["KP" "PRK" 408 "North Korea" north_korea []]
- ["KR" "KOR" 410 "South Korea" south_korea []]
- ["KW" "KWT" 414 "Kuwait" kuwait []]
- ["KG" "KGZ" 417 "Kyrgyzstan" kyrgyzstan []]
- ["LA" "LAO" 418 "Laos" laos []]
- ["LV" "LVA" 428 "Latvia" latvia []]
- ["LB" "LBN" 422 "Lebanon" lebanon []]
- ["LS" "LSO" 426 "Lesotho" lesotho []]
- ["LR" "LBR" 430 "Liberia" liberia []]
- ["LY" "LBY" 434 "Libya" libya []]
- ["LI" "LIE" 438 "Liechtenstein" liechtenstein []]
- ["LT" "LTU" 440 "Lithuania" lithuania []]
- ["LU" "LUX" 442 "Luxembourg" luxembourg []]
- ["MO" "MAC" 446 "Macau" macau []]
- ["MK" "MKD" 807 "Macedonia" macedonia []]
- ["MG" "MDG" 450 "Madagascar" madagascar []]
- ["MW" "MWI" 454 "Malawi" malawi []]
- ["MY" "MYS" 458 "Malaysia" malaysia []]
- ["MV" "MDV" 462 "Maldives" maldives []]
- ["ML" "MLI" 466 "Mali" mali []]
- ["MT" "MLT" 470 "Malta" malta []]
- ["MH" "MHL" 584 "Marshall Islands" marshall_islands []]
- ["MQ" "MTQ" 474 "Martinique" martinique []]
- ["MR" "MRT" 478 "Mauritania" mauritania []]
- ["MU" "MUS" 480 "Mauritius" mauritius []]
- ["YT" "MYT" 175 "Mayotte" mayotte []]
- ["MX" "MEX" 484 "Mexico" mexico []]
- ["FM" "FSM" 583 "Micronesia" micronesia []]
- ["MD" "MDA" 498 "Moldova" moldova []]
- ["MC" "MCO" 492 "Monaco" monaco []]
- ["MN" "MNG" 496 "Mongolia" mongolia []]
- ["ME" "MNE" 499 "Montenegro" montenegro []]
- ["MS" "MSR" 500 "Montserrat" montserrat []]
- ["MA" "MAR" 504 "Morocco" morocco []]
- ["MZ" "MOZ" 508 "Mozambique" mozambique []]
- ["MM" "MMR" 104 "Myanmar" myanmar []]
- ["NA" "NAM" 516 "Namibia" namibia []]
- ["NR" "NRU" 520 "Nauru" nauru []]
- ["NP" "NPL" 524 "Nepal" nepal []]
- ["NL" "NLD" 528 "Netherlands" netherlands []]
- ["NC" "NCL" 540 "New Caledonia" new_caledonia []]
- ["NZ" "NZL" 554 "New Zealand" new_zealand []]
- ["NI" "NIC" 558 "Nicaragua" nicaragua []]
- ["NE" "NER" 562 "Niger" niger []]
- ["NG" "NGA" 566 "Nigeria" nigeria []]
- ["NU" "NIU" 570 "Niue" niue []]
- ["NF" "NFK" 574 "Norfolk Island" norfolk_island []]
- ["MP" "MNP" 580 "Northern Mariana Islands" northern_mariana_islands []]
- ["NO" "NOR" 578 "Norway" norway []]
- ["OM" "OMN" 512 "Oman" oman []]
- ["PK" "PAK" 586 "Pakistan" pakistan []]
- ["PW" "PLW" 585 "Palau" palau []]
- ["PS" "PSE" 275 "Palestine" palestine []]
- ["PA" "PAN" 591 "Panama" panama []]
- ["PG" "PNG" 598 "Papua New Guinea" papua_new_guinea []]
- ["PY" "PRY" 600 "Paraguay" paraguay []]
- ["PE" "PER" 604 "Peru" peru []]
- ["PH" "PHL" 608 "Philippines" philippines []]
- ["PN" "PCN" 612 "Pitcairn Islands" pitcairn_islands []]
- ["PL" "POL" 616 "Poland" poland []]
- ["PT" "PRT" 620 "Portugal" portugal []]
- ["PR" "PRI" 630 "Puerto Rico" puerto_rico []]
- ["QA" "QAT" 634 "Qatar" qatar []]
- ["RE" "REU" 638 "Reunion" reunion []]
- ["RO" "ROU" 642 "Romania" romania []]
- ["RU" "RUS" 643 "Russia" russia []]
- ["RW" "RWA" 646 "Rwanda" rwanda []]
- ["BL" "BLM" 652 "Saint Barthélemy" saint_barthelemy []]
- ["SH" "SHN" 654 "Saint Helena, Ascension and Tristan da Cunha" saint_helena [[ascension] [tristan_da_cunha]]]
- ["KN" "KNA" 659 "Saint Kitts and Nevis" saint_kitts [[nevis]]]
- ["LC" "LCA" 662 "Saint Lucia" saint_lucia []]
- ["MF" "MAF" 663 "Saint Martin" saint_martin []]
- ["PM" "SPM" 666 "Saint Pierre and Miquelon" saint_pierre [[miquelon]]]
- ["VC" "VCT" 670 "Saint Vincent and the Grenadines" saint_vincent [[the_grenadines]]]
- ["WS" "WSM" 882 "Samoa" samoa []]
- ["SM" "SMR" 674 "San Marino" san_marino []]
- ["ST" "STP" 678 "Sao Tome and Principe" sao_tome [[principe]]]
- ["SA" "SAU" 682 "Saudi Arabia" saudi_arabia []]
- ["SN" "SEN" 686 "Senegal" senegal []]
- ["RS" "SRB" 688 "Serbia" serbia []]
- ["SC" "SYC" 690 "Seychelles" seychelles []]
- ["SL" "SLE" 694 "Sierra Leone" sierra_leone []]
- ["SG" "SGP" 702 "Singapore" singapore []]
- ["SX" "SXM" 534 "Sint Maarten" sint_maarten []]
- ["SK" "SVK" 703 "Slovakia" slovakia []]
- ["SI" "SVN" 705 "Slovenia" slovenia []]
- ["SB" "SLB" 090 "Solomon Islands" solomon_islands []]
- ["SO" "SOM" 706 "Somalia" somalia []]
- ["ZA" "ZAF" 710 "South Africa" south_africa []]
- ["GS" "SGS" 239 "South Georgia and the South Sandwich Islands" south_georgia [[south_sandwich_islands]]]
- ["SS" "SSD" 728 "South Sudan" south_sudan []]
- ["ES" "ESP" 724 "Spain" spain []]
- ["LK" "LKA" 144 "Sri Lanka" sri_lanka []]
- ["SD" "SDN" 729 "Sudan" sudan []]
- ["SR" "SUR" 740 "Suriname" suriname []]
- ["SJ" "SJM" 744 "Svalbard and Jan Mayen" svalbard [[jan_mayen]]]
- ["SE" "SWE" 752 "Sweden" sweden []]
- ["CH" "CHE" 756 "Switzerland" switzerland []]
- ["SY" "SYR" 760 "Syria" syria []]
- ["TW" "TWN" 158 "Taiwan" taiwan []]
- ["TJ" "TJK" 762 "Tajikistan" tajikistan []]
- ["TZ" "TZA" 834 "Tanzania" tanzania []]
- ["TH" "THA" 764 "Thailand" thailand []]
- ["TL" "TLS" 626 "East Timor" east_timor []]
- ["TG" "TGO" 768 "Togo" togo []]
- ["TK" "TKL" 772 "Tokelau" tokelau []]
- ["TO" "TON" 776 "Tonga" tonga []]
- ["TT" "TTO" 780 "Trinidad and Tobago" trinidad [[tobago]]]
- ["TN" "TUN" 788 "Tunisia" tunisia []]
- ["TR" "TUR" 792 "Turkey" turkey []]
- ["TM" "TKM" 795 "Turkmenistan" turkmenistan []]
- ["TC" "TCA" 796 "Turks and Caicos Islands" turks [[caicos_islands]]]
- ["TV" "TUV" 798 "Tuvalu" tuvalu []]
- ["UG" "UGA" 800 "Uganda" uganda []]
- ["UA" "UKR" 804 "Ukraine" ukraine []]
- ["AE" "ARE" 784 "United Arab Emirates" united_arab_emirates []]
- ["GB" "GBR" 826 "United Kingdom of Great Britain and Northern Ireland" united_kingdom [[northern_ireland]]]
- ["US" "USA" 840 "United States of America" united_states_of_america []]
- ["UM" "UMI" 581 "United States Minor Outlying Islands" united_states_minor_outlying_islands []]
- ["UY" "URY" 858 "Uruguay" uruguay []]
- ["UZ" "UZB" 860 "Uzbekistan" uzbekistan []]
- ["VU" "VUT" 548 "Vanuatu" vanuatu []]
- ["VE" "VEN" 862 "Venezuela" venezuela []]
- ["VN" "VNM" 704 "Vietnam" vietnam []]
- ["VG" "VGB" 092 "British Virgin Islands" british_virgin_islands []]
- ["VI" "VIR" 850 "United States Virgin Islands" united_states_virgin_islands []]
- ["WF" "WLF" 876 "Wallis and Futuna" wallis [[futuna]]]
- ["EH" "ESH" 732 "Western Sahara" western_sahara []]
- ["YE" "YEM" 887 "Yemen" yemen []]
- ["ZM" "ZMB" 894 "Zambia" zambia []]
- ["ZW" "ZWE" 716 "Zimbabwe" zimbabwe []]
- )
-
- (implementation: #export equivalence
- (Equivalence Territory)
-
- (def: (= reference sample)
- (is? reference sample)))
-
- (implementation: #export hash
- (Hash Territory)
-
- (def: &equivalence ..equivalence)
-
- (def: hash
- (|>> :representation
- (get@ #long)
- (\ text.hash hash))))
- )
diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux
deleted file mode 100644
index 1b83d179a..000000000
--- a/stdlib/source/lux/macro.lux
+++ /dev/null
@@ -1,209 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." text ("#\." monoid)]
- ["." name ("#\." codec)]
- [collection
- ["." list ("#\." monoid monad)]]]
- [macro
- ["." code]]
- [math
- [number
- ["." nat]
- ["." int]]]]
- ["." // #_
- ["#" meta
- ["." location]]])
-
-(def: #export (expand_once syntax)
- {#.doc (doc "Given code that requires applying a macro, does it once and returns the result."
- "Otherwise, returns the code as-is.")}
- (-> Code (Meta (List Code)))
- (case syntax
- [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))]
- (do //.monad
- [?macro (//.find_macro name)]
- (case ?macro
- (#.Some macro)
- ((:as Macro' macro) args)
-
- #.None
- (\ //.monad wrap (list syntax))))
-
- _
- (\ //.monad wrap (list syntax))))
-
-(def: #export (expand syntax)
- {#.doc (doc "Given code that requires applying a macro, expands repeatedly until no more direct macro-calls are left."
- "Otherwise, returns the code as-is.")}
- (-> Code (Meta (List Code)))
- (case syntax
- [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))]
- (do //.monad
- [?macro (//.find_macro name)]
- (case ?macro
- (#.Some macro)
- (do //.monad
- [expansion ((:as Macro' macro) args)
- expansion' (monad.map //.monad expand expansion)]
- (wrap (list\join expansion')))
-
- #.None
- (\ //.monad wrap (list syntax))))
-
- _
- (\ //.monad wrap (list syntax))))
-
-(def: #export (expand_all syntax)
- {#.doc "Expands all macro-calls everywhere recursively, until only primitive/base code remains."}
- (-> Code (Meta (List Code)))
- (case syntax
- [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))]
- (do //.monad
- [?macro (//.find_macro name)]
- (case ?macro
- (#.Some macro)
- (do //.monad
- [expansion ((:as Macro' macro) args)
- expansion' (monad.map //.monad expand_all expansion)]
- (wrap (list\join expansion')))
-
- #.None
- (do //.monad
- [parts' (monad.map //.monad expand_all (list& (code.identifier name) args))]
- (wrap (list (code.form (list\join parts')))))))
-
- [_ (#.Form (#.Cons [harg targs]))]
- (do //.monad
- [harg+ (expand_all harg)
- targs+ (monad.map //.monad expand_all targs)]
- (wrap (list (code.form (list\compose harg+ (list\join (: (List (List Code)) targs+)))))))
-
- [_ (#.Tuple members)]
- (do //.monad
- [members' (monad.map //.monad expand_all members)]
- (wrap (list (code.tuple (list\join members')))))
-
- [_ (#.Record members)]
- (|> members
- (monad.map //.monad
- (function (_ [left right])
- (do //.monad
- [left (expand_all left)
- right (expand_all right)]
- (case [left right]
- [(#.Cons left #.Nil) (#.Cons right #.Nil)]
- (wrap [left right])
-
- _
- (//.fail "Record members must expand into singletons.")))))
- (\ //.monad map (|>> code.record list)))
-
- _
- (\ //.monad wrap (list syntax))))
-
-(def: #export (gensym prefix)
- {#.doc (doc "Generates a unique name as an Code node (ready to be used in code templates)."
- "A prefix can be given (or just be empty text) to better identify the code for debugging purposes.")}
- (-> Text (Meta Code))
- (do //.monad
- [id //.count]
- (wrap (|> id
- (\ nat.decimal encode)
- ($_ text\compose "__gensym__" prefix)
- [""] code.identifier))))
-
-(def: (get_local_identifier ast)
- (-> Code (Meta Text))
- (case ast
- [_ (#.Identifier [_ name])]
- (\ //.monad wrap name)
-
- _
- (//.fail (text\compose "Code is not a local identifier: " (code.format ast)))))
-
-(def: #export wrong_syntax_error
- (-> Name Text)
- (|>> name\encode
- (text\compose "Wrong syntax for ")))
-
-(macro: #export (with_gensyms tokens)
- {#.doc (doc "Creates new identifiers 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 [_ (#.Tuple identifiers)] body))
- (do {! //.monad}
- [identifier_names (monad.map ! ..get_local_identifier identifiers)
- #let [identifier_defs (list\join (list\map (: (-> Text (List Code))
- (function (_ name) (list (code.identifier ["" name]) (` (gensym (~ (code.text name)))))))
- identifier_names))]]
- (wrap (list (` ((~! do) (~! //.monad)
- [(~+ identifier_defs)]
- (~ body))))))
-
- _
- (//.fail (..wrong_syntax_error (name_of ..with_gensyms)))))
-
-(def: #export (expand_1 token)
- {#.doc "Works just like expand, except that it ensures that the output is a single Code token."}
- (-> Code (Meta Code))
- (do //.monad
- [token+ (..expand token)]
- (case token+
- (^ (list token'))
- (wrap token')
-
- _
- (//.fail "Macro expanded to more than 1 element."))))
-
-(template [<macro> <func>]
- [(macro: #export (<macro> tokens)
- {#.doc (doc "Performs a macro-expansion and logs the resulting code."
- "You can either use the resulting code, or omit them."
- "By omitting them, this macro produces nothing (just like the lux.comment macro)."
- (<macro> #omit
- (def: (foo bar baz)
- (-> Int Int Int)
- (int.+ bar baz))))}
- (let [[module _] (name_of .._)
- [_ short] (name_of <macro>)
- macro_name [module short]]
- (case (: (Maybe [Bit Code])
- (case tokens
- (^ (list [_ (#.Tag ["" "omit"])]
- token))
- (#.Some [#1 token])
-
- (^ (list token))
- (#.Some [#0 token])
-
- _
- #.None))
- (#.Some [omit? token])
- (do //.monad
- [location //.location
- output (<func> token)
- #let [_ ("lux io log" ($_ text\compose (name\encode macro_name) " " (location.format location)))
- _ (list\map (|>> code.format "lux io log")
- output)
- _ ("lux io log" "")]]
- (wrap (if omit?
- (list)
- output)))
-
- #.None
- (//.fail (..wrong_syntax_error macro_name)))))]
-
- [log_expand_once! expand_once]
- [log_expand! expand]
- [log_expand_all! expand_all]
- )
diff --git a/stdlib/source/lux/macro/code.lux b/stdlib/source/lux/macro/code.lux
deleted file mode 100644
index a17b38233..000000000
--- a/stdlib/source/lux/macro/code.lux
+++ /dev/null
@@ -1,160 +0,0 @@
-(.module:
- [lux (#- nat int rev)
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- ["." product]
- ["." bit]
- ["." name]
- ["." text ("#\." monoid equivalence)]
- [collection
- ["." list ("#\." functor fold)]]]
- [math
- [number
- ["." nat]
- ["." int]
- ["." rev]
- ["." frac]]]
- [meta
- ["." location]]])
-
-## (type: (Code' w)
-## (#.Bit Bit)
-## (#.Nat Nat)
-## (#.Int Int)
-## (#.Rev Rev)
-## (#.Frac Frac)
-## (#.Text Text)
-## (#.Identifier Name)
-## (#.Tag Name)
-## (#.Form (List (w (Code' w))))
-## (#.Tuple (List (w (Code' w))))
-## (#.Record (List [(w (Code' w)) (w (Code' w))])))
-
-## (type: Code
-## (Ann Location (Code' (Ann Location))))
-
-(template [<name> <type> <tag>]
- [(def: #export (<name> x)
- (-> <type> Code)
- [location.dummy (<tag> x)])]
-
- [bit Bit #.Bit]
- [nat Nat #.Nat]
- [int Int #.Int]
- [rev Rev #.Rev]
- [frac Frac #.Frac]
- [text Text #.Text]
- [identifier Name #.Identifier]
- [tag Name #.Tag]
- [form (List Code) #.Form]
- [tuple (List Code) #.Tuple]
- [record (List [Code Code]) #.Record]
- )
-
-(template [<name> <tag> <doc>]
- [(def: #export (<name> name)
- {#.doc <doc>}
- (-> Text Code)
- [location.dummy (<tag> ["" name])])]
-
- [local_identifier #.Identifier "Produces a local identifier (an identifier with no module prefix)."]
- [local_tag #.Tag "Produces a local tag (a tag with no module prefix)."])
-
-(implementation: #export equivalence
- (Equivalence Code)
-
- (def: (= x y)
- (case [x y]
- (^template [<tag> <eq>]
- [[[_ (<tag> x')] [_ (<tag> y')]]
- (\ <eq> = x' y')])
- ([#.Bit bit.equivalence]
- [#.Nat nat.equivalence]
- [#.Int int.equivalence]
- [#.Rev rev.equivalence]
- [#.Frac frac.equivalence]
- [#.Text text.equivalence]
- [#.Identifier name.equivalence]
- [#.Tag name.equivalence])
-
- (^template [<tag>]
- [[[_ (<tag> xs')] [_ (<tag> ys')]]
- (\ (list.equivalence =) = xs' ys')])
- ([#.Form]
- [#.Tuple])
-
- [[_ (#.Record xs')] [_ (#.Record ys')]]
- (\ (list.equivalence (product.equivalence = =))
- = xs' ys')
-
- _
- false)))
-
-(def: #export (format ast)
- (-> Code Text)
- (case ast
- (^template [<tag> <struct>]
- [[_ (<tag> value)]
- (\ <struct> encode value)])
- ([#.Bit bit.codec]
- [#.Nat nat.decimal]
- [#.Int int.decimal]
- [#.Rev rev.decimal]
- [#.Frac frac.decimal]
- [#.Identifier name.codec])
-
- [_ (#.Text value)]
- (text.format value)
-
- [_ (#.Tag name)]
- (text\compose "#" (\ name.codec encode name))
-
- (^template [<tag> <open> <close>]
- [[_ (<tag> members)]
- ($_ text\compose
- <open>
- (list\fold (function (_ next prev)
- (let [next (format next)]
- (if (text\= "" prev)
- next
- ($_ text\compose prev " " next))))
- ""
- members)
- <close>)])
- ([#.Form "(" ")"]
- [#.Tuple "[" "]"])
-
- [_ (#.Record pairs)]
- ($_ text\compose
- "{"
- (list\fold (function (_ [left right] prev)
- (let [next ($_ text\compose (format left) " " (format right))]
- (if (text\= "" prev)
- next
- ($_ text\compose prev " " next))))
- ""
- pairs)
- "}")
- ))
-
-(def: #export (replace original substitute ast)
- {#.doc "Replaces all code that looks like the 'original' with the 'substitute'."}
- (-> Code Code Code Code)
- (if (\ ..equivalence = original ast)
- substitute
- (case ast
- (^template [<tag>]
- [[location (<tag> parts)]
- [location (<tag> (list\map (replace original substitute) parts))]])
- ([#.Form]
- [#.Tuple])
-
- [location (#.Record parts)]
- [location (#.Record (list\map (function (_ [left right])
- [(replace original substitute left)
- (replace original substitute right)])
- parts))]
-
- _
- ast)))
diff --git a/stdlib/source/lux/macro/local.lux b/stdlib/source/lux/macro/local.lux
deleted file mode 100644
index fc9e8bef5..000000000
--- a/stdlib/source/lux/macro/local.lux
+++ /dev/null
@@ -1,105 +0,0 @@
-(.module:
- [lux #*
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." product]
- ["." text]
- [collection
- ["." list ("#\." functor)]
- [dictionary
- ["." plist (#+ PList)]]]]]
- ["." //
- ["#." code]])
-
-(exception: #export (unknown_module {module Text})
- (exception.report
- ["Module" (text.format module)]))
-
-(template [<name>]
- [(exception: #export (<name> {module Text} {definition Text})
- (exception.report
- ["Module" (text.format module)]
- ["Definition" (text.format definition)]))]
-
- [cannot_shadow_definition]
- [unknown_definition]
- )
-
-(def: (with_module name body)
- (All [a] (-> Text (-> Module (Try [Module a])) (Meta a)))
- (function (_ compiler)
- (case (|> compiler (get@ #.modules) (plist.get name))
- (#.Some module)
- (case (body module)
- (#try.Success [module' output])
- (#try.Success [(update@ #.modules (plist.put name module') compiler)
- output])
-
- (#try.Failure error)
- (#try.Failure error))
-
- #.None
- (exception.throw ..unknown_module [name]))))
-
-(def: (push_one [name macro])
- (-> [Name Macro] (Meta Any))
- (do meta.monad
- [[module_name definition_name] (meta.normalize name)
- #let [definition (: Global (#.Definition [false .Macro (' {}) macro]))
- add_macro! (: (-> (PList Global) (PList Global))
- (plist.put definition_name definition))]]
- (..with_module module_name
- (function (_ module)
- (case (|> module (get@ #.definitions) (plist.get definition_name))
- #.None
- (#try.Success [(update@ #.definitions add_macro! module)
- []])
-
- (#.Some _)
- (exception.throw ..cannot_shadow_definition [module_name definition_name]))))))
-
-(def: (pop_one name)
- (-> Name (Meta Any))
- (do meta.monad
- [[module_name definition_name] (meta.normalize name)
- #let [remove_macro! (: (-> (PList Global) (PList Global))
- (plist.remove definition_name))]]
- (..with_module module_name
- (function (_ module)
- (case (|> module (get@ #.definitions) (plist.get definition_name))
- (#.Some _)
- (#try.Success [(update@ #.definitions remove_macro! module)
- []])
-
- #.None
- (exception.throw ..unknown_definition [module_name definition_name]))))))
-
-(def: (pop_all macros self)
- (-> (List Name) Name Macro)
- ("lux macro"
- (function (_ _)
- (do {! meta.monad}
- [_ (monad.map ! ..pop_one macros)
- _ (..pop_one self)
- compiler meta.get_compiler]
- (wrap (case (get@ #.expected compiler)
- (#.Some _)
- (list (' []))
-
- #.None
- (list)))))))
-
-(def: #export (push macros)
- (-> (List [Name Macro]) (Meta Code))
- (do meta.monad
- [_ (monad.map meta.monad ..push_one macros)
- seed meta.count
- g!pop (//.gensym "pop")
- _ (let [g!pop (: Name ["" (//code.format g!pop)])]
- (..push_one [g!pop (..pop_all (list\map product.left macros) g!pop)]))]
- (wrap (` ((~ g!pop))))))
diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux
deleted file mode 100644
index d29966a87..000000000
--- a/stdlib/source/lux/macro/poly.lux
+++ /dev/null
@@ -1,127 +0,0 @@
-(.module:
- [lux #*
- ["." meta]
- ["." type]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["p" parser
- ["<.>" type (#+ Env)]
- ["s" code]]]
- [data
- ["." product]
- ["." maybe]
- ["." text]
- [collection
- ["." list ("#\." fold functor)]
- ["." dictionary]]]
- [macro (#+ with_gensyms)
- ["." code]
- [syntax (#+ syntax:)
- ["|.|" export]]]
- [math
- [number
- ["n" nat]]]])
-
-(syntax: #export (poly: {export |export|.parser}
- {name s.local_identifier}
- body)
- (with_gensyms [g!_ g!type g!output]
- (let [g!name (code.identifier ["" name])]
- (wrap (.list (` ((~! syntax:) (~+ (|export|.format export)) ((~ g!name) {(~ g!type) (~! s.identifier)})
- ((~! do) (~! meta.monad)
- [(~ g!type) ((~! meta.find_type_def) (~ g!type))]
- (case (: (.Either .Text .Code)
- ((~! <type>.run) ((~! p.rec)
- (function ((~ g!_) (~ g!name))
- (~ body)))
- (~ g!type)))
- (#.Left (~ g!output))
- ((~! meta.fail) (~ g!output))
-
- (#.Right (~ g!output))
- ((~' wrap) (.list (~ g!output))))))))))))
-
-(def: (common_poly_name? poly_func)
- (-> Text Bit)
- (text.contains? "?" poly_func))
-
-(def: (derivation_name poly args)
- (-> Text (List Text) (Maybe Text))
- (if (common_poly_name? poly)
- (#.Some (list\fold (text.replace_once "?") poly args))
- #.None))
-
-(syntax: #export (derived: {export |export|.parser}
- {?name (p.maybe s.local_identifier)}
- {[poly_func poly_args] (s.form (p.and s.identifier (p.many s.identifier)))}
- {?custom_impl (p.maybe s.any)})
- (do {! meta.monad}
- [poly_args (monad.map ! meta.normalize poly_args)
- name (case ?name
- (#.Some name)
- (wrap name)
-
- (^multi #.None
- [(derivation_name (product.right poly_func) (list\map product.right poly_args))
- (#.Some derived_name)])
- (wrap derived_name)
-
- _
- (p.fail "derived: was given no explicit name, and cannot generate one from given information."))
- #let [impl (case ?custom_impl
- (#.Some custom_impl)
- custom_impl
-
- #.None
- (` ((~ (code.identifier poly_func)) (~+ (list\map code.identifier poly_args)))))]]
- (wrap (.list (` (def: (~+ (|export|.format export))
- (~ (code.identifier ["" name]))
- {#.implementation? #1}
- (~ impl)))))))
-
-(def: #export (to_code env type)
- (-> Env Type Code)
- (case type
- (#.Primitive name params)
- (` (#.Primitive (~ (code.text name))
- (list (~+ (list\map (to_code env) params)))))
-
- (^template [<tag>]
- [(<tag> idx)
- (` (<tag> (~ (code.nat idx))))])
- ([#.Var] [#.Ex])
-
- (#.Parameter idx)
- (let [idx (<type>.adjusted_idx env idx)]
- (if (n.= 0 idx)
- (|> (dictionary.get idx env) maybe.assume product.left (to_code env))
- (` (.$ (~ (code.nat (dec idx)))))))
-
- (#.Apply (#.Named ["lux" "Nothing"] _) (#.Parameter idx))
- (let [idx (<type>.adjusted_idx env idx)]
- (if (n.= 0 idx)
- (|> (dictionary.get idx env) maybe.assume product.left (to_code env))
- (undefined)))
-
- (^template [<tag>]
- [(<tag> left right)
- (` (<tag> (~ (to_code env left))
- (~ (to_code env right))))])
- ([#.Function] [#.Apply])
-
- (^template [<macro> <tag> <flattener>]
- [(<tag> left right)
- (` (<macro> (~+ (list\map (to_code env) (<flattener> type)))))])
- ([| #.Sum type.flatten_variant]
- [& #.Product type.flatten_tuple])
-
- (#.Named name sub_type)
- (code.identifier name)
-
- (^template [<tag>]
- [(<tag> scope body)
- (` (<tag> (list (~+ (list\map (to_code env) scope)))
- (~ (to_code env body))))])
- ([#.UnivQ] [#.ExQ])
- ))
diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux
deleted file mode 100644
index 738ae2a22..000000000
--- a/stdlib/source/lux/macro/syntax.lux
+++ /dev/null
@@ -1,128 +0,0 @@
-(.module:
- [lux #*
- ["." macro (#+ with_gensyms)]
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try]
- ["<>" parser
- ["</>" code (#+ Parser)]]]
- [data
- ["." maybe]
- ["." text ("#\." monoid)]
- [collection
- ["." list ("#\." functor)]]]
- [math
- [number
- ["." nat]
- ["." int]
- ["." rev]
- ["." frac]]]]
- [//
- ["." code]])
-
-(def: (self_documenting binding parser)
- (All [a] (-> Code (Parser a) (Parser a)))
- (function (_ tokens)
- (case (parser tokens)
- (#try.Success [tokens output])
- (#try.Success [tokens output])
-
- (#try.Failure error)
- (#try.Failure ($_ text\compose
- "Failed to parse: " (code.format binding) text.new_line
- error)))))
-
-(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'))))
-
-(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 Meta 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\compose "anon-class:"
- (spaced (list (super_class_decl$ (maybe.default object_super_class super))
- (with_brackets (spaced (list\map super_class_decl$ interfaces)))
- (with_brackets (spaced (list\map constructor_arg$ constructor_args)))
- (with_brackets (spaced (list\map (method_def$ id) methods))))))]
- (wrap (list (` ((~ (code.text def_code)))))))))}
- (let [[exported? tokens] (: [Bit (List Code)]
- (case tokens
- (^ (list& [_ (#.Tag ["" "export"])] tokens'))
- [#1 tokens']
-
- _
- [#0 tokens]))
- ?parts (: (Maybe [Text (List Code) Code Code])
- (case tokens
- (^ (list [_ (#.Form (list& [_ (#.Identifier ["" name])] args))]
- body))
- (#.Some name args (` {}) body)
-
- (^ (list [_ (#.Form (list& [_ (#.Identifier ["" 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!error]
- (do {! meta.monad}
- [vars+parsers (monad.map !
- (: (-> Code (Meta [Code Code]))
- (function (_ arg)
- (case arg
- (^ [_ (#.Record (list [var parser]))])
- (case var
- [_ (#.Tag ["" "let"])]
- (wrap [var parser])
-
- _
- (wrap [var
- (` ((~! ..self_documenting) (' (~ var))
- (~ parser)))]))
-
- [_ (#.Identifier var_name)]
- (wrap [arg
- (` ((~! ..self_documenting) (' (~ arg))
- (~! </>.any)))])
-
- _
- (meta.fail "Syntax pattern expects records or identifiers."))))
- args)
- this_module meta.current_module_name
- #let [g!state (code.identifier ["" "*compiler*"])
- error_msg (code.text (macro.wrong_syntax_error [this_module name]))
- export_ast (: (List Code)
- (if exported?
- (list (' #export))
- (list)))]]
- (wrap (list (` (macro: (~+ export_ast) ((~ (code.identifier ["" name])) (~ g!tokens) (~ g!state))
- (~ meta)
- ({(#.Right (~ g!body))
- ((~ g!body) (~ g!state))
-
- (#.Left (~ g!error))
- (#.Left ((~! text.join_with) (~! text.new_line) (list (~ error_msg) (~ g!error))))}
- ((~! </>.run)
- (: ((~! </>.Parser) (Meta (List Code)))
- ((~! do) (~! <>.monad)
- [(~+ (..join_pairs vars+parsers))]
- ((~' wrap) (~ body))))
- (~ g!tokens)))))))))
-
- _
- (meta.fail (macro.wrong_syntax_error (name_of ..syntax:))))))
diff --git a/stdlib/source/lux/macro/syntax/annotations.lux b/stdlib/source/lux/macro/syntax/annotations.lux
deleted file mode 100644
index a0453771a..000000000
--- a/stdlib/source/lux/macro/syntax/annotations.lux
+++ /dev/null
@@ -1,41 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]
- [control
- ["." function]
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- ["." product]
- ["." name]
- [collection
- ["." list ("#\." functor)]]]
- [macro
- ["." code]]])
-
-(type: #export Annotations
- (List [Name Code]))
-
-(def: #export equivalence
- (Equivalence Annotations)
- (list.equivalence
- (product.equivalence name.equivalence
- code.equivalence)))
-
-(def: #export empty
- Annotations
- (list))
-
-(def: #export format
- (-> Annotations Code)
- (let [entry (product.apply code.tag function.identity)]
- (|>> (list\map entry)
- code.record)))
-
-(def: #export parser
- (Parser Annotations)
- (<code>.record
- (<>.some
- (<>.and <code>.tag
- <code>.any))))
diff --git a/stdlib/source/lux/macro/syntax/check.lux b/stdlib/source/lux/macro/syntax/check.lux
deleted file mode 100644
index d3007b2b8..000000000
--- a/stdlib/source/lux/macro/syntax/check.lux
+++ /dev/null
@@ -1,41 +0,0 @@
-(.module:
- [lux #*
- ["." meta]
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]]
- [control
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- ["." product]]
- [macro
- ["." code]]])
-
-(def: extension
- "lux check")
-
-(type: #export Check
- {#type Code
- #value Code})
-
-(def: #export equivalence
- (Equivalence Check)
- ($_ product.equivalence
- code.equivalence
- code.equivalence
- ))
-
-(def: #export (format (^slots [#type #value]))
- (-> Check Code)
- (` ((~ (code.text ..extension))
- (~ type)
- (~ value))))
-
-(def: #export parser
- (Parser Check)
- (<| <code>.form
- (<>.after (<code>.text! ..extension))
- (<>.and <code>.any
- <code>.any)))
diff --git a/stdlib/source/lux/macro/syntax/declaration.lux b/stdlib/source/lux/macro/syntax/declaration.lux
deleted file mode 100644
index 92158b842..000000000
--- a/stdlib/source/lux/macro/syntax/declaration.lux
+++ /dev/null
@@ -1,46 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]
- [control
- ["<>" parser ("#\." monad)
- ["<.>" code (#+ Parser)]]]
- [data
- ["." product]
- ["." text]
- [collection
- ["." list ("#\." functor)]]]
- [macro
- ["." code]]])
-
-(type: #export Declaration
- {#name Text
- #arguments (List Text)})
-
-(def: #export equivalence
- (Equivalence Declaration)
- ($_ product.equivalence
- text.equivalence
- (list.equivalence text.equivalence)
- ))
-
-(def: #export parser
- {#.doc (doc "A parser for declaration syntax."
- "Such as:"
- quux
- (foo bar baz))}
- (Parser Declaration)
- (<>.either (<>.and <code>.local_identifier
- (<>\wrap (list)))
- (<code>.form (<>.and <code>.local_identifier
- (<>.some <code>.local_identifier)))))
-
-(def: #export (format value)
- (-> Declaration Code)
- (let [g!name (code.local_identifier (get@ #name value))]
- (case (get@ #arguments value)
- #.Nil
- g!name
-
- arguments
- (` ((~ g!name) (~+ (list\map code.local_identifier arguments)))))))
diff --git a/stdlib/source/lux/macro/syntax/definition.lux b/stdlib/source/lux/macro/syntax/definition.lux
deleted file mode 100644
index bbb72fb37..000000000
--- a/stdlib/source/lux/macro/syntax/definition.lux
+++ /dev/null
@@ -1,140 +0,0 @@
-(.module:
- [lux (#- Definition)
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]]
- [control
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- ["." sum]
- ["." product]
- ["." bit]
- ["." name]
- ["." text
- ["%" format]]
- [collection
- ["." list]]]
- ["." macro
- ["." code]]
- ["." meta
- ["." location]]]
- ["." //
- ["#." annotations (#+ Annotations)]
- ["#." check (#+ Check)]])
-
-(type: #export Definition
- {#name Text
- #value (Either Check
- Code)
- #anns Annotations
- #export? Bit})
-
-(def: #export equivalence
- (Equivalence Definition)
- ($_ product.equivalence
- text.equivalence
- ($_ sum.equivalence
- //check.equivalence
- code.equivalence
- )
- //annotations.equivalence
- bit.equivalence
- ))
-
-(def: extension
- "lux def")
-
-(def: (format_tag [module short])
- (-> Name Code)
- (` [(~ (code.text module))
- (~ (code.text short))]))
-
-(def: (format_annotations value)
- (-> Annotations Code)
- (case value
- #.Nil
- (` #.Nil)
-
- (#.Cons [name value] tail)
- (` (#.Cons [(~ (..format_tag name))
- (~ value)]
- (~ (format_annotations tail))))))
-
-(def: dummy
- Code
- (` {#.module (~ (code.text (get@ #.module location.dummy)))
- #.line (~ (code.nat (get@ #.line location.dummy)))
- #.column (~ (code.nat (get@ #.column location.dummy)))}))
-
-(def: #export (format (^slots [#name #value #anns #export?]))
- (-> Definition Code)
- (` ((~ (code.text ..extension))
- (~ (code.local_identifier name))
- (~ (case value
- (#.Left check)
- (//check.format check)
-
- (#.Right value)
- value))
- [(~ ..dummy) (#.Record (~ (..format_annotations anns)))]
- (~ (code.bit export?)))))
-
-(def: tag_parser
- (Parser Name)
- (<code>.tuple (<>.and <code>.text <code>.text)))
-
-(def: annotations_parser
- (Parser Annotations)
- (<>.rec
- (function (_ recur)
- ($_ <>.or
- (<code>.tag! (name_of #.Nil))
- (<code>.form (do <>.monad
- [_ (<code>.tag! (name_of #.Cons))
- [head tail] (<>.and (<code>.tuple (<>.and tag_parser <code>.any))
- recur)]
- (wrap [head tail])))
- ))))
-
-(def: #export (parser compiler)
- {#.doc "A reader that first macro-expands and then analyses the input Code, to ensure it's a definition."}
- (-> Lux (Parser Definition))
- (do {! <>.monad}
- [raw <code>.any
- me_raw (|> raw
- macro.expand_all
- (meta.run compiler)
- <>.lift)]
- (<| (<code>.local me_raw)
- <code>.form
- (<>.after (<code>.text! ..extension))
- ($_ <>.and
- <code>.local_identifier
- (<>.or //check.parser
- <code>.any)
- (<| <code>.tuple
- (<>.after <code>.any)
- <code>.form
- (<>.after (<code>.this! (` #.Record)))
- ..annotations_parser)
- <code>.bit
- ))))
-
-(exception: #export (lacks_type! {definition Definition})
- (exception.report
- ["Definition" (%.code (..format definition))]))
-
-(def: #export (typed compiler)
- {#.doc "Only works for typed definitions."}
- (-> Lux (Parser Definition))
- (do <>.monad
- [definition (..parser compiler)
- _ (case (get@ #value definition)
- (#.Left _)
- (wrap [])
-
- (#.Right _)
- (<>.lift (exception.throw ..lacks_type! [definition])))]
- (wrap definition)))
diff --git a/stdlib/source/lux/macro/syntax/export.lux b/stdlib/source/lux/macro/syntax/export.lux
deleted file mode 100644
index fceecc6e7..000000000
--- a/stdlib/source/lux/macro/syntax/export.lux
+++ /dev/null
@@ -1,20 +0,0 @@
-(.module:
- [lux #*
- [control
- ["<>" parser ("#\." monad)
- ["<.>" code (#+ Parser)]]]])
-
-(def: token
- (' #export))
-
-(def: #export (format exported?)
- (-> Bit (List Code))
- (if exported?
- (list ..token)
- (list)))
-
-(def: #export parser
- (Parser Bit)
- (<>.either (<>.after (<code>.this! ..token)
- (<>\wrap true))
- (<>\wrap false)))
diff --git a/stdlib/source/lux/macro/syntax/input.lux b/stdlib/source/lux/macro/syntax/input.lux
deleted file mode 100644
index 9b9fcb576..000000000
--- a/stdlib/source/lux/macro/syntax/input.lux
+++ /dev/null
@@ -1,37 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]
- [control
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- ["." product]]
- [macro
- ["." code]]])
-
-(type: #export Input
- {#binding Code
- #type Code})
-
-(def: #export equivalence
- (Equivalence Input)
- ($_ product.equivalence
- code.equivalence
- code.equivalence
- ))
-
-(def: #export (format value)
- (-> Input Code)
- (code.record
- (list [(get@ #binding value)
- (get@ #type value)])))
-
-(def: #export parser
- {#.doc "Parser for the common typed-argument syntax used by many macros."}
- (Parser Input)
- (<code>.record
- ($_ <>.and
- <code>.any
- <code>.any
- )))
diff --git a/stdlib/source/lux/macro/syntax/type/variable.lux b/stdlib/source/lux/macro/syntax/type/variable.lux
deleted file mode 100644
index 22f37a35c..000000000
--- a/stdlib/source/lux/macro/syntax/type/variable.lux
+++ /dev/null
@@ -1,27 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]
- [control
- [parser
- ["<.>" code (#+ Parser)]]]
- [data
- ["." text]]
- [macro
- ["." code]]])
-
-(type: #export Variable
- Text)
-
-(def: #export equivalence
- (Equivalence Variable)
- text.equivalence)
-
-(def: #export format
- (-> Variable Code)
- code.local_identifier)
-
-(def: #export parser
- {#.doc "Parser for the common type variable/parameter used by many macros."}
- (Parser Variable)
- <code>.local_identifier)
diff --git a/stdlib/source/lux/macro/template.lux b/stdlib/source/lux/macro/template.lux
deleted file mode 100644
index b970cae05..000000000
--- a/stdlib/source/lux/macro/template.lux
+++ /dev/null
@@ -1,184 +0,0 @@
-(.module:
- [lux (#- let)
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["<>" parser ("#\." functor)
- ["<.>" code (#+ Parser)]]]
- [data
- ["." bit ("#\." codec)]
- ["." text]
- [collection
- ["." list ("#\." monad)]
- ["." dictionary (#+ Dictionary)]]]
- [math
- [number
- ["." nat ("#\." decimal)]
- ["." int ("#\." decimal)]
- ["." rev ("#\." decimal)]
- ["." frac ("#\." decimal)]]]]
- ["." //
- [syntax (#+ syntax:)]
- ["." code]
- ["." local]])
-
-(syntax: #export (splice {parts (<code>.tuple (<>.some <code>.any))})
- (wrap parts))
-
-(syntax: #export (count {parts (<code>.tuple (<>.some <code>.any))})
- (wrap (list (code.nat (list.size parts)))))
-
-(syntax: #export (with_locals {locals (<code>.tuple (<>.some <code>.local_identifier))}
- body)
- (do {! meta.monad}
- [g!locals (|> locals
- (list\map //.gensym)
- (monad.seq !))]
- (wrap (list (` (.with_expansions [(~+ (|> (list.zip/2 locals g!locals)
- (list\map (function (_ [name identifier])
- (list (code.local_identifier name) (as_is identifier))))
- list\join))]
- (~ body)))))))
-
-(def: (name_side module_side? parser)
- (-> Bit (Parser Name) (Parser Text))
- (do <>.monad
- [[module short] parser]
- (wrap (if module_side?
- (case module
- "" short
- _ module)
- short))))
-
-(def: (snippet module_side?)
- (-> Bit (Parser Text))
- (.let [full_identifier (..name_side module_side? <code>.identifier)
- full_tag (..name_side module_side? <code>.tag)]
- ($_ <>.either
- <code>.text
- (if module_side?
- full_identifier
- (<>.either <code>.local_identifier
- full_identifier))
- (if module_side?
- full_tag
- (<>.either <code>.local_tag
- full_tag))
- (<>\map bit\encode <code>.bit)
- (<>\map nat\encode <code>.nat)
- (<>\map int\encode <code>.int)
- (<>\map rev\encode <code>.rev)
- (<>\map frac\encode <code>.frac)
- )))
-
-(def: (part module_side?)
- (-> Bit (Parser (List Text)))
- (<code>.tuple (<>.many (..snippet module_side?))))
-
-(syntax: #export (text {simple (..part false)})
- (wrap (list (|> simple (text.join_with "") code.text))))
-
-(template [<name> <simple> <complex>]
- [(syntax: #export (<name> {name (<>.or (<>.and (..part true) (..part false))
- (..part false))})
- (case name
- (#.Left [simple complex])
- (wrap (list (<complex> [(text.join_with "" simple)
- (text.join_with "" complex)])))
-
- (#.Right simple)
- (wrap (list (|> simple (text.join_with "") <simple>)))))]
-
- [identifier code.local_identifier code.identifier]
- [tag code.local_tag code.tag]
- )
-
-(type: Environment
- (Dictionary Text Code))
-
-(def: (apply env template)
- (-> Environment Code Code)
- (case template
- [_ (#.Identifier "" name)]
- (case (dictionary.get name env)
- (#.Some substitute)
- substitute
-
- #.None
- template)
-
- (^template [<tag>]
- [[meta (<tag> elems)]
- [meta (<tag> (list\map (apply env) elems))]])
- ([#.Tuple]
- [#.Form])
-
- [meta (#.Record members)]
- [meta (#.Record (list\map (: (-> [Code Code] [Code Code])
- (function (_ [key value])
- [(apply env key)
- (apply env value)]))
- members))]
-
- _
- template))
-
-(type: Local
- {#name Text
- #parameters (List Text)
- #template (List Code)})
-
-(exception: #export (irregular_arguments {expected Nat} {actual Nat})
- (exception.report
- ["Expected" (\ nat.decimal encode expected)]
- ["Actual" (\ nat.decimal encode actual)]))
-
-(def: (macro (^slots [#parameters #template]))
- (-> Local Macro)
- ("lux macro"
- (function (_ inputs compiler)
- (.let [parameters_count (list.size parameters)
- inputs_count (list.size inputs)]
- (if (nat.= parameters_count inputs_count)
- (.let [environment (: Environment
- (|> (list.zip/2 parameters inputs)
- (dictionary.from_list text.hash)))]
- (#.Right [compiler (list\map (..apply environment) template)]))
- (exception.throw ..irregular_arguments [parameters_count inputs_count]))))))
-
-(def: local
- (Parser Local)
- (do <>.monad
- [[name parameters] (<code>.form (<>.and <code>.local_identifier
- (<>.many <code>.local_identifier)))
- template (<code>.tuple (<>.some <code>.any))]
- (wrap {#name name
- #parameters parameters
- #template template})))
-
-(syntax: #export (let {locals (<code>.tuple (<>.some ..local))}
- body)
- (do meta.monad
- [here_name meta.current_module_name
- expression? (: (Meta Bit)
- (function (_ lux)
- (#try.Success [lux (case (get@ #.expected lux)
- #.None
- false
-
- (#.Some _)
- true)])))
- g!pop (local.push (list\map (function (_ local)
- [[here_name (get@ #name local)]
- (..macro local)])
- locals))]
- (if expression?
- (//.with_gensyms [g!body]
- (wrap (list (` (.let [(~ g!body) (~ body)]
- (exec (~ g!pop)
- (~ g!body)))))))
- (wrap (list body
- g!pop)))))
diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux
deleted file mode 100644
index c7e709578..000000000
--- a/stdlib/source/lux/math.lux
+++ /dev/null
@@ -1,393 +0,0 @@
-(.module: {#.doc "Common mathematical constants and functions."}
- [lux #*
- ["@" target]
- [math
- [number
- ["n" nat]
- ["i" int]]]])
-
-(template [<name> <value> <doc>]
- [(def: #export <name>
- {#.doc <doc>}
- <value>)]
-
- [e +2.7182818284590452354 "The base of the natural logarithm."]
- [pi +3.14159265358979323846 "The ratio of a circle's circumference to its diameter."]
- [tau +6.28318530717958647692 "The ratio of a circle's circumference to its radius."]
- )
-
-(for {@.old
- (as_is (template [<name> <method>]
- [(def: #export (<name> input)
- (-> Frac Frac)
- (<method> input))]
-
- [cos "jvm invokestatic:java.lang.Math:cos:double"]
- [sin "jvm invokestatic:java.lang.Math:sin:double"]
- [tan "jvm invokestatic:java.lang.Math:tan:double"]
-
- [acos "jvm invokestatic:java.lang.Math:acos:double"]
- [asin "jvm invokestatic:java.lang.Math:asin:double"]
- [atan "jvm invokestatic:java.lang.Math:atan:double"]
-
- [exp "jvm invokestatic:java.lang.Math:exp:double"]
- [log "jvm invokestatic:java.lang.Math:log:double"]
-
- [ceil "jvm invokestatic:java.lang.Math:ceil:double"]
- [floor "jvm invokestatic:java.lang.Math:floor:double"]
- )
- (def: #export (pow param subject)
- (-> Frac Frac Frac)
- ("jvm invokestatic:java.lang.Math:pow:double,double" subject param)))
-
- @.jvm
- (as_is (template: (!double value)
- (|> value
- (:as (primitive "java.lang.Double"))
- "jvm object cast"))
-
- (template: (!frac value)
- (|> value
- "jvm object cast"
- (: (primitive "java.lang.Double"))
- (:as Frac)))
-
- (template [<name> <method>]
- [(def: #export <name>
- (-> Frac Frac)
- (|>> !double
- ["D"]
- ("jvm member invoke static" [] "java.lang.Math" <method> [])
- !frac))]
-
- [cos "cos"]
- [sin "sin"]
- [tan "tan"]
-
- [acos "acos"]
- [asin "asin"]
- [atan "atan"]
-
- [exp "exp"]
- [log "log"]
-
- [ceil "ceil"]
- [floor "floor"]
-
- [root/2 "sqrt"]
- [root/3 "cbrt"]
- )
-
- (def: #export (pow param subject)
- (-> Frac Frac Frac)
- (|> ("jvm member invoke static" [] "java.lang.Math" "pow" []
- ["D" (!double subject)] ["D" (!double param)])
- !frac)))
-
- @.js
- (as_is (template [<name> <method>]
- [(def: #export <name>
- (-> Frac Frac)
- (|>> ("js apply" ("js constant" <method>))
- (:as Frac)))]
-
- [cos "Math.cos"]
- [sin "Math.sin"]
- [tan "Math.tan"]
-
- [acos "Math.acos"]
- [asin "Math.asin"]
- [atan "Math.atan"]
-
- [exp "Math.exp"]
- [log "Math.log"]
-
- [ceil "Math.ceil"]
- [floor "Math.floor"]
-
- [root/2 "Math.sqrt"]
- [root/3 "Math.cbrt"]
- )
-
- (def: #export (pow param subject)
- (-> Frac Frac Frac)
- (:as Frac ("js apply" ("js constant" "Math.pow") subject param))))
-
- @.python
- (as_is (template [<name> <method>]
- [(def: #export <name>
- (-> Frac Frac)
- (|>> ("python object do" <method> ("python import" "math"))
- (:as Frac)))]
-
- [cos "cos"]
- [sin "sin"]
- [tan "tan"]
-
- [acos "acos"]
- [asin "asin"]
- [atan "atan"]
-
- [exp "exp"]
- [log "log"]
-
- [ceil "ceil"]
- [floor "floor"]
-
- [root/2 "sqrt"]
- )
-
- (def: #export (pow param subject)
- (-> Frac Frac Frac)
- (:as Frac ("python object do" "pow" ("python import" "math") subject param)))
-
- (def: #export root/3
- (-> Frac Frac)
- (..pow ("lux f64 /" +3.0 +1.0))))
-
- @.lua
- (as_is (template [<name> <method>]
- [(def: #export <name>
- (-> Frac Frac)
- (|>> ("lua apply" ("lua constant" <method>))
- (:as Frac)))]
-
- [cos "math.cos"]
- [sin "math.sin"]
- [tan "math.tan"]
-
- [acos "math.acos"]
- [asin "math.asin"]
- [atan "math.atan"]
-
- [exp "math.exp"]
- [log "math.log"]
-
- [ceil "math.ceil"]
- [floor "math.floor"]
-
- [root/2 "math.sqrt"]
- )
-
- (def: #export (pow param subject)
- (-> Frac Frac Frac)
- ("lua power" param subject))
-
- (def: #export root/3
- (-> Frac Frac)
- (..pow ("lux f64 /" +3.0 +1.0))))
-
- @.ruby
- (as_is (template [<name> <method>]
- [(def: #export <name>
- (-> Frac Frac)
- (|>> ("ruby apply" ("ruby constant" <method>))
- (:as Frac)))]
-
- [cos "Math.cos"]
- [sin "Math.sin"]
- [tan "Math.tan"]
-
- [acos "Math.acos"]
- [asin "Math.asin"]
- [atan "Math.atan"]
-
- [exp "Math.exp"]
- [log "Math.log"]
-
- [root/2 "Math.sqrt"]
- [root/3 "Math.cbrt"]
- )
-
- (template [<name> <method>]
- [(def: #export <name>
- (-> Frac Frac)
- (|>> ("ruby object do" <method>)
- (:as Int)
- ("lux i64 f64")))]
-
- [ceil "ceil"]
- [floor "floor"]
- )
-
- (def: #export (pow param subject)
- (-> Frac Frac Frac)
- (:as Frac ("ruby object do" "**" subject param))))
-
- @.php
- (as_is (template [<name> <method>]
- [(def: #export <name>
- (-> Frac Frac)
- (|>> ("php apply" ("php constant" <method>))
- (:as Frac)))]
-
- [cos "cos"]
- [sin "sin"]
- [tan "tan"]
-
- [acos "acos"]
- [asin "asin"]
- [atan "atan"]
-
- [exp "exp"]
- [log "log"]
-
- [ceil "ceil"]
- [floor "floor"]
-
- [root/2 "sqrt"]
- )
-
- (def: #export (pow param subject)
- (-> Frac Frac Frac)
- (:as Frac ("php apply" ("php constant" "pow") subject param)))
-
- (def: #export root/3
- (-> Frac Frac)
- (..pow ("lux f64 /" +3.0 +1.0))))
-
- @.scheme
- (as_is (template [<name> <method>]
- [(def: #export <name>
- (-> Frac Frac)
- (|>> ("scheme apply" ("scheme constant" <method>))
- (:as Frac)))]
-
- [cos "cos"]
- [sin "sin"]
- [tan "tan"]
-
- [acos "acos"]
- [asin "asin"]
- [atan "atan"]
-
- [exp "exp"]
- [log "log"]
-
- [ceil "ceiling"]
- [floor "floor"]
-
- [root/2 "sqrt"]
- )
-
- (def: #export (pow param subject)
- (-> Frac Frac Frac)
- (:as Frac ("scheme apply" ("scheme constant" "expt") subject param)))
-
- (def: #export root/3
- (-> Frac Frac)
- (..pow ("lux f64 /" +3.0 +1.0))))
- })
-
-(def: #export (round input)
- (-> Frac Frac)
- (let [floored (floor input)
- diff ("lux f64 -" floored input)]
- (cond ("lux f64 <" diff +0.5)
- ("lux f64 +" +1.0 floored)
-
- ("lux f64 <" -0.5 diff)
- ("lux f64 +" -1.0 floored)
-
- ## else
- floored)))
-
-(def: #export (atan/2 x y)
- (-> Frac Frac Frac)
- (cond ("lux f64 <" x +0.0)
- (..atan ("lux f64 /" x y))
-
- ("lux f64 <" +0.0 x)
- (if (or ("lux f64 <" y +0.0)
- ("lux f64 =" +0.0 y))
- (|> y ("lux f64 /" x) atan ("lux f64 +" pi))
- (|> y ("lux f64 /" x) atan ("lux f64 -" pi)))
-
- ## ("lux f64 =" +0.0 x)
- (cond ("lux f64 <" y +0.0)
- (|> pi ("lux f64 /" +2.0))
-
- ("lux f64 <" +0.0 y)
- (|> pi ("lux f64 /" -2.0))
-
- ## ("lux f64 =" +0.0 y)
- ("lux f64 /" +0.0 +0.0))))
-
-(def: #export (log' base input)
- (-> Frac Frac Frac)
- ("lux f64 /"
- (..log base)
- (..log input)))
-
-(def: #export (factorial n)
- (-> Nat Nat)
- (loop [acc 1
- n n]
- (if (n.<= 1 n)
- acc
- (recur (n.* n acc) (dec n)))))
-
-(def: #export (hypotenuse catA catB)
- (-> Frac Frac Frac)
- (..pow +0.5 ("lux f64 +"
- (..pow +2.0 catA)
- (..pow +2.0 catB))))
-
-## Hyperbolic functions
-## https://en.wikipedia.org/wiki/Hyperbolic_function#Definitions
-(template [<name> <comp> <inverse>]
- [(def: #export (<name> x)
- (-> Frac Frac)
- (|> (..exp x) (<comp> (..exp ("lux f64 *" -1.0 x))) ("lux f64 /" +2.0)))
-
- (def: #export (<inverse> x)
- (-> Frac Frac)
- (|> +2.0 ("lux f64 /" (|> (..exp x) (<comp> (..exp ("lux f64 *" -1.0 x)))))))]
-
- [sinh "lux f64 -" csch]
- [cosh "lux f64 +" sech]
- )
-
-(template [<name> <top> <bottom>]
- [(def: #export (<name> x)
- (-> Frac Frac)
- (let [e+ (exp x)
- e- (exp ("lux f64 *" -1.0 x))
- sinh' (|> e+ ("lux f64 -" e-))
- cosh' (|> e+ ("lux f64 +" e-))]
- (|> <top> ("lux f64 /" <bottom>))))]
-
- [tanh sinh' cosh']
- [coth cosh' sinh']
- )
-
-## https://en.wikipedia.org/wiki/Inverse_hyperbolic_functions#Definitions_in_terms_of_logarithms
-(template [<name> <comp>]
- [(def: #export (<name> x)
- (-> Frac Frac)
- (|> x (pow +2.0) (<comp> +1.0) (pow +0.5) ("lux f64 +" x) log))]
-
- [asinh "lux f64 +"]
- [acosh "lux f64 -"]
- )
-
-(template [<name> <base> <diff>]
- [(def: #export (<name> x)
- (-> Frac Frac)
- (let [x+ (|> <base> ("lux f64 +" <diff>))
- x- (|> <base> ("lux f64 -" <diff>))]
- (|> x+ ("lux f64 /" x-) log ("lux f64 /" +2.0))))]
-
- [atanh +1.0 x]
- [acoth x +1.0]
- )
-
-(template [<name> <op>]
- [(def: #export (<name> x)
- (-> Frac Frac)
- (let [x^2 (|> x (pow +2.0))]
- (|> +1.0 (<op> x^2) (pow +0.5) ("lux f64 +" +1.0) ("lux f64 /" x) log)))]
-
- [asech "lux f64 -"]
- [acsch "lux f64 +"]
- )
diff --git a/stdlib/source/lux/math/infix.lux b/stdlib/source/lux/math/infix.lux
deleted file mode 100644
index 674544ae8..000000000
--- a/stdlib/source/lux/math/infix.lux
+++ /dev/null
@@ -1,95 +0,0 @@
-(.module: {#.doc "Common mathematical constants and functions."}
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["<>" parser ("#\." functor)
- ["<.>" code (#+ Parser)]]]
- [data
- ["." product]
- [collection
- ["." list ("#\." fold)]]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number
- ["n" nat]
- ["i" int]]]])
-
-(type: #rec Infix
- (#Const Code)
- (#Call (List Code))
- (#Unary Code Infix)
- (#Binary Infix Code Infix))
-
-(def: infix^
- (Parser Infix)
- (<| <>.rec (function (_ infix^))
- ($_ <>.or
- ($_ <>.either
- (<>\map code.bit <code>.bit)
- (<>\map code.nat <code>.nat)
- (<>\map code.int <code>.int)
- (<>\map code.rev <code>.rev)
- (<>\map code.frac <code>.frac)
- (<>\map code.text <code>.text)
- (<>\map code.identifier <code>.identifier)
- (<>\map code.tag <code>.tag))
- (<code>.form (<>.many <code>.any))
- (<code>.tuple (<>.and <code>.any infix^))
- (<code>.tuple ($_ <>.either
- (do <>.monad
- [_ (<code>.this! (' #and))
- init_subject infix^
- init_op <code>.any
- init_param infix^
- steps (<>.some (<>.and <code>.any infix^))]
- (wrap (product.right (list\fold (function (_ [op param] [subject [_subject _op _param]])
- [param [(#Binary _subject _op _param)
- (` and)
- (#Binary subject op param)]])
- [init_param [init_subject init_op init_param]]
- steps))))
- (do <>.monad
- [init_subject infix^
- init_op <code>.any
- init_param infix^
- steps (<>.some (<>.and <code>.any infix^))]
- (wrap (list\fold (function (_ [op param] [_subject _op _param])
- [(#Binary _subject _op _param) op param])
- [init_subject init_op init_param]
- steps)))
- ))
- )))
-
-(def: (to_prefix infix)
- (-> Infix Code)
- (case infix
- (#Const value)
- value
-
- (#Call parts)
- (code.form parts)
-
- (#Unary op subject)
- (` ((~ op) (~ (to_prefix subject))))
-
- (#Binary left op right)
- (` ((~ op) (~ (to_prefix right)) (~ (to_prefix left))))
- ))
-
-(syntax: #export (infix {expr infix^})
- {#.doc (doc "Infix math syntax."
- (infix [x i.* +10])
- (infix [[x i.+ y] i.* [x i.- y]])
- (infix [sin [x i.+ y]])
- (infix [[x n.< y] and [y n.< z]])
- (infix [#and x n.< y n.< z])
- (infix [(n.* 3 9) gcd 450])
-
- "The rules for infix syntax are simple."
- "If you want your binary function to work well with it."
- "Then take the argument to the right (y) as your first argument,"
- "and take the argument to the left (x) as your second argument.")}
- (wrap (list (..to_prefix expr))))
diff --git a/stdlib/source/lux/math/logic/continuous.lux b/stdlib/source/lux/math/logic/continuous.lux
deleted file mode 100644
index 445bd8447..000000000
--- a/stdlib/source/lux/math/logic/continuous.lux
+++ /dev/null
@@ -1,39 +0,0 @@
-(.module:
- [lux (#- false true or and not)
- [abstract
- [monoid (#+ Monoid)]]
- [math
- [number
- ["r" rev ("#\." interval)]]]])
-
-(def: #export false Rev r\bottom)
-(def: #export true Rev r\top)
-
-(template [<name> <chooser> <monoid> <identity>]
- [(def: #export <name>
- (-> Rev Rev Rev)
- <chooser>)
-
- (implementation: #export <monoid>
- (Monoid Rev)
-
- (def: identity <identity>)
- (def: compose <name>))]
-
- [or r.max disjunction ..false]
- [and r.min conjunction ..true]
- )
-
-(def: #export (not input)
- (-> Rev Rev)
- (r.- input ..true))
-
-(def: #export (implies consequent antecedent)
- (-> Rev Rev Rev)
- (or (not antecedent)
- consequent))
-
-(def: #export (= left right)
- (-> Rev Rev Rev)
- (and (or (not left) right)
- (or left (not right))))
diff --git a/stdlib/source/lux/math/logic/fuzzy.lux b/stdlib/source/lux/math/logic/fuzzy.lux
deleted file mode 100644
index 5308786fa..000000000
--- a/stdlib/source/lux/math/logic/fuzzy.lux
+++ /dev/null
@@ -1,131 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [predicate (#+ Predicate)]
- [functor
- ["." contravariant]]]
- [data
- [collection
- ["." list]
- ["." set (#+ Set)]]]
- [math
- [number
- ["/" rev]]]]
- ["." // #_
- ["#" continuous]])
-
-(type: #export (Fuzzy a)
- (-> a Rev))
-
-(implementation: #export functor
- (contravariant.Functor Fuzzy)
-
- (def: (map f fb)
- (|>> f fb)))
-
-(template [<name> <verdict>]
- [(def: #export <name>
- Fuzzy
- (function (_ _)
- <verdict>))]
-
- [empty //.false]
- [full //.true]
- )
-
-(def: #export (membership set elem)
- (All [a] (-> (Fuzzy a) a Rev))
- (set elem))
-
-(template [<set_composition> <membership_composition>]
- [(def: #export (<set_composition> left right)
- (All [a] (-> (Fuzzy a) (Fuzzy a) (Fuzzy a)))
- (function (_ elem)
- (<membership_composition> (left elem)
- (right elem))))]
-
- [union //.or]
- [intersection //.and]
- )
-
-(def: #export (complement set)
- (All [a] (-> (Fuzzy a) (Fuzzy a)))
- (|>> set //.not))
-
-(def: #export (difference sub base)
- (All [a] (-> (Fuzzy a) (Fuzzy a) (Fuzzy a)))
- (..intersection (..complement sub) base))
-
-(def: #export (from_predicate predicate)
- (All [a] (-> (Predicate a) (Fuzzy a)))
- (function (_ elem)
- (if (predicate elem)
- //.true
- //.false)))
-
-(def: #export (to_predicate treshold set)
- (All [a] (-> Rev (Fuzzy a) (Predicate a)))
- (function (_ elem)
- (/.> treshold (set elem))))
-
-(def: #export from_set
- (All [a] (-> (Set a) (Fuzzy a)))
- (|>> set.member? ..from_predicate))
-
-(def: (ascending from to)
- (-> Rev Rev (Fuzzy Rev))
- (let [measure (/.- from to)]
- (function (_ elem)
- (cond (/.< from elem)
- ## below
- //.false
-
- (/.< to elem)
- ## in the middle...
- (|> elem
- (/.- from)
- (/./ measure))
-
- ## above
- //.true))))
-
-(def: (descending from to)
- (-> Rev Rev (Fuzzy Rev))
- (..complement (..ascending from to)))
-
-(def: #export (gradient from to)
- (-> Rev Rev (Fuzzy Rev))
- (if (/.< to from)
- (..ascending from to)
- (..descending from to)))
-
-(template: (!sort_2 <low> <high>)
- (if (/.> <low> <high>)
- [<low> <high>]
- [<high> <low>]))
-
-(def: #export (triangle bottom middle top)
- (-> Rev Rev Rev (Fuzzy Rev))
- (let [[low_0 high_0] (!sort_2 bottom middle)
- [bottom' high_1] (!sort_2 low_0 top)
- [middle' top'] (!sort_2 high_0 high_1)]
- (..intersection (..ascending bottom' middle')
- (..descending middle' top'))))
-
-(def: #export (trapezoid bottom middle_bottom middle_top top)
- (-> Rev Rev Rev Rev (Fuzzy Rev))
- (let [[low_0 high_0] (!sort_2 bottom middle_bottom)
- [low_1 high_1] (!sort_2 middle_top top)
- [bottom' middle_0] (!sort_2 low_0 low_1)
- [middle_1 top'] (!sort_2 high_0 high_1)
- [middle_bottom' middle_top'] (!sort_2 middle_0 middle_1)]
- (..intersection (..ascending bottom' middle_bottom')
- (..descending middle_top' top'))))
-
-(def: #export (cut treshold set)
- (All [a] (-> Rev (Fuzzy a) (Fuzzy a)))
- (function (_ elem)
- (let [membership (set elem)]
- (if (/.< treshold membership)
- //.false
- (|> membership (/.- treshold) (/.* //.true))))))
diff --git a/stdlib/source/lux/math/modular.lux b/stdlib/source/lux/math/modular.lux
deleted file mode 100644
index 5ecfb6763..000000000
--- a/stdlib/source/lux/math/modular.lux
+++ /dev/null
@@ -1,156 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]
- [monoid (#+ Monoid)]
- [codec (#+ Codec)]
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<.>" text (#+ Parser)]
- ["<.>" code]]]
- [data
- ["." product]
- ["." text ("#\." monoid)]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number
- ["i" int ("#\." decimal)]]]
- [type
- abstract]]
- ["." // #_
- ["#" modulus (#+ Modulus)]])
-
-(abstract: #export (Mod m)
- {#modulus (Modulus m)
- #value Int}
-
- {#.doc "A number under a modulus."}
-
- (def: #export (modular modulus value)
- (All [%] (-> (Modulus %) Int (Mod %)))
- (:abstraction {#modulus modulus
- #value (i.mod (//.divisor modulus) value)}))
-
- (template [<name> <type> <side>]
- [(def: #export <name>
- (All [%] (-> (Mod %) <type>))
- (|>> :representation <side>))]
-
- [modulus (Modulus %) product.left]
- [value Int product.right]
- )
-
- (exception: #export [%] (incorrect_modulus {modulus (Modulus %)}
- {parsed Int})
- (exception.report
- ["Expected" (i\encode (//.divisor modulus))]
- ["Actual" (i\encode parsed)]))
-
- (def: separator
- " mod ")
-
- (def: intL
- (Parser Int)
- (<>.codec i.decimal
- (<text>.and (<text>.one_of "-+") (<text>.many <text>.decimal))))
-
- (implementation: #export (codec expected)
- (All [%] (-> (Modulus %) (Codec Text (Mod %))))
-
- (def: (encode modular)
- (let [[_ value] (:representation modular)]
- ($_ text\compose
- (i\encode value)
- ..separator
- (i\encode (//.divisor expected)))))
-
- (def: decode
- (<text>.run
- (do <>.monad
- [[value _ actual] ($_ <>.and intL (<text>.this ..separator) intL)
- _ (<>.assert (exception.construct ..incorrect_modulus [expected actual])
- (i.= (//.divisor expected) actual))]
- (wrap (..modular expected value))))))
-
- (template [<name> <op>]
- [(def: #export (<name> reference subject)
- (All [%] (-> (Mod %) (Mod %) Bit))
- (let [[_ reference] (:representation reference)
- [_ subject] (:representation subject)]
- (<op> reference subject)))]
-
- [= i.=]
- [< i.<]
- [<= i.<=]
- [> i.>]
- [>= i.>=]
- )
-
- (implementation: #export equivalence
- (All [%] (Equivalence (Mod %)))
-
- (def: = ..=))
-
- (implementation: #export order
- (All [%] (Order (Mod %)))
-
- (def: &equivalence ..equivalence)
- (def: < ..<))
-
- (template [<name> <op>]
- [(def: #export (<name> param subject)
- (All [%] (-> (Mod %) (Mod %) (Mod %)))
- (let [[modulus param] (:representation param)
- [_ subject] (:representation subject)]
- (:abstraction {#modulus modulus
- #value (|> subject
- (<op> param)
- (i.mod (//.divisor modulus)))})))]
-
- [+ i.+]
- [- i.-]
- [* i.*]
- )
-
- (template [<composition> <identity> <monoid>]
- [(implementation: #export (<monoid> modulus)
- (All [%] (-> (Modulus %) (Monoid (Mod %))))
-
- (def: identity
- (..modular modulus <identity>))
- (def: compose
- <composition>))]
-
- [..+ +0 addition]
- [..* +1 multiplication]
- )
-
- (def: #export (inverse modular)
- (All [%] (-> (Mod %) (Maybe (Mod %))))
- (let [[modulus value] (:representation modular)
- [[vk mk] gcd] (i.extended_gcd value (//.divisor modulus))]
- (case gcd
- +1 (#.Some (..modular modulus vk))
- _ #.None)))
- )
-
-(exception: #export [r% s%] (moduli_are_not_equal {reference (Modulus r%)}
- {subject (Modulus s%)})
- (exception.report
- ["Reference" (i\encode (//.divisor reference))]
- ["Subject" (i\encode (//.divisor subject))]))
-
-(def: #export (adapter reference subject)
- (All [r% s%]
- (-> (Modulus r%) (Modulus s%)
- (Try (-> (Mod s%) (Mod r%)))))
- (if (//.= reference subject)
- (#try.Success (|>> ..value
- (..modular reference)))
- (exception.throw ..moduli_are_not_equal [reference subject])))
diff --git a/stdlib/source/lux/math/modulus.lux b/stdlib/source/lux/math/modulus.lux
deleted file mode 100644
index 00949f6ce..000000000
--- a/stdlib/source/lux/math/modulus.lux
+++ /dev/null
@@ -1,55 +0,0 @@
-(.module:
- [lux #*
- ["." meta]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- [parser
- ["<.>" code]]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number
- ["i" int]]]
- [type
- abstract]])
-
-(exception: #export zero_cannot_be_a_modulus)
-
-(abstract: #export (Modulus m)
- Int
-
- {#.doc (doc "A number used as a modulus in modular arithmetic."
- "It cannot be 0.")}
-
- (def: #export (modulus value)
- (Ex [m] (-> Int (Try (Modulus m))))
- (if (i.= +0 value)
- (exception.throw ..zero_cannot_be_a_modulus [])
- (#try.Success (:abstraction value))))
-
- (def: #export divisor
- (All [m] (-> (Modulus m) Int))
- (|>> :representation))
-
- (def: #export (= reference subject)
- (All [r s] (-> (Modulus r) (Modulus s) Bit))
- (i.= (:representation reference)
- (:representation subject)))
-
- (def: #export (congruent? modulus reference subject)
- (All [m] (-> (Modulus m) Int Int Bit))
- (|> subject
- (i.- reference)
- (i.% (:representation modulus))
- (i.= +0)))
- )
-
-(syntax: #export (literal {divisor <code>.int})
- (meta.lift
- (do try.monad
- [_ (..modulus divisor)]
- (wrap (list (` ((~! try.assume) (..modulus (~ (code.int divisor))))))))))
diff --git a/stdlib/source/lux/math/number.lux b/stdlib/source/lux/math/number.lux
deleted file mode 100644
index a96c450ee..000000000
--- a/stdlib/source/lux/math/number.lux
+++ /dev/null
@@ -1,86 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [codec (#+ Codec)]]
- [control
- ["." try (#+ Try)]]
- [data
- ["." text]]]
- ["." / #_
- ["#." nat]
- ["#." int]
- ["#." rev]
- ["#." frac]])
-
-(macro: (encoding_doc tokens state)
- (case tokens
- (^ (list [location (#.Text encoding)] example_1 example_2))
- (let [encoding ($_ "lux text concat"
- "Given syntax for a "
- encoding
- " number, generates a Nat, an Int, a Rev or a Frac.")
- separators "Allows for the presence of commas among the digits."
- description [location (#.Text ($_ "lux text concat" encoding " " separators))]]
- (#try.Success [state (list (` (doc (~ description)
- (~ example_1)
- (~ example_2))))]))
-
- _
- (#try.Failure "Wrong syntax for 'encoding_doc'.")))
-
-(def: separator
- ",")
-
-(def: (separator_prefixed? number)
- (-> Text Bit)
- (case ("lux text index" 0 ..separator number)
- (#.Some 0)
- #1
-
- _
- #0))
-
-(def: clean_separators
- (-> Text Text)
- (text.replace_all ..separator ""))
-
-(template [<macro> <nat> <int> <rev> <frac> <error> <doc>]
- [(macro: #export (<macro> tokens state)
- {#.doc <doc>}
- (case tokens
- (#.Cons [meta (#.Text repr')] #.Nil)
- (if (..separator_prefixed? repr')
- (#try.Failure <error>)
- (let [repr (..clean_separators repr')]
- (case (\ <nat> decode repr)
- (#try.Success value)
- (#try.Success [state (list [meta (#.Nat value)])])
-
- (^multi (#try.Failure _)
- [(\ <int> decode repr) (#try.Success value)])
- (#try.Success [state (list [meta (#.Int value)])])
-
- (^multi (#try.Failure _)
- [(\ <rev> decode repr) (#try.Success value)])
- (#try.Success [state (list [meta (#.Rev value)])])
-
- (^multi (#try.Failure _)
- [(\ <frac> decode repr) (#try.Success value)])
- (#try.Success [state (list [meta (#.Frac value)])])
-
- _
- (#try.Failure <error>))))
-
- _
- (#try.Failure <error>)))]
-
- [bin /nat.binary /int.binary /rev.binary /frac.binary
- "Invalid binary syntax."
- (encoding_doc "binary" (bin "11001001") (bin "11,00,10,01"))]
- [oct /nat.octal /int.octal /rev.octal /frac.octal
- "Invalid octal syntax."
- (encoding_doc "octal" (oct "615243") (oct "615,243"))]
- [hex /nat.hex /int.hex /rev.hex /frac.hex
- "Invalid hexadecimal syntax."
- (encoding_doc "hexadecimal" (hex "deadBEEF") (hex "dead,BEEF"))]
- )
diff --git a/stdlib/source/lux/math/number/complex.lux b/stdlib/source/lux/math/number/complex.lux
deleted file mode 100644
index 279f6177a..000000000
--- a/stdlib/source/lux/math/number/complex.lux
+++ /dev/null
@@ -1,315 +0,0 @@
-(.module: {#.doc "Complex arithmetic."}
- [lux #*
- ["." math]
- [abstract
- [equivalence (#+ Equivalence)]
- [codec (#+ Codec)]
- ["M" monad (#+ Monad do)]]
- [control
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- ["." maybe]
- [collection
- ["." list ("#\." functor)]]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number
- ["n" nat]
- ["f" frac]
- ["." int]]]])
-
-(type: #export Complex
- {#real Frac
- #imaginary Frac})
-
-(syntax: #export (complex real {?imaginary (<>.maybe <code>.any)})
- {#.doc (doc "Complex literals."
- (complex real imaginary)
- "The imaginary part can be omitted if it's 0."
- (complex real))}
- (wrap (list (` {#..real (~ real)
- #..imaginary (~ (maybe.default (' +0.0)
- ?imaginary))}))))
-
-(def: #export i
- (..complex +0.0 +1.0))
-
-(def: #export +one
- (..complex +1.0 +0.0))
-
-(def: #export -one
- (..complex -1.0 +0.0))
-
-(def: #export zero
- (..complex +0.0 +0.0))
-
-(def: #export (not_a_number? complex)
- (or (f.not_a_number? (get@ #real complex))
- (f.not_a_number? (get@ #imaginary complex))))
-
-(def: #export (= param input)
- (-> Complex Complex Bit)
- (and (f.= (get@ #real param)
- (get@ #real input))
- (f.= (get@ #imaginary param)
- (get@ #imaginary input))))
-
-(template [<name> <op>]
- [(def: #export (<name> param input)
- (-> Complex Complex Complex)
- {#real (<op> (get@ #real param)
- (get@ #real input))
- #imaginary (<op> (get@ #imaginary param)
- (get@ #imaginary input))})]
-
- [+ f.+]
- [- f.-]
- )
-
-(implementation: #export equivalence
- (Equivalence Complex)
-
- (def: = ..=))
-
-(template [<name> <transform>]
- [(def: #export <name>
- (-> Complex Complex)
- (|>> (update@ #real <transform>)
- (update@ #imaginary <transform>)))]
-
- [negate f.negate]
- [signum f.signum]
- )
-
-(def: #export conjugate
- (-> Complex Complex)
- (update@ #imaginary f.negate))
-
-(def: #export (*' param input)
- (-> Frac Complex Complex)
- {#real (f.* param
- (get@ #real input))
- #imaginary (f.* param
- (get@ #imaginary input))})
-
-(def: #export (* param input)
- (-> Complex Complex Complex)
- {#real (f.- (f.* (get@ #imaginary param)
- (get@ #imaginary input))
- (f.* (get@ #real param)
- (get@ #real input)))
- #imaginary (f.+ (f.* (get@ #real param)
- (get@ #imaginary input))
- (f.* (get@ #imaginary param)
- (get@ #real input)))})
-
-(def: #export (/ param input)
- (-> Complex Complex Complex)
- (let [(^slots [#real #imaginary]) param]
- (if (f.< (f.abs imaginary)
- (f.abs real))
- (let [quot (f./ imaginary real)
- denom (|> real (f.* quot) (f.+ imaginary))]
- {#real (|> (get@ #real input) (f.* quot) (f.+ (get@ #imaginary input)) (f./ denom))
- #imaginary (|> (get@ #imaginary input) (f.* quot) (f.- (get@ #real input)) (f./ denom))})
- (let [quot (f./ real imaginary)
- denom (|> imaginary (f.* quot) (f.+ real))]
- {#real (|> (get@ #imaginary input) (f.* quot) (f.+ (get@ #real input)) (f./ denom))
- #imaginary (|> (get@ #imaginary input) (f.- (f.* quot (get@ #real input))) (f./ denom))}))))
-
-(def: #export (/' param subject)
- (-> Frac Complex Complex)
- (let [(^slots [#real #imaginary]) subject]
- {#real (f./ param real)
- #imaginary (f./ param imaginary)}))
-
-(def: #export (% param input)
- (-> Complex Complex Complex)
- (let [scaled (/ param input)
- quotient (|> scaled
- (update@ #real math.floor)
- (update@ #imaginary math.floor))]
- (- (* quotient param)
- input)))
-
-(def: #export (cos subject)
- (-> Complex Complex)
- (let [(^slots [#real #imaginary]) subject]
- {#real (f.* (math.cosh imaginary)
- (math.cos real))
- #imaginary (f.negate (f.* (math.sinh imaginary)
- (math.sin real)))}))
-
-(def: #export (cosh subject)
- (-> Complex Complex)
- (let [(^slots [#real #imaginary]) subject]
- {#real (f.* (math.cos imaginary)
- (math.cosh real))
- #imaginary (f.* (math.sin imaginary)
- (math.sinh real))}))
-
-(def: #export (sin subject)
- (-> Complex Complex)
- (let [(^slots [#real #imaginary]) subject]
- {#real (f.* (math.cosh imaginary)
- (math.sin real))
- #imaginary (f.* (math.sinh imaginary)
- (math.cos real))}))
-
-(def: #export (sinh subject)
- (-> Complex Complex)
- (let [(^slots [#real #imaginary]) subject]
- {#real (f.* (math.cos imaginary)
- (math.sinh real))
- #imaginary (f.* (math.sin imaginary)
- (math.cosh real))}))
-
-(def: #export (tan subject)
- (-> Complex Complex)
- (let [(^slots [#real #imaginary]) subject
- r2 (f.* +2.0 real)
- i2 (f.* +2.0 imaginary)
- d (f.+ (math.cos r2) (math.cosh i2))]
- {#real (f./ d (math.sin r2))
- #imaginary (f./ d (math.sinh i2))}))
-
-(def: #export (tanh subject)
- (-> Complex Complex)
- (let [(^slots [#real #imaginary]) subject
- r2 (f.* +2.0 real)
- i2 (f.* +2.0 imaginary)
- d (f.+ (math.cosh r2) (math.cos i2))]
- {#real (f./ d (math.sinh r2))
- #imaginary (f./ d (math.sin i2))}))
-
-(def: #export (abs subject)
- (-> Complex Frac)
- (let [(^slots [#real #imaginary]) subject]
- (if (f.< (f.abs imaginary)
- (f.abs real))
- (if (f.= +0.0 imaginary)
- (f.abs real)
- (let [q (f./ imaginary real)]
- (f.* (math.pow +0.5 (f.+ +1.0 (f.* q q)))
- (f.abs imaginary))))
- (if (f.= +0.0 real)
- (f.abs imaginary)
- (let [q (f./ real imaginary)]
- (f.* (math.pow +0.5 (f.+ +1.0 (f.* q q)))
- (f.abs real)))))))
-
-(def: #export (exp subject)
- (-> Complex Complex)
- (let [(^slots [#real #imaginary]) subject
- r_exp (math.exp real)]
- {#real (f.* r_exp (math.cos imaginary))
- #imaginary (f.* r_exp (math.sin imaginary))}))
-
-(def: #export (log subject)
- (-> Complex Complex)
- (let [(^slots [#real #imaginary]) subject]
- {#real (|> subject ..abs math.log)
- #imaginary (math.atan/2 real imaginary)}))
-
-(template [<name> <type> <op>]
- [(def: #export (<name> param input)
- (-> <type> Complex Complex)
- (|> input log (<op> param) exp))]
-
- [pow Complex ..*]
- [pow' Frac ..*']
- )
-
-(def: (copy_sign sign magnitude)
- (-> Frac Frac Frac)
- (f.* (f.signum sign) magnitude))
-
-(def: #export (root/2 input)
- (-> Complex Complex)
- (let [(^slots [#real #imaginary]) input
- t (|> input ..abs (f.+ (f.abs real)) (f./ +2.0) (math.pow +0.5))]
- (if (f.>= +0.0 real)
- {#real t
- #imaginary (f./ (f.* +2.0 t)
- imaginary)}
- {#real (f./ (f.* +2.0 t)
- (f.abs imaginary))
- #imaginary (f.* t (..copy_sign imaginary +1.0))})))
-
-(def: (root/2-1z input)
- (-> Complex Complex)
- (|> (complex +1.0) (- (* input input)) ..root/2))
-
-(def: #export (reciprocal (^slots [#real #imaginary]))
- (-> Complex Complex)
- (if (f.< (f.abs imaginary)
- (f.abs real))
- (let [q (f./ imaginary real)
- scale (f./ (|> real (f.* q) (f.+ imaginary))
- +1.0)]
- {#real (f.* q scale)
- #imaginary (f.negate scale)})
- (let [q (f./ real imaginary)
- scale (f./ (|> imaginary (f.* q) (f.+ real))
- +1.0)]
- {#real scale
- #imaginary (|> scale f.negate (f.* q))})))
-
-(def: #export (acos input)
- (-> Complex Complex)
- (|> input
- (..+ (|> input ..root/2-1z (..* ..i)))
- ..log
- (..* (..negate ..i))))
-
-(def: #export (asin input)
- (-> Complex Complex)
- (|> input
- ..root/2-1z
- (..+ (..* ..i input))
- ..log
- (..* (..negate ..i))))
-
-(def: #export (atan input)
- (-> Complex Complex)
- (|> input
- (..+ ..i)
- (../ (..- input ..i))
- ..log
- (..* (../ (..complex +2.0) ..i))))
-
-(def: #export (argument (^slots [#real #imaginary]))
- (-> Complex Frac)
- (math.atan/2 real imaginary))
-
-(def: #export (roots nth input)
- (-> Nat Complex (List Complex))
- (if (n.= 0 nth)
- (list)
- (let [r_nth (|> nth .int int.frac)
- nth_root_of_abs (|> input ..abs (math.pow (f./ r_nth +1.0)))
- nth_phi (|> input ..argument (f./ r_nth))
- slice (|> math.pi (f.* +2.0) (f./ r_nth))]
- (|> (list.indices nth)
- (list\map (function (_ nth')
- (let [inner (|> nth' .int int.frac
- (f.* slice)
- (f.+ nth_phi))
- real (f.* nth_root_of_abs
- (math.cos inner))
- imaginary (f.* nth_root_of_abs
- (math.sin inner))]
- {#real real
- #imaginary imaginary})))))))
-
-(def: #export (approximately? margin_of_error standard value)
- (-> Frac Complex Complex Bit)
- (and (f.approximately? margin_of_error
- (get@ #..real standard)
- (get@ #..real value))
- (f.approximately? margin_of_error
- (get@ #..imaginary standard)
- (get@ #..imaginary value))))
diff --git a/stdlib/source/lux/math/number/frac.lux b/stdlib/source/lux/math/number/frac.lux
deleted file mode 100644
index 4c25d5ca7..000000000
--- a/stdlib/source/lux/math/number/frac.lux
+++ /dev/null
@@ -1,446 +0,0 @@
-(.module:
- [lux (#- nat int rev)
- ["@" target]
- [abstract
- [hash (#+ Hash)]
- [monoid (#+ Monoid)]
- [equivalence (#+ Equivalence)]
- [codec (#+ Codec)]
- [predicate (#+ Predicate)]
- [order (#+ Order)]
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]]
- [data
- ["." maybe]
- ["." text]]]
- ["." // #_
- ["#." i64]
- ["#." nat]
- ["#." int]
- ["#." rev]
- ["/#" //]])
-
-(def: #export (= reference sample)
- {#.doc "Frac(tion) equivalence."}
- (-> Frac Frac Bit)
- ("lux f64 =" reference sample))
-
-(def: #export (< reference sample)
- {#.doc "Frac(tion) less-than."}
- (-> Frac Frac Bit)
- ("lux f64 <" reference sample))
-
-(def: #export (<= reference sample)
- {#.doc "Frac(tion) less-than or equal."}
- (-> Frac Frac Bit)
- (or ("lux f64 <" reference sample)
- ("lux f64 =" reference sample)))
-
-(def: #export (> reference sample)
- {#.doc "Frac(tion) greater-than."}
- (-> Frac Frac Bit)
- ("lux f64 <" sample reference))
-
-(def: #export (>= reference sample)
- {#.doc "Frac(tion) greater-than or equal."}
- (-> Frac Frac Bit)
- (or ("lux f64 <" sample reference)
- ("lux f64 =" sample reference)))
-
-(template [<comparison> <name>]
- [(def: #export <name>
- (Predicate Frac)
- (<comparison> +0.0))]
-
- [..> positive?]
- [..< negative?]
- [..= zero?]
- )
-
-(template [<name> <op> <doc>]
- [(def: #export (<name> param subject)
- {#.doc <doc>}
- (-> Frac Frac Frac)
- (<op> param subject))]
-
- [+ "lux f64 +" "Frac(tion) addition."]
- [- "lux f64 -" "Frac(tion) substraction."]
- [* "lux f64 *" "Frac(tion) multiplication."]
- [/ "lux f64 /" "Frac(tion) division."]
- [% "lux f64 %" "Frac(tion) remainder."]
- )
-
-(def: #export (/% param subject)
- (-> Frac Frac [Frac Frac])
- [(../ param subject)
- (..% param subject)])
-
-(def: #export negate
- (-> Frac Frac)
- (..* -1.0))
-
-(def: #export (abs x)
- (-> Frac Frac)
- (if (..< +0.0 x)
- (..* -1.0 x)
- x))
-
-(def: #export (signum x)
- (-> Frac Frac)
- (cond (..= +0.0 x) +0.0
- (..< +0.0 x) -1.0
- ## else
- +1.0))
-
-(def: min_exponent -1022)
-(def: max_exponent (//int.frac +1023))
-
-(template [<name> <test> <doc>]
- [(def: #export (<name> left right)
- {#.doc <doc>}
- (-> Frac Frac Frac)
- (if (<test> right left)
- left
- right))]
-
- [min ..< "Frac(tion) minimum."]
- [max ..> "Frac(tion) minimum."]
- )
-
-(def: #export nat
- (-> Frac Nat)
- (|>> "lux f64 i64" .nat))
-
-(def: #export int
- (-> Frac Int)
- (|>> "lux f64 i64"))
-
-(def: mantissa_size Nat 52)
-(def: exponent_size Nat 11)
-
-(def: frac_denominator
- (|> -1
- ("lux i64 right-shift" ..exponent_size)
- "lux i64 f64"))
-
-(def: #export rev
- (-> Frac Rev)
- (|>> ..abs
- (..% +1.0)
- (..* ..frac_denominator)
- "lux f64 i64"
- ("lux i64 left-shift" ..exponent_size)))
-
-(implementation: #export equivalence
- (Equivalence Frac)
-
- (def: = ..=))
-
-(implementation: #export order
- (Order Frac)
-
- (def: &equivalence ..equivalence)
- (def: < ..<))
-
-(def: #export smallest
- Frac
- (///.pow (//int.frac (//int.- (.int ..mantissa_size) ..min_exponent))
- +2.0))
-
-(def: #export biggest
- Frac
- (let [f2^-52 (///.pow (//nat.frac (//nat.- ..mantissa_size 0)) +2.0)
- f2^+1023 (///.pow ..max_exponent +2.0)]
- (|> +2.0
- (..- f2^-52)
- (..* f2^+1023))))
-
-(template [<name> <compose> <identity>]
- [(implementation: #export <name>
- (Monoid Frac)
-
- (def: identity <identity>)
- (def: compose <compose>))]
-
- [addition ..+ +0.0]
- [multiplication ..* +1.0]
- [minimum ..min ..biggest]
- [maximum ..max (..* -1.0 ..biggest)]
- )
-
-(template [<name> <numerator> <doc>]
- [(def: #export <name>
- {#.doc <doc>}
- Frac
- (../ +0.0 <numerator>))]
-
- [not_a_number +0.0 "Not a number."]
- [positive_infinity +1.0 "Positive infinity."]
- )
-
-(def: #export negative_infinity
- {#.doc "Negative infinity."}
- Frac
- (..* -1.0 ..positive_infinity))
-
-(def: #export (not_a_number? number)
- {#.doc "Tests whether a frac is actually not-a-number."}
- (-> Frac Bit)
- (not (..= number number)))
-
-(def: #export (number? value)
- (-> Frac Bit)
- (not (or (..not_a_number? value)
- (..= ..positive_infinity value)
- (..= ..negative_infinity value))))
-
-(implementation: #export decimal
- (Codec Text Frac)
-
- (def: (encode x)
- (case x
- -0.0 (let [output ("lux f64 encode" x)]
- (if (text.starts_with? "-" output)
- output
- ("lux text concat" "+" output)))
- _ (if (..< +0.0 x)
- ("lux f64 encode" x)
- ("lux text concat" "+" ("lux f64 encode" x)))))
-
- (def: (decode input)
- (case ("lux f64 decode" [input])
- (#.Some value)
- (#try.Success value)
-
- #.None
- (#try.Failure "Could not decode Frac"))))
-
-(def: log/2
- (-> Frac Frac)
- (|>> ///.log
- (../ (///.log +2.0))))
-
-(def: double_bias Nat 1023)
-
-(def: exponent_mask (//i64.mask ..exponent_size))
-
-(def: exponent_offset ..mantissa_size)
-(def: sign_offset (//nat.+ ..exponent_size ..exponent_offset))
-
-(template [<cast> <hex> <name>]
- [(def: <name> (|> <hex> (\ //nat.hex decode) try.assume <cast>))]
-
- [.i64 "FFF8000000000000" not_a_number_bits]
- [.i64 "7FF0000000000000" positive_infinity_bits]
- [.i64 "FFF0000000000000" negative_infinity_bits]
- [.i64 "0000000000000000" positive_zero_bits]
- [.i64 "8000000000000000" negative_zero_bits]
- [.nat "7FF" special_exponent_bits]
- )
-
-(def: smallest_exponent
- (..log/2 ..smallest))
-
-(def: #export (to_bits input)
- (-> Frac I64)
- (.i64 (cond (..not_a_number? input)
- ..not_a_number_bits
-
- (..= positive_infinity input)
- ..positive_infinity_bits
-
- (..= negative_infinity input)
- ..negative_infinity_bits
-
- (..= +0.0 input)
- (let [reciprocal (../ input +1.0)]
- (if (..= positive_infinity reciprocal)
- ## Positive zero
- ..positive_zero_bits
- ## Negative zero
- ..negative_zero_bits))
-
- ## else
- (let [sign_bit (if (..< -0.0 input)
- 1
- 0)
- input (..abs input)
- exponent (|> input
- ..log/2
- ///.floor
- (..min ..max_exponent))
- min_gap (..- (//int.frac ..min_exponent) exponent)
- power (|> (//nat.frac ..mantissa_size)
- (..+ (..min +0.0 min_gap))
- (..- exponent))
- max_gap (..- ..max_exponent power)
- mantissa (|> input
- (..* (///.pow (..min ..max_exponent power) +2.0))
- (..* (if (..> +0.0 max_gap)
- (///.pow max_gap +2.0)
- +1.0)))
- exponent_bits (|> (if (..< +0.0 min_gap)
- (|> (..int exponent)
- (//int.- (..int min_gap))
- dec)
- (..int exponent))
- (//int.+ (.int ..double_bias))
- (//i64.and ..exponent_mask))
- mantissa_bits (..int mantissa)]
- ($_ //i64.or
- (//i64.left_shift ..sign_offset sign_bit)
- (//i64.left_shift ..exponent_offset exponent_bits)
- (//i64.clear ..mantissa_size mantissa_bits)))
- )))
-
-(template [<getter> <size> <offset>]
- [(def: <getter>
- (-> (I64 Any) I64)
- (let [mask (|> 1 (//i64.left_shift <size>) dec (//i64.left_shift <offset>))]
- (|>> (//i64.and mask) (//i64.right_shift <offset>) .i64)))]
-
- [mantissa ..mantissa_size 0]
- [exponent ..exponent_size ..mantissa_size]
- [sign 1 ..sign_offset]
- )
-
-(def: #export (from_bits input)
- (-> I64 Frac)
- (case [(: Nat (..exponent input))
- (: Nat (..mantissa input))
- (: Nat (..sign input))]
- (^ [(static ..special_exponent_bits) 0 0])
- ..positive_infinity
-
- (^ [(static ..special_exponent_bits) 0 1])
- ..negative_infinity
-
- (^ [(static ..special_exponent_bits) _ _])
- ..not_a_number
-
- ## Positive zero
- [0 0 0] +0.0
- ## Negative zero
- [0 0 1] (..* -1.0 +0.0)
-
- [E M S]
- (let [sign (if (//nat.= 0 S)
- +1.0
- -1.0)
- [mantissa power] (if (//nat.< ..mantissa_size E)
- [(if (//nat.= 0 E)
- M
- (//i64.set ..mantissa_size M))
- (|> E
- (//nat.- ..double_bias)
- .int
- (//int.max ..min_exponent)
- (//int.- (.int ..mantissa_size)))]
- [(//i64.set ..mantissa_size M)
- (|> E (//nat.- ..double_bias) (//nat.- ..mantissa_size) .int)])
- exponent (///.pow (//int.frac power) +2.0)]
- (|> (//nat.frac mantissa)
- (..* exponent)
- (..* sign)))))
-
-(def: (split_exponent codec representation)
- (-> (Codec Text Nat) Text (Try [Text Int]))
- (case [("lux text index" 0 "e+" representation)
- ("lux text index" 0 "E+" representation)
- ("lux text index" 0 "e-" representation)
- ("lux text index" 0 "E-" representation)]
- (^template [<factor> <patterns>]
- [<patterns>
- (do try.monad
- [#let [after_offset (//nat.+ 2 split_index)
- after_length (//nat.- after_offset ("lux text size" representation))]
- exponent (|> representation
- ("lux text clip" after_offset after_length)
- (\ codec decode))]
- (wrap [("lux text clip" 0 split_index representation)
- (//int.* <factor> (.int exponent))]))])
- ([+1 (^or [(#.Some split_index) #.None #.None #.None]
- [#.None (#.Some split_index) #.None #.None])]
- [-1 (^or [#.None #.None (#.Some split_index) #.None]
- [#.None #.None #.None (#.Some split_index)])])
-
- _
- (#try.Success [representation +0])))
-
-(template [<struct> <nat> <int> <error>]
- [(implementation: #export <struct>
- (Codec Text Frac)
-
- (def: (encode value)
- (let [bits (..to_bits value)
- mantissa (..mantissa bits)
- exponent (//int.- (.int ..double_bias) (..exponent bits))
- sign (..sign bits)]
- ($_ "lux text concat"
- (case (.nat sign)
- 1 "-"
- 0 "+"
- _ (undefined))
- (\ <nat> encode (.nat mantissa))
- ".0E"
- (\ <int> encode exponent))))
-
- (def: (decode representation)
- (let [negative? (text.starts_with? "-" representation)
- positive? (text.starts_with? "+" representation)]
- (if (or negative? positive?)
- (do {! try.monad}
- [[mantissa exponent] (..split_exponent <nat> representation)
- [whole decimal] (case ("lux text index" 0 "." mantissa)
- (#.Some split_index)
- (do !
- [#let [after_offset (inc split_index)
- after_length (//nat.- after_offset ("lux text size" mantissa))]
- decimal (|> mantissa
- ("lux text clip" after_offset after_length)
- (\ <nat> decode))]
- (wrap [("lux text clip" 0 split_index mantissa)
- decimal]))
-
- #.None
- (#try.Failure ("lux text concat" <error> representation)))
- #let [whole ("lux text clip" 1 (dec ("lux text size" whole)) whole)]
- mantissa (\ <nat> decode (case decimal
- 0 whole
- _ ("lux text concat" whole (\ <nat> encode decimal))))
- #let [sign (if negative? 1 0)]]
- (wrap (..from_bits
- ($_ //i64.or
- (//i64.left_shift ..sign_offset (.i64 sign))
- (//i64.left_shift ..mantissa_size (.i64 (//int.+ (.int ..double_bias) exponent)))
- (//i64.clear ..mantissa_size (.i64 mantissa))))))
- (#try.Failure ("lux text concat" <error> representation))))))]
-
- [binary //nat.binary //int.binary "Invalid binary syntax: "]
- [octal //nat.octal //int.octal "Invalid octaladecimal syntax: "]
- [hex //nat.hex //int.hex "Invalid hexadecimal syntax: "]
- )
-
-(implementation: #export hash
- (Hash Frac)
-
- (def: &equivalence ..equivalence)
- (def: hash ..to_bits))
-
-(def: #export (approximately? margin_of_error standard value)
- (-> Frac Frac Frac Bit)
- (|> value
- (..- standard)
- ..abs
- (..< margin_of_error)))
-
-(def: #export (mod divisor dividend)
- (All [m] (-> Frac Frac Frac))
- (let [remainder (..% divisor dividend)]
- (if (or (and (..< +0.0 divisor)
- (..> +0.0 remainder))
- (and (..> +0.0 divisor)
- (..< +0.0 remainder)))
- (..+ divisor remainder)
- remainder)))
diff --git a/stdlib/source/lux/math/number/i16.lux b/stdlib/source/lux/math/number/i16.lux
deleted file mode 100644
index ba4f9cd02..000000000
--- a/stdlib/source/lux/math/number/i16.lux
+++ /dev/null
@@ -1,23 +0,0 @@
-(.module:
- [lux (#- i64)
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- ["." maybe]]
- [type (#+ :by_example)]]
- [//
- ["." i64 (#+ Sub)]])
-
-(def: sub (maybe.assume (i64.sub 16)))
-
-(def: #export I16
- (:by_example [size]
- (Sub size)
- ..sub
-
- (I64 size)))
-
-(def: #export equivalence (Equivalence I16) (\ ..sub &equivalence))
-(def: #export width Nat (\ ..sub width))
-(def: #export i16 (-> I64 I16) (\ ..sub narrow))
-(def: #export i64 (-> I16 I64) (\ ..sub widen))
diff --git a/stdlib/source/lux/math/number/i32.lux b/stdlib/source/lux/math/number/i32.lux
deleted file mode 100644
index 9141c175d..000000000
--- a/stdlib/source/lux/math/number/i32.lux
+++ /dev/null
@@ -1,23 +0,0 @@
-(.module:
- [lux (#- i64)
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- ["." maybe]]
- [type (#+ :by_example)]]
- [//
- ["." i64 (#+ Sub)]])
-
-(def: sub (maybe.assume (i64.sub 32)))
-
-(def: #export I32
- (:by_example [size]
- (Sub size)
- ..sub
-
- (I64 size)))
-
-(def: #export equivalence (Equivalence I32) (\ ..sub &equivalence))
-(def: #export width Nat (\ ..sub width))
-(def: #export i32 (-> I64 I32) (\ ..sub narrow))
-(def: #export i64 (-> I32 I64) (\ ..sub widen))
diff --git a/stdlib/source/lux/math/number/i64.lux b/stdlib/source/lux/math/number/i64.lux
deleted file mode 100644
index a3b415287..000000000
--- a/stdlib/source/lux/math/number/i64.lux
+++ /dev/null
@@ -1,213 +0,0 @@
-(.module:
- [lux (#- and or not false true)
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]
- [monoid (#+ Monoid)]]
- [control
- ["." try]]]
- [//
- ["n" nat]])
-
-(def: #export bits_per_byte
- 8)
-
-(def: #export bytes_per_i64
- 8)
-
-(def: #export width
- Nat
- (n.* ..bits_per_byte
- ..bytes_per_i64))
-
-(template [<parameter_type> <name> <op> <doc>]
- [(def: #export (<name> parameter subject)
- {#.doc <doc>}
- (All [s] (-> <parameter_type> (I64 s) (I64 s)))
- (<op> parameter subject))]
-
- [(I64 Any) or "lux i64 or" "Bitwise or."]
- [(I64 Any) xor "lux i64 xor" "Bitwise xor."]
- [(I64 Any) and "lux i64 and" "Bitwise and."]
-
- [Nat left_shift "lux i64 left-shift" "Bitwise left-shift."]
- [Nat right_shift "lux i64 right-shift" "Unsigned/logic bitwise right-shift."]
- )
-
-(type: #export Mask
- I64)
-
-(def: #export (bit position)
- (-> Nat Mask)
- (|> 1 .i64 (..left_shift (n.% ..width position))))
-
-(def: #export sign
- Mask
- (..bit (dec ..width)))
-
-(def: #export not
- {#.doc "Bitwise negation."}
- (All [s] (-> (I64 s) (I64 s)))
- (..xor (.i64 (dec 0))))
-
-(def: #export false
- Mask
- (.i64 0))
-
-(def: #export true
- Mask
- (..not ..false))
-
-(def: #export (mask amount_of_bits)
- (-> Nat Mask)
- (case amount_of_bits
- 0 ..false
- bits (case (n.% ..width bits)
- 0 ..true
- bits (|> 1 .i64 (..left_shift (n.% ..width bits)) .dec))))
-
-(def: (add_shift shift value)
- (-> Nat Nat Nat)
- (|> value (right_shift shift) (n.+ value)))
-
-(def: #export (count subject)
- {#.doc "Count the number of 1s in a bit-map."}
- (-> (I64 Any) Nat)
- (let [count' (n.- (|> subject (right_shift 1) (..and 6148914691236517205) i64)
- (i64 subject))]
- (|> count'
- (right_shift 2) (..and 3689348814741910323) (n.+ (..and 3689348814741910323 count'))
- (add_shift 4) (..and 1085102592571150095)
- (add_shift 8)
- (add_shift 16)
- (add_shift 32)
- (..and 127))))
-
-(def: #export (clear idx input)
- {#.doc "Clear bit at given index."}
- (All [s] (-> Nat (I64 s) (I64 s)))
- (|> idx ..bit ..not (..and input)))
-
-(template [<name> <op> <doc>]
- [(def: #export (<name> idx input)
- {#.doc <doc>}
- (All [s] (-> Nat (I64 s) (I64 s)))
- (|> idx ..bit (<op> input)))]
-
- [set ..or "Set bit at given index."]
- [flip ..xor "Flip bit at given index."]
- )
-
-(def: #export (set? idx input)
- (-> Nat (I64 Any) Bit)
- (|> input (:as I64) (..and (..bit idx)) (n.= 0) .not))
-
-(def: #export (clear? idx input)
- (-> Nat (I64 Any) Bit)
- (.not (..set? idx input)))
-
-(template [<name> <forward> <backward>]
- [(def: #export (<name> distance input)
- (All [s] (-> Nat (I64 s) (I64 s)))
- (..or (<forward> distance input)
- (<backward> (n.- (n.% ..width distance) ..width) input)))]
-
- [rotate_left ..left_shift ..right_shift]
- [rotate_right ..right_shift ..left_shift]
- )
-
-(def: #export (region size offset)
- (-> Nat Nat Mask)
- (..left_shift offset (..mask size)))
-
-(implementation: #export equivalence
- (All [a] (Equivalence (I64 a)))
-
- (def: (= reference sample)
- ("lux i64 =" reference sample)))
-
-(implementation: #export hash
- (All [a] (Hash (I64 a)))
-
- (def: &equivalence ..equivalence)
-
- (def: hash .nat))
-
-(template [<monoid> <identity> <compose>]
- [(implementation: #export <monoid>
- (All [a] (Monoid (I64 a)))
-
- (def: identity <identity>)
- (def: compose <compose>))]
-
- [disjunction ..false ..or]
- [conjunction ..true ..and]
- )
-
-(def: #export reverse
- (All [a] (-> (I64 a) (I64 a)))
- (let [swapper (: (-> Nat (All [a] (-> (I64 a) (I64 a))))
- (function (_ power)
- (let [size (..left_shift power 1)
- repetitions (: (-> Nat Text Text)
- (function (_ times char)
- (loop [iterations 1
- output char]
- (if (n.< times iterations)
- (recur (inc iterations)
- ("lux text concat" char output))
- output))))
- pattern (repetitions (n./ (n.+ size size) ..width)
- ("lux text concat"
- (repetitions size "1")
- (repetitions size "0")))
-
- high (try.assume (\ n.binary decode pattern))
- low (..rotate_right size high)]
- (function (_ value)
- (..or (..right_shift size (..and high value))
- (..left_shift size (..and low value)))))))
-
- swap/01 (swapper 0)
- swap/02 (swapper 1)
- swap/04 (swapper 2)
- swap/08 (swapper 3)
- swap/16 (swapper 4)
- swap/32 (swapper 5)]
- (|>> swap/32
- swap/16
- swap/08
- swap/04
- swap/02
- swap/01)))
-
-(interface: #export (Sub size)
- (: (Equivalence (I64 size))
- &equivalence)
- (: Nat
- width)
- (: (-> I64 (I64 size))
- narrow)
- (: (-> (I64 size) I64)
- widen))
-
-(def: #export (sub width)
- (Ex [size] (-> Nat (Maybe (Sub size))))
- (if (.and (n.> 0 width)
- (n.< ..width width))
- (let [sign_shift (n.- width ..width)
- sign (..bit (dec width))
- mantissa (..mask (dec width))
- co_mantissa (..xor (.i64 -1) mantissa)]
- (#.Some (: Sub
- (implementation
- (def: &equivalence ..equivalence)
- (def: width width)
- (def: (narrow value)
- (..or (|> value (..and ..sign) (..right_shift sign_shift))
- (|> value (..and mantissa))))
- (def: (widen value)
- (.i64 (case (.nat (..and sign value))
- 0 value
- _ (..or co_mantissa value))))))))
- #.None))
diff --git a/stdlib/source/lux/math/number/i8.lux b/stdlib/source/lux/math/number/i8.lux
deleted file mode 100644
index d6184315c..000000000
--- a/stdlib/source/lux/math/number/i8.lux
+++ /dev/null
@@ -1,23 +0,0 @@
-(.module:
- [lux (#- i64)
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- ["." maybe]]
- [type (#+ :by_example)]]
- [//
- ["." i64 (#+ Sub)]])
-
-(def: sub (maybe.assume (i64.sub 8)))
-
-(def: #export I8
- (:by_example [size]
- (Sub size)
- ..sub
-
- (I64 size)))
-
-(def: #export equivalence (Equivalence I8) (\ ..sub &equivalence))
-(def: #export width Nat (\ ..sub width))
-(def: #export i8 (-> I64 I8) (\ ..sub narrow))
-(def: #export i64 (-> I8 I64) (\ ..sub widen))
diff --git a/stdlib/source/lux/math/number/int.lux b/stdlib/source/lux/math/number/int.lux
deleted file mode 100644
index 708ab8dd4..000000000
--- a/stdlib/source/lux/math/number/int.lux
+++ /dev/null
@@ -1,259 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [hash (#+ Hash)]
- [enum (#+ Enum)]
- [interval (#+ Interval)]
- [monoid (#+ Monoid)]
- [equivalence (#+ Equivalence)]
- [codec (#+ Codec)]
- [predicate (#+ Predicate)]
- ["." order (#+ Order)]]
- [control
- ["." try (#+ Try)]]
- [data
- [text (#+ Char)]
- ["." maybe]]]
- ["." // #_
- ["#." nat]
- ["#." i64]])
-
-(def: #export (= reference sample)
- {#.doc "Int(eger) equivalence."}
- (-> Int Int Bit)
- ("lux i64 =" reference sample))
-
-(def: #export (< reference sample)
- {#.doc "Int(eger) less-than."}
- (-> Int Int Bit)
- ("lux i64 <" reference sample))
-
-(def: #export (<= reference sample)
- {#.doc "Int(eger) less-than or equal."}
- (-> Int Int Bit)
- (if ("lux i64 <" reference sample)
- #1
- ("lux i64 =" reference sample)))
-
-(def: #export (> reference sample)
- {#.doc "Int(eger) greater-than."}
- (-> Int Int Bit)
- ("lux i64 <" sample reference))
-
-(def: #export (>= reference sample)
- {#.doc "Int(eger) greater-than or equal."}
- (-> Int Int Bit)
- (if ("lux i64 <" sample reference)
- #1
- ("lux i64 =" reference sample)))
-
-(template [<comparison> <name>]
- [(def: #export <name>
- (Predicate Int)
- (<comparison> +0))]
-
- [..> positive?]
- [..< negative?]
- [..= zero?]
- )
-
-(template [<name> <test> <doc>]
- [(def: #export (<name> left right)
- {#.doc <doc>}
- (-> Int Int Int)
- (if (<test> right left)
- left
- right))]
-
- [min ..< "Int(eger) minimum."]
- [max ..> "Int(eger) maximum."]
- )
-
-(template [<name> <op> <doc>]
- [(def: #export (<name> param subject)
- {#.doc <doc>}
- (-> Int Int Int)
- (<op> param subject))]
-
- [+ "lux i64 +" "Int(eger) addition."]
- [- "lux i64 -" "Int(eger) substraction."]
- [* "lux i64 *" "Int(eger) multiplication."]
- [/ "lux i64 /" "Int(eger) division."]
- [% "lux i64 %" "Int(eger) remainder."]
- )
-
-(def: #export (/% param subject)
- (-> Int Int [Int Int])
- [(../ param subject)
- (..% param subject)])
-
-(def: #export (negate value)
- (-> Int Int)
- (..- value +0))
-
-(def: #export (abs x)
- (-> Int Int)
- (if (..< +0 x)
- (..* -1 x)
- x))
-
-(def: #export (signum x)
- (-> Int Int)
- (cond (..= +0 x) +0
- (..< +0 x) -1
- ## else
- +1))
-
-## https://rob.conery.io/2018/08/21/mod-and-remainder-are-not-the-same/
-(def: #export (mod divisor dividend)
- (All [m] (-> Int Int Int))
- (let [remainder (..% divisor dividend)]
- (if (or (and (..< +0 divisor)
- (..> +0 remainder))
- (and (..> +0 divisor)
- (..< +0 remainder)))
- (..+ divisor remainder)
- remainder)))
-
-(def: #export even?
- (-> Int Bit)
- (|>> (..% +2) ("lux i64 =" +0)))
-
-(def: #export odd?
- (-> Int Bit)
- (|>> ..even? not))
-
-(def: #export (gcd a b)
- {#.doc "Greatest Common Divisor."}
- (-> Int Int Int)
- (case b
- +0 a
- _ (gcd b (..% b a))))
-
-(def: #export (co-prime? a b)
- (-> Int Int Bit)
- (..= +1 (..gcd a b)))
-
-## https://en.wikipedia.org/wiki/Extended_Euclidean_algorithm
-(def: #export (extended_gcd a b)
- {#.doc "Extended euclidean algorithm."}
- (-> Int Int [[Int Int] Int])
- (loop [x +1 x1 +0
- y +0 y1 +1
- a1 a b1 b]
- (case b1
- +0 [[x y] a1]
- _ (let [q (/ b1 a1)]
- (recur x1 (- (* q x1) x)
- y1 (- (* q y1) y)
- b1 (- (* q b1) a1))))))
-
-(def: #export (lcm a b)
- {#.doc "Least Common Multiple."}
- (-> Int Int Int)
- (case [a b]
- (^or [_ +0] [+0 _])
- +0
-
- _
- (|> a (/ (gcd a b)) (* b))
- ))
-
-(def: #export frac
- (-> Int Frac)
- (|>> "lux i64 f64"))
-
-(implementation: #export equivalence
- (Equivalence Int)
-
- (def: = ..=))
-
-(implementation: #export order
- (Order Int)
-
- (def: &equivalence ..equivalence)
- (def: < ..<))
-
-(implementation: #export enum
- (Enum Int)
-
- (def: &order ..order)
- (def: succ inc)
- (def: pred dec))
-
-## TODO: Find out why the numeric literals fail during JS compilation.
-(implementation: #export interval
- (Interval Int)
-
- (def: &enum ..enum)
- (def: top
- ## +9,223,372,036,854,775,807
- (let [half (//i64.left_shift 62 +1)]
- (+ half
- (dec half))))
- (def: bottom
- ## -9,223,372,036,854,775,808
- (//i64.left_shift 63 +1)))
-
-(template [<name> <compose> <identity>]
- [(implementation: #export <name>
- (Monoid Int)
-
- (def: identity <identity>)
- (def: compose <compose>))]
-
- [addition ..+ +0]
- [multiplication ..* +1]
- [maximum ..max (\ ..interval bottom)]
- [minimum ..min (\ ..interval top)]
- )
-
-(def: -sign "-")
-(def: +sign "+")
-
-(template [<struct> <codec> <error>]
- [(implementation: #export <struct>
- (Codec Text Int)
-
- (def: (encode value)
- (if (..< +0 value)
- (|> value inc ..negate .nat inc (\ <codec> encode) ("lux text concat" ..-sign))
- (|> value .nat (\ <codec> encode) ("lux text concat" ..+sign))))
-
- (def: (decode repr)
- (let [input_size ("lux text size" repr)]
- (if (//nat.> 1 input_size)
- (case ("lux text clip" 0 1 repr)
- (^ (static ..+sign))
- (|> repr
- ("lux text clip" 1 (dec input_size))
- (\ <codec> decode)
- (\ try.functor map .int))
-
- (^ (static ..-sign))
- (|> repr
- ("lux text clip" 1 (dec input_size))
- (\ <codec> decode)
- (\ try.functor map (|>> dec .int ..negate dec)))
-
- _
- (#try.Failure <error>))
- (#try.Failure <error>)))))]
-
- [binary //nat.binary "Invalid binary syntax for Int: "]
- [octal //nat.octal "Invalid octal syntax for Int: "]
- [decimal //nat.decimal "Invalid syntax for Int: "]
- [hex //nat.hex "Invalid hexadecimal syntax for Int: "]
- )
-
-(implementation: #export hash
- (Hash Int)
-
- (def: &equivalence ..equivalence)
- (def: hash .nat))
-
-(def: #export (right_shift parameter subject)
- {#.doc "Signed/arithmetic bitwise right-shift."}
- (-> Nat Int Int)
- (//i64.or (//i64.and //i64.sign subject)
- (//i64.right_shift parameter subject)))
diff --git a/stdlib/source/lux/math/number/nat.lux b/stdlib/source/lux/math/number/nat.lux
deleted file mode 100644
index 248c169ba..000000000
--- a/stdlib/source/lux/math/number/nat.lux
+++ /dev/null
@@ -1,379 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [hash (#+ Hash)]
- [enum (#+ Enum)]
- [interval (#+ Interval)]
- [monoid (#+ Monoid)]
- [equivalence (#+ Equivalence)]
- [codec (#+ Codec)]
- ["." order (#+ Order)]]
- [control
- ["." function]
- ["." try (#+ Try)]]
- [data
- ["." maybe]]])
-
-(template [<extension> <output> <name> <documentation>]
- [(def: #export (<name> parameter subject)
- {#.doc <documentation>}
- (-> Nat Nat <output>)
- (<extension> parameter subject))]
-
- ["lux i64 =" Bit = "Nat(ural) equivalence."]
- ["lux i64 +" Nat + "Nat(ural) addition."]
- ["lux i64 -" Nat - "Nat(ural) substraction."]
- )
-
-(def: high
- (-> (I64 Any) I64)
- (|>> ("lux i64 right-shift" 32)))
-
-(def: low
- (-> (I64 Any) I64)
- (let [mask (|> 1 ("lux i64 left-shift" 32) ("lux i64 -" 1))]
- (|>> ("lux i64 and" mask))))
-
-(def: #export (< reference sample)
- {#.doc "Nat(ural) less-than."}
- (-> Nat Nat Bit)
- (let [referenceH (..high reference)
- sampleH (..high sample)]
- (if ("lux i64 <" referenceH sampleH)
- #1
- (if ("lux i64 =" referenceH sampleH)
- ("lux i64 <"
- (..low reference)
- (..low sample))
- #0))))
-
-(def: #export (<= reference sample)
- {#.doc "Nat(ural) less-than or equal."}
- (-> Nat Nat Bit)
- (if (..< reference sample)
- #1
- ("lux i64 =" reference sample)))
-
-(def: #export (> reference sample)
- {#.doc "Nat(ural) greater-than."}
- (-> Nat Nat Bit)
- (..< sample reference))
-
-(def: #export (>= reference sample)
- {#.doc "Nat(ural) greater-than or equal."}
- (-> Nat Nat Bit)
- (if (..< sample reference)
- #1
- ("lux i64 =" reference sample)))
-
-(template [<name> <test> <doc>]
- [(def: #export (<name> left right)
- {#.doc <doc>}
- (-> Nat Nat Nat)
- (if (<test> right left)
- left
- right))]
-
- [min ..< "Nat(ural) minimum."]
- [max ..> "Nat(ural) maximum."]
- )
-
-(def: #export (* parameter subject)
- {#.doc "Nat(ural) multiplication."}
- (-> Nat Nat Nat)
- (:as Nat
- ("lux i64 *"
- (:as Int parameter)
- (:as Int subject))))
-
-(def: #export (/ parameter subject)
- {#.doc "Nat(ural) division."}
- (-> Nat Nat Nat)
- (if ("lux i64 <" +0 (:as Int parameter))
- (if (..< parameter subject)
- 0
- 1)
- (let [quotient (|> subject
- ("lux i64 right-shift" 1)
- ("lux i64 /" (:as Int parameter))
- ("lux i64 left-shift" 1))
- flat ("lux i64 *"
- (:as Int parameter)
- (:as Int quotient))
- remainder ("lux i64 -" flat subject)]
- (if (..< parameter remainder)
- quotient
- ("lux i64 +" 1 quotient)))))
-
-(def: #export (/% parameter subject)
- {#.doc "Nat(ural) [division remainder]."}
- (-> Nat Nat [Nat Nat])
- (let [quotient (../ parameter subject)
- flat ("lux i64 *"
- (:as Int parameter)
- (:as Int quotient))]
- [quotient ("lux i64 -" flat subject)]))
-
-(def: #export (% parameter subject)
- {#.doc "Nat(ural) remainder."}
- (-> Nat Nat Nat)
- (let [flat ("lux i64 *"
- (:as Int parameter)
- (:as Int (../ parameter subject)))]
- ("lux i64 -" flat subject)))
-
-(def: #export (gcd a b)
- {#.doc "Greatest Common Divisor."}
- (-> Nat Nat Nat)
- (case b
- 0 a
- _ (gcd b (..% b a))))
-
-(def: #export (co-prime? a b)
- (-> Nat Nat Bit)
- (..= 1 (..gcd a b)))
-
-(def: #export (lcm a b)
- {#.doc "Least Common Multiple."}
- (-> Nat Nat Nat)
- (case [a b]
- (^or [_ 0] [0 _])
- 0
-
- _
- (|> a (../ (..gcd a b)) (..* b))))
-
-(def: #export even?
- (-> Nat Bit)
- (|>> (..% 2) ("lux i64 =" 0)))
-
-(def: #export odd?
- (-> Nat Bit)
- (|>> ..even? not))
-
-(def: #export frac
- (-> Nat Frac)
- (|>> .int "lux i64 f64"))
-
-(implementation: #export equivalence
- (Equivalence Nat)
-
- (def: = ..=))
-
-(implementation: #export order
- (Order Nat)
-
- (def: &equivalence ..equivalence)
- (def: < ..<))
-
-(implementation: #export enum
- (Enum Nat)
-
- (def: &order ..order)
- (def: succ inc)
- (def: pred dec))
-
-(implementation: #export interval
- (Interval Nat)
-
- (def: &enum ..enum)
- (def: top (dec 0))
- (def: bottom 0))
-
-(template [<name> <compose> <identity>]
- [(implementation: #export <name>
- (Monoid Nat)
-
- (def: identity <identity>)
- (def: compose <compose>))]
-
- [addition ..+ 0]
- [multiplication ..* 1]
- [minimum ..min (\ ..interval top)]
- [maximum ..max (\ ..interval bottom)]
- )
-
-(def: (binary-character value)
- (-> Nat Text)
- (case value
- 0 "0"
- 1 "1"
- _ (undefined)))
-
-(def: (binary-value digit)
- (-> Nat (Maybe Nat))
- (case digit
- (^ (char "0")) (#.Some 0)
- (^ (char "1")) (#.Some 1)
- _ #.None))
-
-(def: (octal-character value)
- (-> Nat Text)
- (case value
- 0 "0"
- 1 "1"
- 2 "2"
- 3 "3"
- 4 "4"
- 5 "5"
- 6 "6"
- 7 "7"
- _ (undefined)))
-
-(def: (octal-value digit)
- (-> Nat (Maybe Nat))
- (case digit
- (^ (char "0")) (#.Some 0)
- (^ (char "1")) (#.Some 1)
- (^ (char "2")) (#.Some 2)
- (^ (char "3")) (#.Some 3)
- (^ (char "4")) (#.Some 4)
- (^ (char "5")) (#.Some 5)
- (^ (char "6")) (#.Some 6)
- (^ (char "7")) (#.Some 7)
- _ #.None))
-
-(def: (decimal-character value)
- (-> Nat Text)
- (case value
- 0 "0"
- 1 "1"
- 2 "2"
- 3 "3"
- 4 "4"
- 5 "5"
- 6 "6"
- 7 "7"
- 8 "8"
- 9 "9"
- _ (undefined)))
-
-(def: (decimal-value digit)
- (-> Nat (Maybe Nat))
- (case digit
- (^ (char "0")) (#.Some 0)
- (^ (char "1")) (#.Some 1)
- (^ (char "2")) (#.Some 2)
- (^ (char "3")) (#.Some 3)
- (^ (char "4")) (#.Some 4)
- (^ (char "5")) (#.Some 5)
- (^ (char "6")) (#.Some 6)
- (^ (char "7")) (#.Some 7)
- (^ (char "8")) (#.Some 8)
- (^ (char "9")) (#.Some 9)
- _ #.None))
-
-(def: (hexadecimal-character value)
- (-> Nat Text)
- (case value
- 0 "0"
- 1 "1"
- 2 "2"
- 3 "3"
- 4 "4"
- 5 "5"
- 6 "6"
- 7 "7"
- 8 "8"
- 9 "9"
- 10 "A"
- 11 "B"
- 12 "C"
- 13 "D"
- 14 "E"
- 15 "F"
- _ (undefined)))
-
-(def: (hexadecimal-value digit)
- (-> Nat (Maybe Nat))
- (case digit
- (^template [<character> <number>]
- [(^ (char <character>)) (#.Some <number>)])
- (["0" 0] ["1" 1] ["2" 2] ["3" 3] ["4" 4]
- ["5" 5] ["6" 6] ["7" 7] ["8" 8] ["9" 9])
-
- (^template [<lower> <upper> <number>]
- [(^or (^ (char <lower>)) (^ (char <upper>))) (#.Some <number>)])
- (["a" "A" 10] ["b" "B" 11] ["c" "C" 12]
- ["d" "D" 13] ["e" "E" 14] ["f" "F" 15])
- _ #.None))
-
-(template [<shift> <struct> <to-character> <to-value> <error>]
- [(implementation: #export <struct>
- (Codec Text Nat)
-
- (def: encode
- (let [mask (|> 1 ("lux i64 left-shift" <shift>) dec)]
- (function (_ value)
- (loop [input value
- output ""]
- (let [output' ("lux text concat"
- (<to-character> ("lux i64 and" mask input))
- output)]
- (case (: Nat ("lux i64 right-shift" <shift> input))
- 0
- output'
-
- input'
- (recur input' output')))))))
-
- (def: (decode repr)
- (let [input-size ("lux text size" repr)]
- (if (..> 0 input-size)
- (loop [idx 0
- output 0]
- (if (..< input-size idx)
- (case (<to-value> ("lux text char" idx repr))
- (#.Some digit-value)
- (recur (inc idx)
- (|> output
- ("lux i64 left-shift" <shift>)
- ("lux i64 or" digit-value)))
-
- _
- (#try.Failure ("lux text concat" <error> repr)))
- (#try.Success output)))
- (#try.Failure ("lux text concat" <error> repr))))))]
-
- [1 binary binary-character binary-value "Invalid binary syntax for Nat: "]
- [3 octal octal-character octal-value "Invalid octal syntax for Nat: "]
- [4 hex hexadecimal-character hexadecimal-value "Invalid hexadecimal syntax for Nat: "]
- )
-
-(implementation: #export decimal
- (Codec Text Nat)
-
- (def: (encode value)
- (loop [input value
- output ""]
- (let [digit (decimal-character (..% 10 input))
- output' ("lux text concat" digit output)]
- (case (../ 10 input)
- 0
- output'
-
- input'
- (recur input' output')))))
-
- (def: (decode repr)
- (let [input-size ("lux text size" repr)]
- (with_expansions [<failure> (#try.Failure ("lux text concat" "Invalid decimal syntax for Nat: " repr))]
- (if (..> 0 input-size)
- (loop [idx 0
- output 0]
- (if (..< input-size idx)
- (case (decimal-value ("lux text char" idx repr))
- #.None
- <failure>
-
- (#.Some digit-value)
- (recur (inc idx)
- (|> output (..* 10) (..+ digit-value))))
- (#try.Success output)))
- <failure>)))))
-
-(implementation: #export hash
- (Hash Nat)
-
- (def: &equivalence ..equivalence)
- (def: hash function.identity))
diff --git a/stdlib/source/lux/math/number/ratio.lux b/stdlib/source/lux/math/number/ratio.lux
deleted file mode 100644
index ad2092fbd..000000000
--- a/stdlib/source/lux/math/number/ratio.lux
+++ /dev/null
@@ -1,161 +0,0 @@
-(.module:
- {#.doc "Rational numbers."}
- [lux (#- nat)
- [abstract
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]
- [monoid (#+ Monoid)]
- [codec (#+ Codec)]
- [monad (#+ do)]]
- [control
- ["." function]
- ["." try]
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- ["." product]
- ["." maybe]
- ["." text ("#\." monoid)]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]]]
- [//
- ["n" nat ("#\." decimal)]])
-
-(type: #export Ratio
- {#numerator Nat
- #denominator Nat})
-
-(def: #export (nat value)
- (-> Ratio (Maybe Nat))
- (case (get@ #denominator value)
- 1 (#.Some (get@ #numerator value))
- _ #.None))
-
-(def: (normalize (^slots [#numerator #denominator]))
- (-> Ratio Ratio)
- (let [common (n.gcd numerator denominator)]
- {#numerator (n./ common numerator)
- #denominator (n./ common denominator)}))
-
-(syntax: #export (ratio numerator {?denominator (<>.maybe <code>.any)})
- {#.doc (doc "Rational literals."
- (ratio numerator denominator)
- "The denominator can be omitted if it's 1."
- (ratio numerator))}
- (wrap (list (` ((~! ..normalize) {#..numerator (~ numerator)
- #..denominator (~ (maybe.default (' 1)
- ?denominator))})))))
-
-(def: #export (= parameter subject)
- (-> Ratio Ratio Bit)
- (and (n.= (get@ #numerator parameter)
- (get@ #numerator subject))
- (n.= (get@ #denominator parameter)
- (get@ #denominator subject))))
-
-(implementation: #export equivalence
- (Equivalence Ratio)
-
- (def: = ..=))
-
-(def: (equalize parameter subject)
- (-> Ratio Ratio [Nat Nat])
- [(n.* (get@ #denominator subject)
- (get@ #numerator parameter))
- (n.* (get@ #denominator parameter)
- (get@ #numerator subject))])
-
-(def: #export (< parameter subject)
- (-> Ratio Ratio Bit)
- (let [[parameter' subject'] (..equalize parameter subject)]
- (n.< parameter' subject')))
-
-(def: #export (<= parameter subject)
- (-> Ratio Ratio Bit)
- (or (< parameter subject)
- (= parameter subject)))
-
-(def: #export (> parameter subject)
- (-> Ratio Ratio Bit)
- (..< subject parameter))
-
-(def: #export (>= parameter subject)
- (-> Ratio Ratio Bit)
- (or (> parameter subject)
- (= parameter subject)))
-
-(implementation: #export order
- (Order Ratio)
-
- (def: &equivalence ..equivalence)
- (def: < ..<))
-
-(def: #export (+ parameter subject)
- (-> Ratio Ratio Ratio)
- (let [[parameter' subject'] (..equalize parameter subject)]
- (normalize [(n.+ parameter' subject')
- (n.* (get@ #denominator parameter)
- (get@ #denominator subject))])))
-
-(def: #export (- parameter subject)
- (-> Ratio Ratio Ratio)
- (let [[parameter' subject'] (..equalize parameter subject)]
- (normalize [(n.- parameter' subject')
- (n.* (get@ #denominator parameter)
- (get@ #denominator subject))])))
-
-(def: #export (* parameter subject)
- (-> Ratio Ratio Ratio)
- (normalize [(n.* (get@ #numerator parameter)
- (get@ #numerator subject))
- (n.* (get@ #denominator parameter)
- (get@ #denominator subject))]))
-
-(def: #export (/ parameter subject)
- (-> Ratio Ratio Ratio)
- (let [[parameter' subject'] (..equalize parameter subject)]
- (normalize [subject' parameter'])))
-
-(def: #export (% parameter subject)
- (-> Ratio Ratio Ratio)
- (let [[parameter' subject'] (..equalize parameter subject)
- quot (n./ parameter' subject')]
- (..- (update@ #numerator (n.* quot) parameter)
- subject)))
-
-(def: #export (reciprocal (^slots [#numerator #denominator]))
- (-> Ratio Ratio)
- {#numerator denominator
- #denominator numerator})
-
-(def: separator ":")
-
-(implementation: #export codec
- (Codec Text Ratio)
-
- (def: (encode (^slots [#numerator #denominator]))
- ($_ text\compose (n\encode numerator) ..separator (n\encode denominator)))
-
- (def: (decode input)
- (case (text.split_with ..separator input)
- (#.Some [num denom])
- (do try.monad
- [numerator (n\decode num)
- denominator (n\decode denom)]
- (wrap (normalize {#numerator numerator
- #denominator denominator})))
-
- #.None
- (#.Left (text\compose "Invalid syntax for ratio: " input)))))
-
-(template [<identity> <compose> <name>]
- [(implementation: #export <name>
- (Monoid Ratio)
-
- (def: identity (..ratio <identity>))
- (def: compose <compose>))]
-
- [0 ..+ addition]
- [1 ..* multiplication]
- )
diff --git a/stdlib/source/lux/math/number/rev.lux b/stdlib/source/lux/math/number/rev.lux
deleted file mode 100644
index 0f96320e3..000000000
--- a/stdlib/source/lux/math/number/rev.lux
+++ /dev/null
@@ -1,462 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [hash (#+ Hash)]
- [enum (#+ Enum)]
- [interval (#+ Interval)]
- [monoid (#+ Monoid)]
- [equivalence (#+ Equivalence)]
- [codec (#+ Codec)]
- [order (#+ Order)]]
- [control
- ["." try]]
- [data
- ["." maybe]
- [collection
- ["." array (#+ Array)]]]]
- ["." // #_
- ["#." i64]
- ["#." nat]
- ["#." int]])
-
-(template [<power> <name>]
- [(def: #export <name>
- Rev
- (.rev (//i64.left_shift (//nat.- <power> //i64.width) 1)))]
-
- [01 /2]
- [02 /4]
- [03 /8]
- [04 /16]
- [05 /32]
- [06 /64]
- [07 /128]
- [08 /256]
- [09 /512]
- [10 /1024]
- [11 /2048]
- [12 /4096]
- )
-
-(def: #export (= reference sample)
- {#.doc "Rev(olution) equivalence."}
- (-> Rev Rev Bit)
- ("lux i64 =" reference sample))
-
-(def: #export (< reference sample)
- {#.doc "Rev(olution) less-than."}
- (-> Rev Rev Bit)
- (//nat.< (.nat reference) (.nat sample)))
-
-(def: #export (<= reference sample)
- {#.doc "Rev(olution) less-than or equal."}
- (-> Rev Rev Bit)
- (if (//nat.< (.nat reference) (.nat sample))
- true
- ("lux i64 =" reference sample)))
-
-(def: #export (> reference sample)
- {#.doc "Rev(olution) greater-than."}
- (-> Rev Rev Bit)
- (..< sample reference))
-
-(def: #export (>= reference sample)
- {#.doc "Rev(olution) greater-than or equal."}
- (-> Rev Rev Bit)
- (if (..< sample reference)
- true
- ("lux i64 =" reference sample)))
-
-(template [<name> <test> <doc>]
- [(def: #export (<name> left right)
- {#.doc <doc>}
- (-> Rev Rev Rev)
- (if (<test> right left)
- left
- right))]
-
- [min ..< "Rev(olution) minimum."]
- [max ..> "Rev(olution) maximum."]
- )
-
-(template [<name> <op> <doc>]
- [(def: #export (<name> param subject)
- {#.doc <doc>}
- (-> Rev Rev Rev)
- (<op> param subject))]
-
- [+ "lux i64 +" "Rev(olution) addition."]
- [- "lux i64 -" "Rev(olution) substraction."]
- )
-
-(def: high
- (-> (I64 Any) I64)
- (|>> ("lux i64 right-shift" 32)))
-
-(def: low
- (-> (I64 Any) I64)
- (let [mask (|> 1 ("lux i64 left-shift" 32) ("lux i64 -" 1))]
- (|>> ("lux i64 and" mask))))
-
-(def: #export (* param subject)
- {#.doc "Rev(olution) multiplication."}
- (-> Rev Rev Rev)
- (let [subjectH (..high subject)
- subjectL (..low subject)
- paramH (..high param)
- paramL (..low param)
- bottom (|> subjectL
- ("lux i64 *" paramL)
- ("lux i64 right-shift" 32))
- middle ("lux i64 +"
- ("lux i64 *" paramL subjectH)
- ("lux i64 *" paramH subjectL))
- top ("lux i64 *" subjectH paramH)]
- (|> bottom
- ("lux i64 +" middle)
- ..high
- ("lux i64 +" top))))
-
-(def: even_one (//i64.rotate_right 1 1))
-(def: odd_one (dec 0))
-
-(def: (even_reciprocal numerator)
- (-> Nat Nat)
- (//nat./ (//i64.right_shift 1 numerator)
- ..even_one))
-
-(def: (odd_reciprocal numerator)
- (-> Nat Nat)
- (//nat./ numerator ..odd_one))
-
-(with_expansions [<least_significant_bit> 1]
- (def: #export (reciprocal numerator)
- {#.doc "Rev(olution) reciprocal of a Nat(ural)."}
- (-> Nat Rev)
- (.rev (case (: Nat ("lux i64 and" <least_significant_bit> numerator))
- 0 (..even_reciprocal numerator)
- _ (..odd_reciprocal numerator))))
-
- (def: #export (/ param subject)
- {#.doc "Rev(olution) division."}
- (-> Rev Rev Rev)
- (if ("lux i64 =" +0 param)
- (error! "Cannot divide Rev by zero!")
- (let [reciprocal (case (: Nat ("lux i64 and" <least_significant_bit> param))
- 0 (..even_reciprocal (.nat param))
- _ (..odd_reciprocal (.nat param)))]
- (.rev (//nat.* reciprocal (.nat subject)))))))
-
-(template [<operator> <name> <output> <output_type> <documentation>]
- [(def: #export (<name> param subject)
- {#.doc <documentation>}
- (-> Rev Rev <output_type>)
- (<output> (<operator> (.nat param) (.nat subject))))]
-
- [//nat.% % .rev Rev "Rev(olution) remainder."]
- [//nat./ ratio |> Nat "Ratio between two rev(olution)s."]
- )
-
-(template [<operator> <name>]
- [(def: #export (<name> scale subject)
- (-> Nat Rev Rev)
- (.rev (<operator> (.nat scale) (.nat subject))))]
-
- [//nat.* up]
- [//nat./ down]
- )
-
-(def: #export (/% param subject)
- (-> Rev Rev [Rev Rev])
- [(../ param subject)
- (..% param subject)])
-
-(def: mantissa
- (-> (I64 Any) Frac)
- (|>> ("lux i64 right-shift" 11)
- "lux i64 f64"))
-
-(def: frac_denominator
- (..mantissa -1))
-
-(def: #export frac
- (-> Rev Frac)
- (|>> ..mantissa ("lux f64 /" ..frac_denominator)))
-
-(implementation: #export equivalence
- (Equivalence Rev)
-
- (def: = ..=))
-
-(implementation: #export hash
- (Hash Rev)
-
- (def: &equivalence ..equivalence)
- (def: hash .nat))
-
-(implementation: #export order
- (Order Rev)
-
- (def: &equivalence ..equivalence)
- (def: < ..<))
-
-(implementation: #export enum
- (Enum Rev)
-
- (def: &order ..order)
- (def: succ inc)
- (def: pred dec))
-
-(implementation: #export interval
- (Interval Rev)
-
- (def: &enum ..enum)
- (def: top (.rev -1))
- (def: bottom (.rev 0)))
-
-(template [<name> <compose> <identity>]
- [(implementation: #export <name>
- (Monoid Rev)
-
- (def: identity (\ interval <identity>))
- (def: compose <compose>))]
-
- [addition ..+ bottom]
- [maximum ..max bottom]
- [minimum ..min top]
- )
-
-(def: (de_prefix input)
- (-> Text Text)
- ("lux text clip" 1 (dec ("lux text size" input)) input))
-
-(template [<struct> <codec> <char_bit_size> <error>]
- [(with_expansions [<error_output> (as_is (#try.Failure ("lux text concat" <error> repr)))]
- (implementation: #export <struct>
- (Codec Text Rev)
-
- (def: (encode value)
- (let [raw_output (\ <codec> encode (.nat value))
- max_num_chars (//nat.+ (//nat./ <char_bit_size> //i64.width)
- (case (//nat.% <char_bit_size> //i64.width)
- 0 0
- _ 1))
- raw_size ("lux text size" raw_output)
- zero_padding (: Text
- (loop [zeroes_left (: Nat (//nat.- raw_size max_num_chars))
- output (: Text "")]
- (if (//nat.= 0 zeroes_left)
- output
- (recur (dec zeroes_left)
- ("lux text concat" "0" output)))))]
- (|> raw_output
- ("lux text concat" zero_padding)
- ("lux text concat" "."))))
-
- (def: (decode repr)
- (let [repr_size ("lux text size" repr)]
- (if (//nat.> 1 repr_size)
- (case ("lux text char" 0 repr)
- (^ (char "."))
- (case (\ <codec> decode (de_prefix repr))
- (#try.Success output)
- (#try.Success (.rev output))
-
- _
- <error_output>)
-
- _
- <error_output>)
- <error_output>)))))]
-
- [binary //nat.binary 1 "Invalid binary syntax: "]
- [octal //nat.octal 3 "Invalid octal syntax: "]
- [hex //nat.hex 4 "Invalid hexadecimal syntax: "]
- )
-
-## The following code allows one to encode/decode Rev numbers as text.
-## This is not a simple algorithm, and it requires subverting the Rev
-## abstraction a bit.
-## It takes into account the fact that Rev numbers are represented by
-## Lux as 64-bit integers.
-## A valid way to model them is as Lux's Nat type.
-## This is a somewhat hackish way to do things, but it allows one to
-## write the encoding/decoding algorithm once, in pure Lux, rather
-## than having to implement it on the compiler for every platform
-## targeted by Lux.
-(type: Digits (Array Nat))
-
-(def: (digits::new _)
- (-> Any Digits)
- (array.new //i64.width))
-
-(def: (digits::get idx digits)
- (-> Nat Digits Nat)
- (|> digits (array.read idx) (maybe.default 0)))
-
-(def: digits::put
- (-> Nat Nat Digits Digits)
- array.write!)
-
-(def: (prepend left right)
- (-> Text Text Text)
- ("lux text concat" left right))
-
-(def: (digits::times_5! idx output)
- (-> Nat Digits Digits)
- (loop [idx idx
- carry 0
- output output]
- (if (//int.>= +0 (.int idx))
- (let [raw (|> (digits::get idx output)
- (//nat.* 5)
- (//nat.+ carry))]
- (recur (dec idx)
- (//nat./ 10 raw)
- (digits::put idx (//nat.% 10 raw) output)))
- output)))
-
-(def: (digits::power power)
- (-> Nat Digits)
- (loop [times power
- output (|> (digits::new [])
- (digits::put power 1))]
- (if (//int.>= +0 (.int times))
- (recur (dec times)
- (digits::times_5! power output))
- output)))
-
-(def: (digits::format digits)
- (-> Digits Text)
- (loop [idx (dec //i64.width)
- all_zeroes? true
- output ""]
- (if (//int.>= +0 (.int idx))
- (let [digit (digits::get idx digits)]
- (if (and (//nat.= 0 digit)
- all_zeroes?)
- (recur (dec idx) true output)
- (recur (dec idx)
- false
- ("lux text concat"
- (\ //nat.decimal encode digit)
- output))))
- (if all_zeroes?
- "0"
- output))))
-
-(def: (digits::+ param subject)
- (-> Digits Digits Digits)
- (loop [idx (dec //i64.width)
- carry 0
- output (digits::new [])]
- (if (//int.>= +0 (.int idx))
- (let [raw ($_ //nat.+
- carry
- (digits::get idx param)
- (digits::get idx subject))]
- (recur (dec idx)
- (//nat./ 10 raw)
- (digits::put idx (//nat.% 10 raw) output)))
- output)))
-
-(def: (text_to_digits input)
- (-> Text (Maybe Digits))
- (let [length ("lux text size" input)]
- (if (//nat.<= //i64.width length)
- (loop [idx 0
- output (digits::new [])]
- (if (//nat.< length idx)
- (case ("lux text index" 0 ("lux text clip" idx 1 input) "0123456789")
- #.None
- #.None
-
- (#.Some digit)
- (recur (inc idx)
- (digits::put idx digit output)))
- (#.Some output)))
- #.None)))
-
-(def: (digits::< param subject)
- (-> Digits Digits Bit)
- (loop [idx 0]
- (and (//nat.< //i64.width idx)
- (let [pd (digits::get idx param)
- sd (digits::get idx subject)]
- (if (//nat.= pd sd)
- (recur (inc idx))
- (//nat.< pd sd))))))
-
-(def: (digits::-!' idx param subject)
- (-> Nat Nat Digits Digits)
- (let [sd (digits::get idx subject)]
- (if (//nat.>= param sd)
- (digits::put idx (//nat.- param sd) subject)
- (let [diff (|> sd
- (//nat.+ 10)
- (//nat.- param))]
- (|> subject
- (digits::put idx diff)
- (digits::-!' (dec idx) 1))))))
-
-(def: (digits::-! param subject)
- (-> Digits Digits Digits)
- (loop [idx (dec //i64.width)
- output subject]
- (if (//int.>= +0 (.int idx))
- (recur (dec idx)
- (digits::-!' idx (digits::get idx param) output))
- output)))
-
-(implementation: #export decimal
- (Codec Text Rev)
-
- (def: (encode input)
- (case (.nat input)
- 0
- ".0"
-
- input
- (let [last_idx (dec //i64.width)]
- (loop [idx last_idx
- digits (digits::new [])]
- (if (//int.>= +0 (.int idx))
- (if (//i64.set? idx input)
- (let [digits' (digits::+ (digits::power (//nat.- idx last_idx))
- digits)]
- (recur (dec idx)
- digits'))
- (recur (dec idx)
- digits))
- ("lux text concat" "." (digits::format digits))
- )))))
-
- (def: (decode input)
- (let [dotted? (case ("lux text index" 0 "." input)
- (#.Some 0)
- true
-
- _
- false)
- within_limits? (//nat.<= (inc //i64.width)
- ("lux text size" input))]
- (if (and dotted? within_limits?)
- (case (text_to_digits (de_prefix input))
- (#.Some digits)
- (loop [digits digits
- idx 0
- output 0]
- (if (//nat.< //i64.width idx)
- (let [power (digits::power idx)]
- (if (digits::< power digits)
- ## Skip power
- (recur digits (inc idx) output)
- (recur (digits::-! power digits)
- (inc idx)
- (//i64.set (//nat.- idx (dec //i64.width)) output))))
- (#try.Success (.rev output))))
-
- #.None
- (#try.Failure ("lux text concat" "Wrong syntax for Rev: " input)))
- (#try.Failure ("lux text concat" "Wrong syntax for Rev: " input))))
- ))
diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux
deleted file mode 100644
index 8c95c63fa..000000000
--- a/stdlib/source/lux/math/random.lux
+++ /dev/null
@@ -1,399 +0,0 @@
-(.module: {#.doc "Pseudo-random number generation (PRNG) algorithms."}
- [lux (#- or and list i64 nat int rev char)
- [abstract
- [hash (#+ Hash)]
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- ["." monad (#+ Monad do)]]
- [data
- ["." text (#+ Char) ("#\." monoid)
- ["." unicode #_
- ["#" set]]]
- [collection
- ["." list ("#\." fold)]
- ["." array (#+ Array)]
- ["." dictionary (#+ Dictionary)]
- ["." queue (#+ Queue)]
- ["." set (#+ Set)]
- ["." stack (#+ Stack)]
- ["." row (#+ Row)]
- [tree
- ["." finger (#+ Tree)]]]]
- [math
- [number (#+ hex)
- ["n" nat]
- ["i" int]
- ["f" frac]
- ["r" ratio]
- ["c" complex]
- ["." i64]]]
- ["." time (#+ Time)
- ["." instant (#+ Instant)]
- ["." date (#+ Date)]
- ["." duration (#+ Duration)]
- ["." month (#+ Month)]
- ["." day (#+ Day)]]
- [type
- [refinement (#+ Refiner Refined)]]])
-
-(type: #export #rec PRNG
- {#.doc "An abstract way to represent any PRNG."}
- (-> Any [PRNG I64]))
-
-(type: #export (Random a)
- {#.doc "A producer of random values based on a PRNG."}
- (-> PRNG [PRNG a]))
-
-(implementation: #export functor
- (Functor Random)
-
- (def: (map f fa)
- (function (_ state)
- (let [[state' a] (fa state)]
- [state' (f a)]))))
-
-(implementation: #export apply
- (Apply Random)
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (function (_ state)
- (let [[state' f] (ff state)
- [state'' a] (fa state')]
- [state'' (f a)]))))
-
-(implementation: #export monad
- (Monad Random)
-
- (def: &functor ..functor)
-
- (def: (wrap a)
- (function (_ state)
- [state a]))
-
- (def: (join ffa)
- (function (_ state)
- (let [[state' fa] (ffa state)]
- (fa state')))))
-
-(def: #export (filter pred gen)
- {#.doc "Retries the generator until the output satisfies a predicate."}
- (All [a] (-> (-> a Bit) (Random a) (Random a)))
- (do ..monad
- [sample gen]
- (if (pred sample)
- (wrap sample)
- (filter pred gen))))
-
-(def: #export (one check random)
- (All [a b]
- (-> (-> a (Maybe b)) (Random a) (Random b)))
- (do ..monad
- [sample random]
- (case (check sample)
- (#.Some output)
- (wrap output)
-
- #.None
- (one check random))))
-
-(def: #export (refine refiner gen)
- {#.doc "Retries the generator until the output can be refined."}
- (All [t r] (-> (Refiner t r) (Random t) (Random (Refined t r))))
- (do ..monad
- [sample gen]
- (case (refiner sample)
- (#.Some refined)
- (wrap refined)
-
- #.None
- (refine refiner gen))))
-
-(def: #export bit
- (Random Bit)
- (function (_ prng)
- (let [[prng output] (prng [])]
- [prng (|> output (i64.and 1) (n.= 1))])))
-
-(def: #export i64
- (Random I64)
- (function (_ prng)
- (let [[prng left] (prng [])
- [prng right] (prng [])]
- [prng (|> left
- (i64.left_shift 32)
- ("lux i64 +" right))])))
-
-(template [<name> <type> <cast>]
- [(def: #export <name>
- (Random <type>)
- (\ ..monad map <cast> ..i64))]
-
- [nat Nat .nat]
- [int Int .int]
- [rev Rev .rev]
- )
-
-(def: #export frac
- (Random Frac)
- (\ ..monad map (|>> .i64 f.from_bits) ..nat))
-
-(def: #export safe_frac
- (Random Frac)
- (let [mantissa_range (.int (i64.left_shift 53 1))
- mantissa_max (i.frac (dec mantissa_range))]
- (\ ..monad map
- (|>> (i.% mantissa_range)
- i.frac
- (f./ mantissa_max))
- ..int)))
-
-(def: #export (char set)
- (-> unicode.Set (Random Char))
- (let [[start end] (unicode.range set)
- size (n.- start end)
- in_range (: (-> Char Char)
- (|>> (n.% size) (n.+ start)))]
- (|> ..nat
- (\ ..monad map in_range)
- (..filter (unicode.member? set)))))
-
-(def: #export (text char_gen size)
- (-> (Random Char) Nat (Random Text))
- (if (n.= 0 size)
- (\ ..monad wrap "")
- (do ..monad
- [x char_gen
- xs (text char_gen (dec size))]
- (wrap (text\compose (text.from_code x) xs)))))
-
-(template [<name> <set>]
- [(def: #export <name>
- (-> Nat (Random Text))
- (..text (..char <set>)))]
-
- [unicode unicode.character]
- [ascii unicode.ascii]
- [ascii/alpha unicode.ascii/alpha]
- [ascii/alpha_num unicode.ascii/alpha_num]
- [ascii/numeric unicode.ascii/numeric]
- [ascii/upper unicode.ascii/upper]
- [ascii/lower unicode.ascii/lower]
- )
-
-(template [<name> <type> <ctor> <gen>]
- [(def: #export <name>
- (Random <type>)
- (do ..monad
- [left <gen>
- right <gen>]
- (wrap (<ctor> left right))))]
-
- [ratio r.Ratio r.ratio ..nat]
- [complex c.Complex c.complex ..safe_frac]
- )
-
-(def: #export (and left right)
- {#.doc "Sequencing combinator."}
- (All [a b] (-> (Random a) (Random b) (Random [a b])))
- (do ..monad
- [=left left
- =right right]
- (wrap [=left =right])))
-
-(def: #export (or left right)
- {#.doc "Heterogeneous alternative combinator."}
- (All [a b] (-> (Random a) (Random b) (Random (| a b))))
- (do {! ..monad}
- [? bit]
- (if ?
- (do !
- [=left left]
- (wrap (0 #0 =left)))
- (do !
- [=right right]
- (wrap (0 #1 =right))))))
-
-(def: #export (either left right)
- {#.doc "Homogeneous alternative combinator."}
- (All [a] (-> (Random a) (Random a) (Random a)))
- (do ..monad
- [? bit]
- (if ?
- left
- right)))
-
-(def: #export (rec gen)
- {#.doc "A combinator for producing recursive random generators."}
- (All [a] (-> (-> (Random a) (Random a)) (Random a)))
- (function (_ state)
- (let [gen' (gen (rec gen))]
- (gen' state))))
-
-(def: #export (maybe value_gen)
- (All [a] (-> (Random a) (Random (Maybe a))))
- (do {! ..monad}
- [some? bit]
- (if some?
- (do !
- [value value_gen]
- (wrap (#.Some value)))
- (wrap #.None))))
-
-(template [<name> <type> <zero> <plus>]
- [(def: #export (<name> size value_gen)
- (All [a] (-> Nat (Random a) (Random (<type> a))))
- (if (n.> 0 size)
- (do ..monad
- [x value_gen
- xs (<name> (dec size) value_gen)]
- (wrap (<plus> x xs)))
- (\ ..monad wrap <zero>)))]
-
- [list List (.list) #.Cons]
- [row Row row.empty row.add]
- )
-
-(template [<name> <type> <ctor>]
- [(def: #export (<name> size value_gen)
- (All [a] (-> Nat (Random a) (Random (<type> a))))
- (do ..monad
- [values (list size value_gen)]
- (wrap (|> values <ctor>))))]
-
- [array Array array.from_list]
- [queue Queue queue.from_list]
- [stack Stack (list\fold stack.push stack.empty)]
- )
-
-(def: #export (set Hash<a> size value_gen)
- (All [a] (-> (Hash a) Nat (Random a) (Random (Set a))))
- (if (n.> 0 size)
- (do {! ..monad}
- [xs (set Hash<a> (dec size) value_gen)]
- (loop [_ []]
- (do !
- [x value_gen
- #let [xs+ (set.add x xs)]]
- (if (n.= size (set.size xs+))
- (wrap xs+)
- (recur [])))))
- (\ ..monad wrap (set.new Hash<a>))))
-
-(def: #export (dictionary Hash<a> size key_gen value_gen)
- (All [k v] (-> (Hash k) Nat (Random k) (Random v) (Random (Dictionary k v))))
- (if (n.> 0 size)
- (do {! ..monad}
- [kv (dictionary Hash<a> (dec size) key_gen value_gen)]
- (loop [_ []]
- (do !
- [k key_gen
- v value_gen
- #let [kv+ (dictionary.put k v kv)]]
- (if (n.= size (dictionary.size kv+))
- (wrap kv+)
- (recur [])))))
- (\ ..monad wrap (dictionary.new Hash<a>))))
-
-(def: #export instant
- (Random Instant)
- (\ ..monad map instant.from_millis ..int))
-
-(def: #export date
- (Random Date)
- (\ ..monad map instant.date ..instant))
-
-(def: #export time
- (Random Time)
- (\ ..monad map instant.time ..instant))
-
-(def: #export duration
- (Random Duration)
- (\ ..monad map duration.from_millis ..int))
-
-(def: #export month
- (Random Month)
- (let [(^open "\.") ..monad]
- (..either (..either (..either (\wrap #month.January)
- (..either (\wrap #month.February)
- (\wrap #month.March)))
- (..either (\wrap #month.April)
- (..either (\wrap #month.May)
- (\wrap #month.June))))
- (..either (..either (\wrap #month.July)
- (..either (\wrap #month.August)
- (\wrap #month.September)))
- (..either (\wrap #month.October)
- (..either (\wrap #month.November)
- (\wrap #month.December)))))))
-
-(def: #export day
- (Random Day)
- (let [(^open "\.") ..monad]
- (..either (..either (\wrap #day.Sunday)
- (..either (\wrap #day.Monday)
- (\wrap #day.Tuesday)))
- (..either (..either (\wrap #day.Wednesday)
- (\wrap #day.Thursday))
- (..either (\wrap #day.Friday)
- (\wrap #day.Saturday))))))
-
-(def: #export (run prng calc)
- (All [a] (-> PRNG (Random a) [PRNG a]))
- (calc prng))
-
-(def: #export (prng update return)
- (All [a] (-> (-> a a) (-> a I64) (-> a PRNG)))
- (function (recur state)
- (function (_ _)
- [(recur (update state))
- (return state)])))
-
-(def: #export (pcg32 [increase seed])
- {#.doc (doc "An implementation of the PCG32 algorithm."
- "For more information, please see: http://www.pcg-random.org/")}
- (-> [(I64 Any) (I64 Any)] PRNG)
- (let [magic 6364136223846793005]
- (function (_ _)
- [(|> seed .nat (n.* magic) ("lux i64 +" increase) [increase] pcg32)
- (let [rot (|> seed .i64 (i64.right_shift 59))]
- (|> seed
- (i64.right_shift 18)
- (i64.xor seed)
- (i64.right_shift 27)
- (i64.rotate_right rot)
- .i64))])))
-
-(def: #export (xoroshiro_128+ [s0 s1])
- {#.doc (doc "An implementation of the Xoroshiro128+ algorithm."
- "For more information, please see: http://xoroshiro.di.unimi.it/")}
- (-> [(I64 Any) (I64 Any)] PRNG)
- (function (_ _)
- [(let [s01 (i64.xor s0 s1)]
- (xoroshiro_128+ [(|> s0
- (i64.rotate_left 55)
- (i64.xor s01)
- (i64.xor (i64.left_shift 14 s01)))
- (i64.rotate_left 36 s01)]))
- ("lux i64 +" s0 s1)]))
-
-## https://en.wikipedia.org/wiki/Xorshift#Initialization
-## http://xorshift.di.unimi.it/splitmix64.c
-(def: #export split_mix_64
- {#.doc (doc "An implementation of the SplitMix64 algorithm.")}
- (-> Nat PRNG)
- (let [twist (: (-> Nat Nat Nat)
- (function (_ shift value)
- (i64.xor (i64.right_shift shift value)
- value)))
- mix n.*]
- (..prng (n.+ (hex "9E,37,79,B9,7F,4A,7C,15"))
- (|>> (twist 30)
- (mix (hex "BF,58,47,6D,1C,E4,E5,B9"))
-
- (twist 27)
- (mix (hex "94,D0,49,BB,13,31,11,EB"))
-
- (twist 31)
- .i64))))
diff --git a/stdlib/source/lux/meta.lux b/stdlib/source/lux/meta.lux
deleted file mode 100644
index a6877765b..000000000
--- a/stdlib/source/lux/meta.lux
+++ /dev/null
@@ -1,567 +0,0 @@
-(.module: {#.doc "Functions for extracting information from the state of the compiler."}
- [lux #*
- [abstract
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- ["." monad (#+ Monad do)]]
- [control
- ["." try (#+ Try)]]
- [data
- ["." product]
- ["." maybe]
- ["." text ("#\." monoid equivalence)]
- ["." name ("#\." codec equivalence)]
- [collection
- ["." list ("#\." monoid monad)]
- [dictionary
- ["." plist]]]]
- [macro
- ["." code]]
- [math
- [number
- ["n" nat]
- ["i" int]]]]
- [/
- ["." location]])
-
-## (type: (Meta a)
-## (-> Lux (Try [Lux a])))
-
-(implementation: #export functor
- (Functor Meta)
-
- (def: (map f fa)
- (function (_ compiler)
- (case (fa compiler)
- (#try.Failure msg)
- (#try.Failure msg)
-
- (#try.Success [compiler' a])
- (#try.Success [compiler' (f a)])))))
-
-(implementation: #export apply
- (Apply Meta)
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (function (_ compiler)
- (case (ff compiler)
- (#try.Success [compiler' f])
- (case (fa compiler')
- (#try.Success [compiler'' a])
- (#try.Success [compiler'' (f a)])
-
- (#try.Failure msg)
- (#try.Failure msg))
-
- (#try.Failure msg)
- (#try.Failure msg)))))
-
-(implementation: #export monad
- (Monad Meta)
-
- (def: &functor ..functor)
-
- (def: (wrap x)
- (function (_ compiler)
- (#try.Success [compiler x])))
-
- (def: (join mma)
- (function (_ compiler)
- (case (mma compiler)
- (#try.Failure msg)
- (#try.Failure msg)
-
- (#try.Success [compiler' ma])
- (ma compiler')))))
-
-(def: #export (run' compiler action)
- (All [a] (-> Lux (Meta a) (Try [Lux a])))
- (action compiler))
-
-(def: #export (run compiler action)
- (All [a] (-> Lux (Meta a) (Try a)))
- (case (action compiler)
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success [_ output])
- (#try.Success output)))
-
-(def: #export (either left right)
- {#.doc "Pick whichever computation succeeds."}
- (All [a] (-> (Meta a) (Meta a) (Meta a)))
- (function (_ compiler)
- (case (left compiler)
- (#try.Failure error)
- (right compiler)
-
- (#try.Success [compiler' output])
- (#try.Success [compiler' output]))))
-
-(def: #export (assert message test)
- {#.doc "Fails with the given message if the test is #0."}
- (-> Text Bit (Meta Any))
- (function (_ compiler)
- (if test
- (#try.Success [compiler []])
- (#try.Failure message))))
-
-(def: #export (fail error)
- {#.doc "Fails with the given error message."}
- (All [a]
- (-> Text (Meta a)))
- (function (_ state)
- (#try.Failure (location.with (get@ #.location state) error))))
-
-(def: #export (find_module name)
- (-> Text (Meta Module))
- (function (_ compiler)
- (case (plist.get name (get@ #.modules compiler))
- (#.Some module)
- (#try.Success [compiler module])
-
- _
- (#try.Failure ($_ text\compose "Unknown module: " name)))))
-
-(def: #export current_module_name
- (Meta Text)
- (function (_ compiler)
- (case (get@ #.current_module compiler)
- (#.Some current_module)
- (#try.Success [compiler current_module])
-
- _
- (#try.Failure "No current module."))))
-
-(def: #export current_module
- (Meta Module)
- (let [(^open "\.") ..monad]
- (|> ..current_module_name
- (\map ..find_module)
- \join)))
-
-(def: (macro_type? type)
- (-> Type Bit)
- (case type
- (#.Named ["lux" "Macro"] (#.Primitive "#Macro" #.Nil))
- true
-
- _
- false))
-
-(def: #export (normalize name)
- {#.doc (doc "If given a name without a module prefix, gives it the current module's name as prefix."
- "Otherwise, returns the name as-is.")}
- (-> Name (Meta Name))
- (case name
- ["" name]
- (do ..monad
- [module_name ..current_module_name]
- (wrap [module_name name]))
-
- _
- (\ ..monad wrap name)))
-
-(def: (find_macro' modules this_module module name)
- (-> (List [Text Module]) Text Text Text
- (Maybe Macro))
- (do maybe.monad
- [$module (plist.get module modules)
- definition (: (Maybe Global)
- (|> (: Module $module)
- (get@ #.definitions)
- (plist.get name)))]
- (case definition
- (#.Alias [r_module r_name])
- (find_macro' modules this_module r_module r_name)
-
- (#.Definition [exported? def_type def_anns def_value])
- (if (macro_type? def_type)
- (#.Some (:as Macro def_value))
- #.None))))
-
-(def: #export (find_macro full_name)
- (-> Name (Meta (Maybe Macro)))
- (do ..monad
- [[module name] (normalize full_name)]
- (: (Meta (Maybe Macro))
- (function (_ compiler)
- (let [macro (case (..current_module_name compiler)
- (#try.Failure error)
- #.None
-
- (#try.Success [_ this_module])
- (find_macro' (get@ #.modules compiler) this_module module name))]
- (#try.Success [compiler macro]))))))
-
-(def: #export count
- (Meta Nat)
- (function (_ compiler)
- (#try.Success [(update@ #.seed inc compiler)
- (get@ #.seed compiler)])))
-
-(def: #export (module_exists? module)
- (-> Text (Meta Bit))
- (function (_ compiler)
- (#try.Success [compiler (case (plist.get module (get@ #.modules compiler))
- (#.Some _)
- #1
-
- #.None
- #0)])))
-
-(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_type_var idx bindings)
- (-> Nat (List [Nat (Maybe Type)]) (Maybe Type))
- (case bindings
- #.Nil
- #.None
-
- (#.Cons [var bound] bindings')
- (if (n.= idx var)
- bound
- (find_type_var idx bindings'))))
-
-(def: (clean_type type)
- (-> Type (Meta Type))
- (case type
- (#.Var var)
- (function (_ compiler)
- (case (|> compiler
- (get@ [#.type_context #.var_bindings])
- (find_type_var var))
- (^or #.None (#.Some (#.Var _)))
- (#try.Success [compiler type])
-
- (#.Some type')
- (#try.Success [compiler type'])))
-
- _
- (\ ..monad wrap type)))
-
-(def: #export (find_var_type name)
- {#.doc "Looks-up the type of a local variable somewhere in the environment."}
- (-> Text (Meta Type))
- (function (_ compiler)
- (let [test (: (-> [Text [Type Any]] Bit)
- (|>> product.left (text\= name)))]
- (case (do maybe.monad
- [scope (list.find (function (_ env)
- (or (list.any? test (: (List [Text [Type Any]])
- (get@ [#.locals #.mappings] env)))
- (list.any? test (: (List [Text [Type Any]])
- (get@ [#.captured #.mappings] env)))))
- (get@ #.scopes compiler))
- [_ [type _]] (try_both (list.find test)
- (: (List [Text [Type Any]])
- (get@ [#.locals #.mappings] scope))
- (: (List [Text [Type Any]])
- (get@ [#.captured #.mappings] scope)))]
- (wrap type))
- (#.Some var_type)
- ((clean_type var_type) compiler)
-
- #.None
- (#try.Failure ($_ text\compose "Unknown variable: " name))))))
-
-(def: #export (find_def name)
- {#.doc "Looks-up a definition's whole data in the available modules (including the current one)."}
- (-> Name (Meta Global))
- (do ..monad
- [name (normalize name)
- #let [[normal_module normal_short] name]]
- (function (_ compiler)
- (case (: (Maybe Global)
- (do maybe.monad
- [(^slots [#.definitions]) (|> compiler
- (get@ #.modules)
- (plist.get normal_module))]
- (plist.get normal_short definitions)))
- (#.Some definition)
- (#try.Success [compiler definition])
-
- _
- (let [current_module (|> compiler (get@ #.current_module) (maybe.default "???"))
- separator ($_ text\compose text.new_line " ")]
- (#try.Failure ($_ text\compose
- "Unknown definition: " (name\encode name) text.new_line
- " Current module: " current_module text.new_line
- (case (plist.get current_module (get@ #.modules compiler))
- (#.Some this_module)
- (let [candidates (|> compiler
- (get@ #.modules)
- (list\map (function (_ [module_name module])
- (|> module
- (get@ #.definitions)
- (list.all (function (_ [def_name global])
- (case global
- (#.Definition [exported? _ _ _])
- (if (and exported?
- (text\= normal_short def_name))
- (#.Some (name\encode [module_name def_name]))
- #.None)
-
- (#.Alias _)
- #.None))))))
- list.concat
- (text.join_with separator))
- imports (|> this_module
- (get@ #.imports)
- (text.join_with separator))
- aliases (|> this_module
- (get@ #.module_aliases)
- (list\map (function (_ [alias real]) ($_ text\compose alias " => " real)))
- (text.join_with separator))]
- ($_ text\compose
- " Candidates: " candidates text.new_line
- " Imports: " imports text.new_line
- " Aliases: " aliases text.new_line))
-
- _
- "")
- " All known modules: " (|> compiler (get@ #.modules) (list\map product.left) (text.join_with separator)) text.new_line)))))))
-
-(def: #export (find_export name)
- {#.doc "Looks-up a definition's type in the available modules (including the current one)."}
- (-> Name (Meta Definition))
- (do ..monad
- [definition (..find_def name)]
- (case definition
- (#.Left de_aliased)
- (fail ($_ text\compose
- "Aliases are not considered exports: "
- (name\encode name)))
-
- (#.Right definition)
- (let [[exported? def_type def_data def_value] definition]
- (if exported?
- (wrap definition)
- (fail ($_ text\compose "Definition is not an export: " (name\encode name))))))))
-
-(def: #export (find_def_type name)
- {#.doc "Looks-up a definition's type in the available modules (including the current one)."}
- (-> Name (Meta Type))
- (do ..monad
- [definition (find_def name)]
- (case definition
- (#.Left de_aliased)
- (find_def_type de_aliased)
-
- (#.Right [exported? def_type def_data def_value])
- (clean_type def_type))))
-
-(def: #export (find_type name)
- {#.doc "Looks-up the type of either a local variable or a definition."}
- (-> Name (Meta Type))
- (do ..monad
- [#let [[_ _name] name]]
- (case name
- ["" _name]
- (either (find_var_type _name)
- (find_def_type name))
-
- _
- (find_def_type name))))
-
-(def: #export (find_type_def name)
- {#.doc "Finds the value of a type definition (such as Int, Any or Lux)."}
- (-> Name (Meta Type))
- (do ..monad
- [definition (find_def name)]
- (case definition
- (#.Left de_aliased)
- (find_type_def de_aliased)
-
- (#.Right [exported? def_type def_data def_value])
- (let [type_to_code ("lux in-module" "lux" .type_to_code)]
- (if (or (is? .Type def_type)
- (\ code.equivalence =
- (type_to_code .Type)
- (type_to_code def_type)))
- (wrap (:as Type def_value))
- (..fail ($_ text\compose "Definition is not a type: " (name\encode name))))))))
-
-(def: #export (globals module)
- {#.doc "The entire list of globals in a module (including the non-exported/private ones)."}
- (-> Text (Meta (List [Text Global])))
- (function (_ compiler)
- (case (plist.get module (get@ #.modules compiler))
- #.None
- (#try.Failure ($_ text\compose "Unknown module: " module))
-
- (#.Some module)
- (#try.Success [compiler (get@ #.definitions module)]))))
-
-(def: #export (definitions module)
- {#.doc "The entire list of definitions in a module (including the non-exported/private ones)."}
- (-> Text (Meta (List [Text Definition])))
- (\ ..monad map
- (list.all (function (_ [name global])
- (case global
- (#.Left de_aliased)
- #.None
-
- (#.Right definition)
- (#.Some [name definition]))))
- (..globals module)))
-
-(def: #export (exports module_name)
- {#.doc "All the exported definitions in a module."}
- (-> Text (Meta (List [Text Definition])))
- (do ..monad
- [constants (..definitions module_name)]
- (wrap (do list.monad
- [[name [exported? def_type def_data def_value]] constants]
- (if exported?
- (wrap [name [exported? def_type def_data def_value]])
- (list))))))
-
-(def: #export modules
- {#.doc "All the available modules (including the current one)."}
- (Meta (List [Text Module]))
- (function (_ compiler)
- (|> compiler
- (get@ #.modules)
- [compiler]
- #try.Success)))
-
-(def: #export (tags_of type_name)
- {#.doc "All the tags associated with a type definition."}
- (-> Name (Meta (Maybe (List Name))))
- (do ..monad
- [#let [[module name] type_name]
- module (find_module module)]
- (case (plist.get name (get@ #.types module))
- (#.Some [tags _])
- (wrap (#.Some tags))
-
- _
- (wrap #.None))))
-
-(def: #export location
- {#.doc "The location of the current expression being analyzed."}
- (Meta Location)
- (function (_ compiler)
- (#try.Success [compiler (get@ #.location compiler)])))
-
-(def: #export expected_type
- {#.doc "The expected type of the current expression being analyzed."}
- (Meta Type)
- (function (_ compiler)
- (case (get@ #.expected compiler)
- (#.Some type)
- (#try.Success [compiler type])
-
- #.None
- (#try.Failure "Not expecting any type."))))
-
-(def: #export (imported_modules module_name)
- {#.doc "All the modules imported by a specified module."}
- (-> Text (Meta (List Text)))
- (do ..monad
- [(^slots [#.imports]) (..find_module module_name)]
- (wrap imports)))
-
-(def: #export (imported_by? import module)
- (-> Text Text (Meta Bit))
- (do ..monad
- [(^slots [#.imports]) (..find_module module)]
- (wrap (list.any? (text\= import) imports))))
-
-(def: #export (imported? import)
- (-> Text (Meta Bit))
- (\ ..functor map
- (|>> (get@ #.imports) (list.any? (text\= import)))
- ..current_module))
-
-(def: #export (resolve_tag tag)
- {#.doc "Given a tag, finds out what is its index, its related tag-list and its associated type."}
- (-> Name (Meta [Nat (List Name) Type]))
- (do ..monad
- [#let [[module name] tag]
- =module (..find_module module)
- this_module_name ..current_module_name
- imported! (..imported? module)]
- (case (plist.get name (get@ #.tags =module))
- (#.Some [idx tag_list exported? type])
- (if (or (text\= this_module_name module)
- (and imported! exported?))
- (wrap [idx tag_list type])
- (..fail ($_ text\compose "Cannot access tag: " (name\encode tag) " from module " this_module_name)))
-
- _
- (..fail ($_ text\compose
- "Unknown tag: " (name\encode tag) text.new_line
- " Known tags: " (|> =module
- (get@ #.tags)
- (list\map (|>> product.left [module] name\encode (text.prefix text.new_line)))
- (text.join_with ""))
- )))))
-
-(def: #export (tag_lists module)
- {#.doc "All the tag-lists defined in a module, with their associated types."}
- (-> Text (Meta (List [(List Name) Type])))
- (do ..monad
- [=module (..find_module module)
- this_module_name ..current_module_name]
- (wrap (|> (get@ #.types =module)
- (list.filter (function (_ [type_name [tag_list exported? type]])
- (or exported?
- (text\= this_module_name module))))
- (list\map (function (_ [type_name [tag_list exported? type]])
- [tag_list type]))))))
-
-(def: #export locals
- {#.doc "All the local variables currently in scope, separated in different scopes."}
- (Meta (List (List [Text Type])))
- (function (_ compiler)
- (case (list.inits (get@ #.scopes compiler))
- #.None
- (#try.Failure "No local environment")
-
- (#.Some scopes)
- (#try.Success [compiler
- (list\map (|>> (get@ [#.locals #.mappings])
- (list\map (function (_ [name [type _]])
- [name type])))
- scopes)]))))
-
-(def: #export (un_alias def_name)
- {#.doc "Given an aliased definition's name, returns the original definition being referenced."}
- (-> Name (Meta Name))
- (do ..monad
- [constant (..find_def def_name)]
- (wrap (case constant
- (#.Left real_def_name)
- real_def_name
-
- (#.Right _)
- def_name))))
-
-(def: #export get_compiler
- {#.doc "Obtains the current state of the compiler."}
- (Meta Lux)
- (function (_ compiler)
- (#try.Success [compiler compiler])))
-
-(def: #export type_context
- (Meta Type_Context)
- (function (_ compiler)
- (#try.Success [compiler (get@ #.type_context compiler)])))
-
-(def: #export (lift result)
- (All [a] (-> (Try a) (Meta a)))
- (case result
- (#try.Success output)
- (\ ..monad wrap output)
-
- (#try.Failure error)
- (..fail error)))
diff --git a/stdlib/source/lux/meta/annotation.lux b/stdlib/source/lux/meta/annotation.lux
deleted file mode 100644
index 648119177..000000000
--- a/stdlib/source/lux/meta/annotation.lux
+++ /dev/null
@@ -1,94 +0,0 @@
-(.module:
- [lux (#- nat int rev)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." maybe]
- ["." name ("#\." equivalence)]]])
-
-(type: #export Annotation
- Code)
-
-(def: #export (value tag ann)
- (-> Name Annotation (Maybe Code))
- (case ann
- [_ (#.Record ann)]
- (loop [ann ann]
- (case ann
- (#.Cons [key value] ann')
- (case key
- [_ (#.Tag tag')]
- (if (name\= tag tag')
- (#.Some value)
- (recur ann'))
-
- _
- (recur ann'))
-
- #.Nil
- #.None))
-
- _
- #.None))
-
-(template [<name> <tag> <type>]
- [(def: #export (<name> tag ann)
- (-> Name Annotation (Maybe <type>))
- (case (..value tag ann)
- (#.Some [_ (<tag> value)])
- (#.Some value)
-
- _
- #.None))]
-
- [bit #.Bit Bit]
- [nat #.Nat Nat]
- [int #.Int Int]
- [rev #.Rev Rev]
- [frac #.Frac Frac]
- [text #.Text Text]
- [identifier #.Identifier Name]
- [tag #.Tag Name]
- [form #.Form (List Code)]
- [tuple #.Tuple (List Code)]
- [record #.Record (List [Code Code])]
- )
-
-(def: #export documentation
- (-> Annotation (Maybe Text))
- (..text (name_of #.doc)))
-
-(def: #export (flagged? flag)
- (-> Name Annotation Bit)
- (|>> (..bit flag) (maybe.default false)))
-
-(template [<name> <tag>]
- [(def: #export <name>
- (-> Annotation Bit)
- (..flagged? (name_of <tag>)))]
-
- [implementation? #.implementation?]
- [recursive_type? #.type-rec?]
- [signature? #.sig?]
- )
-
-(def: (parse_text input)
- (-> Code (Maybe Text))
- (case input
- [_ (#.Text actual_value)]
- (#.Some actual_value)
-
- _
- #.None))
-
-(template [<name> <tag>]
- [(def: #export (<name> ann)
- (-> Annotation (List Text))
- (maybe.default (list)
- (do {! maybe.monad}
- [args (..tuple (name_of <tag>) ann)]
- (monad.map ! ..parse_text args))))]
-
- [function_arguments #.func-args]
- [type_arguments #.type-args]
- )
diff --git a/stdlib/source/lux/meta/location.lux b/stdlib/source/lux/meta/location.lux
deleted file mode 100644
index 5e8453c50..000000000
--- a/stdlib/source/lux/meta/location.lux
+++ /dev/null
@@ -1,48 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]])
-
-(implementation: #export equivalence
- (Equivalence Location)
-
- (def: (= reference subject)
- (and ("lux text =" (get@ #.module reference) (get@ #.module subject))
- ("lux i64 =" (get@ #.line reference) (get@ #.line subject))
- ("lux i64 =" (get@ #.column reference) (get@ #.column subject)))))
-
-(def: #export dummy
- Location
- {#.module ""
- #.line 0
- #.column 0})
-
-(macro: #export (here tokens compiler)
- (case tokens
- #.Nil
- (let [location (get@ #.location compiler)]
- (#.Right [compiler
- (list (` [(~ [..dummy (#.Text (get@ #.module location))])
- (~ [..dummy (#.Nat (get@ #.line location))])
- (~ [..dummy (#.Nat (get@ #.column location))])]))]))
-
- _
- (#.Left (("lux in-module" "lux" wrong_syntax_error) (name_of ..here)))))
-
-(def: #export (format value)
- (-> Location Text)
- (let [separator ","
- [file line column] value]
- ($_ "lux text concat"
- "@"
- (("lux in-module" "lux" .text\encode) file) separator
- (("lux in-module" "lux" .nat\encode) line) separator
- (("lux in-module" "lux" .nat\encode) column))))
-
-(def: \n
- ("lux i64 char" +10))
-
-(def: #export (with location error)
- (-> Location Text Text)
- ($_ "lux text concat" (..format location) \n
- error))
diff --git a/stdlib/source/lux/program.lux b/stdlib/source/lux/program.lux
deleted file mode 100644
index 475bd7322..000000000
--- a/stdlib/source/lux/program.lux
+++ /dev/null
@@ -1,82 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io]
- [concurrency
- ["." thread]]
- ["<>" parser
- ["<.>" code]
- ["<.>" cli]]]
- [data
- ["." text]
- [collection
- ["." list ("#\." monad)]]]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]]])
-
-(type: Arguments
- (#Raw Text)
- (#Parsed (List [Code Code])))
-
-(def: arguments^
- (<code>.Parser Arguments)
- (<>.or <code>.local_identifier
- (<code>.tuple (<>.some (<>.either (do <>.monad
- [name <code>.local_identifier]
- (wrap [(code.identifier ["" name]) (` (~! <cli>.any))]))
- (<code>.record (<>.and <code>.any <code>.any)))))))
-
-(syntax: #export (program:
- {args ..arguments^}
- 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/control/parser/cli module."
- (program: all_args
- (do io.monad
- [foo init_program
- bar (do_something all_args)]
- (wrap [])))
-
- (program: [name]
- (io (log! (\ text.monoid compose "Hello, " name))))
-
- (program: [{config configuration_parser}]
- (do io.monad
- [data (init_program config)]
- (do_something data))))}
- (with_gensyms [g!program g!args g!_ g!output g!message]
- (let [initialization+event_loop
- (` ((~! do) (~! io.monad)
- [(~ g!output) (~ body)
- (~+ (for {@.old (list)
- @.jvm (list)
- @.js (list)
- @.python (list)}
- (list g!_ (` (~! thread.run!)))))]
- ((~' wrap) (~ g!output))))]
- (wrap (list (` ("lux def program"
- (~ (case args
- (#Raw args)
- (` (.function ((~ g!program) (~ (code.identifier ["" args])))
- (~ initialization+event_loop)))
-
- (#Parsed args)
- (` (.function ((~ g!program) (~ g!args))
- (case ((~! <cli>.run) (: (~! (<cli>.Parser (io.IO .Any)))
- ((~! do) (~! <>.monad)
- [(~+ (|> args
- (list\map (function (_ [binding parser])
- (list binding parser)))
- list\join))]
- ((~' wrap) (~ initialization+event_loop))))
- (~ g!args))
- (#.Right (~ g!output))
- (~ g!output)
-
- (#.Left (~ g!message))
- (.error! (~ g!message))))))))))))))
diff --git a/stdlib/source/lux/target.lux b/stdlib/source/lux/target.lux
deleted file mode 100644
index c548e6809..000000000
--- a/stdlib/source/lux/target.lux
+++ /dev/null
@@ -1,25 +0,0 @@
-(.module:
- lux)
-
-(type: #export Target
- Text)
-
-(template [<name> <value>]
- [(def: #export <name>
- Target
- <value>)]
-
- ## TODO: Delete ASAP.
- [old "{old}"]
- ## Available.
- [js "JavaScript"]
- [jvm "JVM"]
- [lua "Lua"]
- [python "Python"]
- [ruby "Ruby"]
- ## Not available yet.
- [common_lisp "Common Lisp"]
- [php "PHP"]
- [r "R"]
- [scheme "Scheme"]
- )
diff --git a/stdlib/source/lux/target/common_lisp.lux b/stdlib/source/lux/target/common_lisp.lux
deleted file mode 100644
index f68d28c28..000000000
--- a/stdlib/source/lux/target/common_lisp.lux
+++ /dev/null
@@ -1,468 +0,0 @@
-(.module:
- [lux (#- Code int if cond or and comment let)
- [control
- [pipe (#+ case> cond> new>)]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." monad fold monoid)]]]
- [macro
- ["." template]]
- [math
- [number
- ["f" frac]]]
- [type
- abstract]])
-
-(def: as_form
- (-> Text Text)
- (text.enclose ["(" ")"]))
-
-(abstract: #export (Code brand)
- Text
-
- (def: #export manual
- (-> Text Code)
- (|>> :abstraction))
-
- (def: #export code
- (-> (Code Any) Text)
- (|>> :representation))
-
- (template [<type> <super>]
- [(with_expansions [<brand> (template.identifier [<type> "'"])]
- (`` (abstract: #export (<brand> brand) Any))
- (`` (type: #export (<type> brand)
- (<super> (<brand> brand)))))]
-
- [Expression Code]
- [Computation Expression]
- [Access Computation]
- [Var Access]
-
- [Input Code]
- )
-
- (template [<type> <super>]
- [(with_expansions [<brand> (template.identifier [<type> "'"])]
- (`` (abstract: #export <brand> Any))
- (`` (type: #export <type> (<super> <brand>))))]
-
- [Label Code]
- [Tag Expression]
- [Literal Expression]
- [Var/1 Var]
- [Var/* Input]
- )
-
- (type: #export Lambda
- {#input Var/*
- #output (Expression Any)})
-
- (def: #export nil
- Literal
- (:abstraction "()"))
-
- (template [<prefix> <name>]
- [(def: #export <name>
- (-> Text Literal)
- (|>> (format <prefix>) :abstraction))]
-
- ["'" symbol]
- [":" keyword])
-
- (def: #export bool
- (-> Bit Literal)
- (|>> (case> #0 ..nil
- #1 (..symbol "t"))))
-
- (def: #export int
- (-> Int Literal)
- (|>> %.int :abstraction))
-
- (def: #export float
- (-> Frac Literal)
- (|>> (cond> [(f.= f.positive_infinity)]
- [(new> "(/ 1.0 0.0)" [])]
-
- [(f.= f.negative_infinity)]
- [(new> "(/ -1.0 0.0)" [])]
-
- [f.not_a_number?]
- [(new> "(/ 0.0 0.0)" [])]
-
- ## else
- [%.frac])
- :abstraction))
-
- (def: #export (double value)
- (-> Frac Literal)
- (:abstraction
- (.cond (f.= f.positive_infinity value)
- "(/ 1.0d0 0.0d0)"
-
- (f.= f.negative_infinity value)
- "(/ -1.0d0 0.0d0)"
-
- (f.not_a_number? value)
- "(/ 0.0d0 0.0d0)"
-
- ## else
- (.let [raw (%.frac value)]
- (.if (text.contains? "E" raw)
- (text.replace_once "E" "d" raw)
- (format raw "d0"))))))
-
- (def: sanitize
- (-> Text Text)
- (`` (|>> (~~ (template [<find> <replace>]
- [(text.replace_all <find> <replace>)]
-
- ["\" "\\"]
- [text.tab "\t"]
- [text.vertical_tab "\v"]
- [text.null "\0"]
- [text.back_space "\b"]
- [text.form_feed "\f"]
- [text.new_line "\n"]
- [text.carriage_return "\r"]
- [text.double_quote (format "\" text.double_quote)]
- ))
- )))
-
- (def: #export string
- (-> Text Literal)
- (|>> ..sanitize
- (text.enclose' text.double_quote)
- :abstraction))
-
- (def: #export var
- (-> Text Var/1)
- (|>> :abstraction))
-
- (def: #export args
- (-> (List Var/1) Var/*)
- (|>> (list\map ..code)
- (text.join_with " ")
- ..as_form
- :abstraction))
-
- (def: #export (args& singles rest)
- (-> (List Var/1) Var/1 Var/*)
- (|> (case singles
- #.Nil
- ""
-
- (#.Cons _)
- (|> singles
- (list\map ..code)
- (text.join_with " ")
- (text.suffix " ")))
- (format "&rest " (:representation rest))
- ..as_form
- :abstraction))
-
- (def: form
- (-> (List (Expression Any)) Expression)
- (|>> (list\map ..code)
- (text.join_with " ")
- ..as_form
- :abstraction))
-
- (def: #export (call/* func)
- (-> (Expression Any) (-> (List (Expression Any)) (Computation Any)))
- (|>> (#.Cons func) ..form))
-
- (template [<name> <function>]
- [(def: #export <name>
- (-> (List (Expression Any)) (Computation Any))
- (..call/* (..var <function>)))]
-
- [vector/* "vector"]
- [list/* "list"]
- )
-
- (def: #export (labels definitions body)
- (-> (List [Var/1 Lambda]) (Expression Any) (Computation Any))
- (..form (list (..var "labels")
- (..form (list\map (function (_ [def_name [def_args def_body]])
- (..form (list def_name (:transmutation def_args) def_body)))
- definitions))
- body)))
-
- (def: #export (destructuring-bind [bindings expression] body)
- (-> [Var/* (Expression Any)] (List (Expression Any)) (Computation Any))
- (..form (list& (..var "destructuring-bind")
- (:transmutation bindings) expression
- body)))
-
- (template [<call> <input_var>+ <input_type>+ <function>+]
- [(`` (def: #export (<call> [(~~ (template.splice <input_var>+))] function)
- (-> [(~~ (template.splice <input_type>+))] (Expression Any) (Computation Any))
- (..call/* function (list (~~ (template.splice <input_var>+))))))
-
- (`` (template [<lux_name> <host_name>]
- [(def: #export (<lux_name> args)
- (-> [(~~ (template.splice <input_type>+))] (Computation Any))
- (<call> args (..var <host_name>)))]
-
- (~~ (template.splice <function>+))))]
-
- [call/0 [] []
- [[get-universal-time/0 "get-universal-time"]
- [make-hash-table/0 "make-hash-table"]]]
- [call/1 [in0] [(Expression Any)]
- [[length/1 "length"]
- [function/1 "function"]
- [copy-seq/1 "copy-seq"]
- [null/1 "null"]
- [error/1 "error"]
- [not/1 "not"]
- [floor/1 "floor"]
- [type-of/1 "type-of"]
- [write-to-string/1 "write-to-string"]
- [read-from-string/1 "read-from-string"]
- [print/1 "print"]
- [reverse/1 "reverse"]
- [sxhash/1 "sxhash"]
- [string-upcase/1 "string-upcase"]
- [string-downcase/1 "string-downcase"]
- [char-int/1 "char-int"]
- [text/1 "text"]
- [hash-table-size/1 "hash-table-size"]
- [hash-table-rehash-size/1 "hash-table-rehash-size"]
- [code-char/1 "code-char"]
- [char-code/1 "char-code"]
- [string/1 "string"]
- [write-line/1 "write-line"]
- [pprint/1 "pprint"]
- [identity/1 "identity"]]]
- [call/2 [in0 in1] [(Expression Any) (Expression Any)]
- [[apply/2 "apply"]
- [append/2 "append"]
- [cons/2 "cons"]
- [char/2 "char"]
- [nth/2 "nth"]
- [nthcdr/2 "nthcdr"]
- [coerce/2 "coerce"]
- [eq/2 "eq"]
- [equal/2 "equal"]
- [string=/2 "string="]
- [=/2 "="]
- [+/2 "+"]
- [*/2 "*"]]]
- [call/3 [in0 in1 in2] [(Expression Any) (Expression Any) (Expression Any)]
- [[subseq/3 "subseq"]
- [map/3 "map"]
- [concatenate/3 "concatenate"]
- [format/3 "format"]]]
- )
-
- (template [<call> <input_type>+ <function>+]
- [(`` (template [<lux_name> <host_name>]
- [(def: #export (<lux_name> args)
- (-> [(~~ (template.splice <input_type>+))] (Access Any))
- (:transmutation (<call> args (..var <host_name>))))]
-
- (~~ (template.splice <function>+))))]
-
- [call/1 [(Expression Any)]
- [[car/1 "car"]
- [cdr/1 "cdr"]
- [cadr/1 "cadr"]
- [cddr/1 "cddr"]]]
- [call/2 [(Expression Any) (Expression Any)]
- [[svref/2 "svref"]
- [elt/2 "elt"]
- [gethash/2 "gethash"]]]
- )
-
- (def: #export (make-hash-table/with_size size)
- (-> (Expression Any) (Computation Any))
- (..call/* (..var "make-hash-table")
- (list (..keyword "size")
- size)))
-
- (def: #export (funcall/+ [func args])
- (-> [(Expression Any) (List (Expression Any))] (Computation Any))
- (..call/* (..var "funcall") (list& func args)))
-
- (def: #export (search/3 [reference space start])
- (-> [(Expression Any) (Expression Any) (Expression Any)] (Computation Any))
- (..call/* (..var "search")
- (list reference
- space
- (..keyword "start2") start)))
-
- (def: #export (concatenate/2|string [left right])
- (-> [(Expression Any) (Expression Any)] (Computation Any))
- (concatenate/3 [(..symbol "string") left right]))
-
- (template [<lux_name> <host_name>]
- [(def: #export (<lux_name> left right)
- (-> (Expression Any) (Expression Any) (Computation Any))
- (..form (list (..var <host_name>) left right)))]
-
- [or "or"]
- [and "and"]
- )
-
- (template [<lux_name> <host_name>]
- [(def: #export (<lux_name> [param subject])
- (-> [(Expression Any) (Expression Any)] (Computation Any))
- (..form (list (..var <host_name>) subject param)))]
-
- [</2 "<"]
- [<=/2 "<="]
- [>/2 ">"]
- [>=/2 ">="]
- [string</2 "string<"]
- [-/2 "-"]
- [//2 "/"]
- [rem/2 "rem"]
- [floor/2 "floor"]
- [mod/2 "mod"]
- [ash/2 "ash"]
- [logand/2 "logand"]
- [logior/2 "logior"]
- [logxor/2 "logxor"]
- )
-
- (def: #export (if test then else)
- (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any))
- (..form (list (..var "if") test then else)))
-
- (def: #export (when test then)
- (-> (Expression Any) (Expression Any) (Computation Any))
- (..form (list (..var "when") test then)))
-
- (def: #export (lambda input body)
- (-> Var/* (Expression Any) Literal)
- (..form (list (..var "lambda") (:transmutation input) body)))
-
- (template [<lux_name> <host_name>]
- [(def: #export (<lux_name> bindings body)
- (-> (List [Var/1 (Expression Any)]) (List (Expression Any)) (Computation Any))
- (..form (list& (..var <host_name>)
- (|> bindings
- (list\map (function (_ [name value])
- (..form (list name value))))
- ..form)
- body)))]
-
- [let "let"]
- [let* "let*"]
- )
-
- (def: #export (defparameter name body)
- (-> Var/1 (Expression Any) (Expression Any))
- (..form (list (..var "defparameter") name body)))
-
- (def: #export (defun name inputs body)
- (-> Var/1 Var/* (Expression Any) (Expression Any))
- (..form (list (..var "defun") name (:transmutation inputs) body)))
-
- (template [<name> <symbol>]
- [(def: #export <name>
- (-> (List (Expression Any)) (Computation Any))
- (|>> (list& (..var <symbol>)) ..form))]
-
- [progn "progn"]
- [tagbody "tagbody"]
- [values/* "values"]
- )
-
- (def: #export (setq name value)
- (-> Var/1 (Expression Any) (Expression Any))
- (..form (list (..var "setq") name value)))
-
- (def: #export (setf access value)
- (-> (Access Any) (Expression Any) (Expression Any))
- (..form (list (..var "setf") access value)))
-
- (type: #export Handler
- {#condition_type (Expression Any)
- #condition Var/1
- #body (Expression Any)})
-
- (def: #export (handler-case handlers body)
- (-> (List Handler) (Expression Any) (Computation Any))
- (..form (list& (..var "handler-case")
- body
- (list\map (function (_ [type condition handler])
- (..form (list type
- (:transmutation (..args (list condition)))
- handler)))
- handlers))))
-
- (template [<name> <prefix>]
- [(def: #export (<name> conditions expression)
- (-> (List Text) (Expression Any) (Expression Any))
- (case conditions
- #.Nil
- expression
-
- (#.Cons single #.Nil)
- (:abstraction
- (format <prefix> single " " (:representation expression)))
-
- _
- (:abstraction
- (format <prefix> (|> conditions (list\map ..symbol)
- (list& (..symbol "or")) ..form
- :representation)
- " " (:representation expression)))))]
-
- [conditional+ "#+"]
- [conditional- "#-"])
-
- (def: #export label
- (-> Text Label)
- (|>> :abstraction))
-
- (def: #export (block name body)
- (-> Label (List (Expression Any)) (Computation Any))
- (..form (list& (..var "block") (:transmutation name) body)))
-
- (def: #export (return-from target value)
- (-> Label (Expression Any) (Computation Any))
- (..form (list (..var "return-from") (:transmutation target) value)))
-
- (def: #export (return value)
- (-> (Expression Any) (Computation Any))
- (..form (list (..var "return") value)))
-
- (def: #export (cond clauses else)
- (-> (List [(Expression Any) (Expression Any)]) (Expression Any) (Computation Any))
- (..form (list& (..var "cond")
- (list\compose (list\map (function (_ [test then])
- (..form (list test then)))
- clauses)
- (list (..form (list (..bool true) else)))))))
-
- (def: #export tag
- (-> Text Tag)
- (|>> :abstraction))
-
- (def: #export go
- (-> Tag (Expression Any))
- (|>> (list (..var "go"))
- ..form))
-
- (def: #export values-list/1
- (-> (Expression Any) (Expression Any))
- (|>> (list (..var "values-list"))
- ..form))
-
- (def: #export (multiple-value-setq bindings values)
- (-> Var/* (Expression Any) (Expression Any))
- (..form (list (..var "multiple-value-setq")
- (:transmutation bindings)
- values)))
- )
-
-(def: #export (while condition body)
- (-> (Expression Any) (Expression Any) (Computation Any))
- (..form (list (..var "loop") (..var "while") condition
- (..var "do") body)))
diff --git a/stdlib/source/lux/target/js.lux b/stdlib/source/lux/target/js.lux
deleted file mode 100644
index f1a7c3e72..000000000
--- a/stdlib/source/lux/target/js.lux
+++ /dev/null
@@ -1,448 +0,0 @@
-(.module:
- [lux (#- Location Code or and function if cond undefined for comment not int try)
- [control
- [pipe (#+ case>)]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [macro
- ["." template]]
- [math
- [number
- ["i" int]
- ["f" frac]]]
- [type
- abstract]])
-
-(def: expression (text.enclose ["(" ")"]))
-(def: element (text.enclose ["[" "]"]))
-
-(def: nest
- (-> Text Text)
- (|>> (format text.new_line)
- (text.replace_all text.new_line (format text.new_line text.tab))))
-
-(abstract: #export (Code brand)
- Text
-
- (def: #export code
- (-> (Code Any) Text)
- (|>> :representation))
-
- (template [<type> <super>+]
- [(with_expansions [<brand> (template.identifier [<type> "'"])]
- (abstract: (<brand> brand) Any)
- (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))]
-
- [Expression [Code]]
- [Computation [Expression' Code]]
- [Location [Computation' Expression' Code]]
- [Statement [Code]]
- )
-
- (template [<type> <super>+]
- [(with_expansions [<brand> (template.identifier [<type> "'"])]
- (abstract: #export <brand> Any)
- (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))]
-
- [Var [Location' Computation' Expression' Code]]
- [Access [Location' Computation' Expression' Code]]
- [Literal [Computation' Expression' Code]]
- [Loop [Statement' Code]]
- [Label [Code]]
- )
-
- (template [<name> <literal>]
- [(def: #export <name> Literal (:abstraction <literal>))]
-
- [null "null"]
- [undefined "undefined"]
- )
-
- (def: #export boolean
- (-> Bit Literal)
- (|>> (case>
- #0 "false"
- #1 "true")
- :abstraction))
-
- (def: #export (number value)
- (-> Frac Literal)
- (:abstraction
- (.cond (f.not_a_number? value)
- "NaN"
-
- (f.= f.positive_infinity value)
- "Infinity"
-
- (f.= f.negative_infinity value)
- "-Infinity"
-
- ## else
- (|> value %.frac ..expression))))
-
- (def: sanitize
- (-> Text Text)
- (`` (|>> (~~ (template [<replace> <find>]
- [(text.replace_all <find> <replace>)]
-
- ["\\" "\"]
- ["\t" text.tab]
- ["\v" text.vertical_tab]
- ["\0" text.null]
- ["\b" text.back_space]
- ["\f" text.form_feed]
- ["\n" text.new_line]
- ["\r" text.carriage_return]
- [(format "\" text.double_quote)
- text.double_quote]
- ))
- )))
-
- (def: #export string
- (-> Text Literal)
- (|>> ..sanitize
- (text.enclose [text.double_quote text.double_quote])
- :abstraction))
-
- (def: argument_separator ", ")
- (def: field_separator ": ")
- (def: statement_suffix ";")
-
- (def: #export array
- (-> (List Expression) Computation)
- (|>> (list\map ..code)
- (text.join_with ..argument_separator)
- ..element
- :abstraction))
-
- (def: #export var
- (-> Text Var)
- (|>> :abstraction))
-
- (def: #export (at index array_or_object)
- (-> Expression Expression Access)
- (:abstraction (format (:representation array_or_object) (..element (:representation index)))))
-
- (def: #export (the field object)
- (-> Text Expression Access)
- (:abstraction (format (:representation object) "." field)))
-
- (def: #export (apply/* function inputs)
- (-> Expression (List Expression) Computation)
- (|> inputs
- (list\map ..code)
- (text.join_with ..argument_separator)
- ..expression
- (format (:representation function))
- :abstraction))
-
- (def: #export (do method inputs object)
- (-> Text (List Expression) Expression Computation)
- (apply/* (..the method object) inputs))
-
- (def: #export object
- (-> (List [Text Expression]) Computation)
- (|>> (list\map (.function (_ [key val])
- (format (:representation (..string key)) ..field_separator (:representation val))))
- (text.join_with ..argument_separator)
- (text.enclose ["{" "}"])
- ..expression
- :abstraction))
-
- (def: #export (, pre post)
- (-> Expression Expression Computation)
- (|> (format (:representation pre) ..argument_separator (:representation post))
- ..expression
- :abstraction))
-
- (def: #export (then pre post)
- (-> Statement Statement Statement)
- (:abstraction (format (:representation pre)
- text.new_line
- (:representation post))))
-
- (def: block
- (-> Statement Text)
- (let [close (format text.new_line "}")]
- (|>> :representation
- ..nest
- (text.enclose ["{"
- close]))))
-
- (def: #export (function! name inputs body)
- (-> Var (List Var) Statement Statement)
- (|> body
- ..block
- (format "function " (:representation name)
- (|> inputs
- (list\map ..code)
- (text.join_with ..argument_separator)
- ..expression)
- " ")
- :abstraction))
-
- (def: #export (function name inputs body)
- (-> Var (List Var) Statement Computation)
- (|> (..function! name inputs body)
- :representation
- ..expression
- :abstraction))
-
- (def: #export (closure inputs body)
- (-> (List Var) Statement Computation)
- (|> body
- ..block
- (format "function"
- (|> inputs
- (list\map ..code)
- (text.join_with ..argument_separator)
- ..expression)
- " ")
- ..expression
- :abstraction))
-
- (template [<name> <op>]
- [(def: #export (<name> param subject)
- (-> Expression Expression Computation)
- (|> (format (:representation subject) " " <op> " " (:representation param))
- ..expression
- :abstraction))]
-
- [= "==="]
- [< "<"]
- [<= "<="]
- [> ">"]
- [>= ">="]
-
- [+ "+"]
- [- "-"]
- [* "*"]
- [/ "/"]
- [% "%"]
-
- [left_shift "<<"]
- [arithmetic_right_shift ">>"]
- [logic_right_shift ">>>"]
-
- [or "||"]
- [and "&&"]
- [bit_xor "^"]
- [bit_or "|"]
- [bit_and "&"]
- )
-
- (template [<name> <prefix>]
- [(def: #export <name>
- (-> Expression Computation)
- (|>> :representation (text.prefix <prefix>) ..expression :abstraction))]
-
- [not "!"]
- [bit_not "~"]
- [negate "-"]
- )
-
- (template [<name> <input> <format>]
- [(def: #export (<name> value)
- {#.doc "A 32-bit integer expression."}
- (-> <input> Computation)
- (:abstraction (..expression (format (<format> value) "|0"))))]
-
- [to_i32 Expression :representation]
- [i32 Int %.int]
- )
-
- (def: #export (int value)
- (-> Int Literal)
- (:abstraction (.if (i.< +0 value)
- (%.int value)
- (%.nat (.nat value)))))
-
- (def: #export (? test then else)
- (-> Expression Expression Expression Computation)
- (|> (format (:representation test)
- " ? " (:representation then)
- " : " (:representation else))
- ..expression
- :abstraction))
-
- (def: #export type_of
- (-> Expression Computation)
- (|>> :representation
- (format "typeof ")
- ..expression
- :abstraction))
-
- (def: #export (new constructor inputs)
- (-> Expression (List Expression) Computation)
- (|> (format "new " (:representation constructor)
- (|> inputs
- (list\map ..code)
- (text.join_with ..argument_separator)
- ..expression))
- ..expression
- :abstraction))
-
- (def: #export statement
- (-> Expression Statement)
- (|>> :representation (text.suffix ..statement_suffix) :abstraction))
-
- (def: #export use_strict
- Statement
- (:abstraction (format text.double_quote "use strict" text.double_quote ..statement_suffix)))
-
- (def: #export (declare name)
- (-> Var Statement)
- (:abstraction (format "var " (:representation name) ..statement_suffix)))
-
- (def: #export (define name value)
- (-> Var Expression Statement)
- (:abstraction (format "var " (:representation name) " = " (:representation value) ..statement_suffix)))
-
- (def: #export (set' name value)
- (-> Location Expression Expression)
- (:abstraction (..expression (format (:representation name) " = " (:representation value)))))
-
- (def: #export (set name value)
- (-> Location Expression Statement)
- (:abstraction (format (:representation name) " = " (:representation value) ..statement_suffix)))
-
- (def: #export (throw message)
- (-> Expression Statement)
- (:abstraction (format "throw " (:representation message) ..statement_suffix)))
-
- (def: #export (return value)
- (-> Expression Statement)
- (:abstraction (format "return " (:representation value) ..statement_suffix)))
-
- (def: #export (delete' value)
- (-> Location Expression)
- (:abstraction (format "delete " (:representation value))))
-
- (def: #export (delete value)
- (-> Location Statement)
- (:abstraction (format (:representation (delete' value)) ..statement_suffix)))
-
- (def: #export (if test then! else!)
- (-> Expression Statement Statement Statement)
- (:abstraction (format "if(" (:representation test) ") "
- (..block then!)
- " else "
- (..block else!))))
-
- (def: #export (when test then!)
- (-> Expression Statement Statement)
- (:abstraction (format "if(" (:representation test) ") "
- (..block then!))))
-
- (def: #export (while test body)
- (-> Expression Statement Loop)
- (:abstraction (format "while(" (:representation test) ") "
- (..block body))))
-
- (def: #export (do_while test body)
- (-> Expression Statement Loop)
- (:abstraction (format "do " (..block body)
- " while(" (:representation test) ")" ..statement_suffix)))
-
- (def: #export (try body [exception catch])
- (-> Statement [Var Statement] Statement)
- (:abstraction (format "try "
- (..block body)
- " catch(" (:representation exception) ") "
- (..block catch))))
-
- (def: #export (for var init condition update iteration)
- (-> Var Expression Expression Expression Statement Loop)
- (:abstraction (format "for(" (:representation (..define var init))
- " " (:representation condition)
- ..statement_suffix " " (:representation update)
- ")"
- (..block iteration))))
-
- (def: #export label
- (-> Text Label)
- (|>> :abstraction))
-
- (def: #export (with_label label loop)
- (-> Label Loop Statement)
- (:abstraction (format (:representation label) ": " (:representation loop))))
-
- (template [<keyword> <0> <1>]
- [(def: #export <0>
- Statement
- (:abstraction (format <keyword> ..statement_suffix)))
-
- (def: #export (<1> label)
- (-> Label Statement)
- (:abstraction (format <keyword> " " (:representation label) ..statement_suffix)))]
-
- ["break" break break_at]
- ["continue" continue continue_at]
- )
-
- (template [<name> <js>]
- [(def: #export <name>
- (-> Location Expression)
- (|>> :representation
- (text.suffix <js>)
- :abstraction))]
-
- [++ "++"]
- [-- "--"]
- )
-
- (def: #export (comment commentary on)
- (All [kind] (-> Text (Code kind) (Code kind)))
- (:abstraction (format "/* " commentary " */" " " (:representation on))))
-
- (def: #export (switch input cases default)
- (-> Expression (List [(List Literal) Statement]) (Maybe Statement) Statement)
- (:abstraction (format "switch (" (:representation input) ") "
- (|> (format (|> cases
- (list\map (.function (_ [when then])
- (format (|> when
- (list\map (|>> :representation (text.enclose ["case " ":"])))
- (text.join_with text.new_line))
- (..nest (:representation then)))))
- (text.join_with text.new_line))
- text.new_line
- (case default
- (#.Some default)
- (format "default:"
- (..nest (:representation default)))
-
- #.None ""))
- :abstraction
- ..block))))
- )
-
-(def: #export (cond clauses else!)
- (-> (List [Expression Statement]) Statement Statement)
- (list\fold (.function (_ [test then!] next!)
- (..if test then! next!))
- else!
- (list.reverse clauses)))
-
-(template [<apply> <arg>+ <type>+ <function>+]
- [(`` (def: #export (<apply> function)
- (-> Expression (~~ (template.splice <type>+)) Computation)
- (.function (_ (~~ (template.splice <arg>+)))
- (..apply/* function (list (~~ (template.splice <arg>+)))))))
-
- (`` (template [<definition> <function>]
- [(def: #export <definition> (<apply> (..var <function>)))]
-
- (~~ (template.splice <function>+))))]
-
- [apply/1 [_0] [Expression]
- [[not_a_number? "isNaN"]]]
-
- [apply/2 [_0 _1] [Expression Expression]
- []]
-
- [apply/3 [_0 _1 _2] [Expression Expression Expression]
- []]
- )
diff --git a/stdlib/source/lux/target/jvm.lux b/stdlib/source/lux/target/jvm.lux
deleted file mode 100644
index 4250bf705..000000000
--- a/stdlib/source/lux/target/jvm.lux
+++ /dev/null
@@ -1,283 +0,0 @@
-(.module:
- [lux (#- Type)
- [data
- [collection
- [row (#+ Row)]]]
- [target
- [jvm
- [type (#+ Type)
- ["." category (#+ Primitive Class Value Method)]]]]])
-
-(type: #export Literal
- (#Boolean Bit)
- (#Int Int)
- (#Long Int)
- (#Double Frac)
- (#Char Nat)
- (#String Text))
-
-(type: #export Constant
- (#BIPUSH Int)
-
- (#SIPUSH Int)
-
- #ICONST_M1
- #ICONST_0
- #ICONST_1
- #ICONST_2
- #ICONST_3
- #ICONST_4
- #ICONST_5
-
- #LCONST_0
- #LCONST_1
-
- #FCONST_0
- #FCONST_1
- #FCONST_2
-
- #DCONST_0
- #DCONST_1
-
- #ACONST_NULL
-
- (#LDC Literal))
-
-(type: #export Int_Arithmetic
- #IADD
- #ISUB
- #IMUL
- #IDIV
- #IREM
- #INEG)
-
-(type: #export Long_Arithmetic
- #LADD
- #LSUB
- #LMUL
- #LDIV
- #LREM
- #LNEG)
-
-(type: #export Float_Arithmetic
- #FADD
- #FSUB
- #FMUL
- #FDIV
- #FREM
- #FNEG)
-
-(type: #export Double_Arithmetic
- #DADD
- #DSUB
- #DMUL
- #DDIV
- #DREM
- #DNEG)
-
-(type: #export Arithmetic
- (#Int_Arithmetic Int_Arithmetic)
- (#Long_Arithmetic Long_Arithmetic)
- (#Float_Arithmetic Float_Arithmetic)
- (#Double_Arithmetic Double_Arithmetic))
-
-(type: #export Int_Bitwise
- #IOR
- #IXOR
- #IAND
- #ISHL
- #ISHR
- #IUSHR)
-
-(type: #export Long_Bitwise
- #LOR
- #LXOR
- #LAND
- #LSHL
- #LSHR
- #LUSHR)
-
-(type: #export Bitwise
- (#Int_Bitwise Int_Bitwise)
- (#Long_Bitwise Long_Bitwise))
-
-(type: #export Conversion
- #I2B
- #I2S
- #I2L
- #I2F
- #I2D
- #I2C
-
- #L2I
- #L2F
- #L2D
-
- #F2I
- #F2L
- #F2D
-
- #D2I
- #D2L
- #D2F)
-
-(type: #export Array
- #ARRAYLENGTH
-
- (#NEWARRAY (Type Primitive))
- (#ANEWARRAY (Type category.Object))
-
- #BALOAD
- #BASTORE
-
- #SALOAD
- #SASTORE
-
- #IALOAD
- #IASTORE
-
- #LALOAD
- #LASTORE
-
- #FALOAD
- #FASTORE
-
- #DALOAD
- #DASTORE
-
- #CALOAD
- #CASTORE
-
- #AALOAD
- #AASTORE)
-
-(type: #export Object
- (#GETSTATIC (Type Class) Text (Type Value))
- (#PUTSTATIC (Type Class) Text (Type Value))
-
- (#NEW (Type Class))
-
- (#INSTANCEOF (Type Class))
- (#CHECKCAST (Type category.Object))
-
- (#GETFIELD (Type Class) Text (Type Value))
- (#PUTFIELD (Type Class) Text (Type Value))
-
- (#INVOKEINTERFACE (Type Class) Text (Type Method))
- (#INVOKESPECIAL (Type Class) Text (Type Method))
- (#INVOKESTATIC (Type Class) Text (Type Method))
- (#INVOKEVIRTUAL (Type Class) Text (Type Method)))
-
-(type: #export Register Nat)
-
-(type: #export Local_Int
- (#ILOAD Register)
- (#ISTORE Register))
-
-(type: #export Local_Long
- (#LLOAD Register)
- (#LSTORE Register))
-
-(type: #export Local_Float
- (#FLOAD Register)
- (#FSTORE Register))
-
-(type: #export Local_Double
- (#DLOAD Register)
- (#DSTORE Register))
-
-(type: #export Local_Object
- (#ALOAD Register)
- (#ASTORE Register))
-
-(type: #export Local
- (#Local_Int Local_Int)
- (#IINC Register)
- (#Local_Long Local_Long)
- (#Local_Float Local_Float)
- (#Local_Double Local_Double)
- (#Local_Object Local_Object))
-
-(type: #export Stack
- #DUP
- #DUP_X1
- #DUP_X2
- #DUP2
- #DUP2_X1
- #DUP2_X2
- #SWAP
- #POP
- #POP2)
-
-(type: #export Comparison
- #LCMP
-
- #FCMPG
- #FCMPL
-
- #DCMPG
- #DCMPL)
-
-(type: #export Label Nat)
-
-(type: #export (Branching label)
- (#IF_ICMPEQ label)
- (#IF_ICMPGE label)
- (#IF_ICMPGT label)
- (#IF_ICMPLE label)
- (#IF_ICMPLT label)
- (#IF_ICMPNE label)
- (#IFEQ label)
- (#IFNE label)
- (#IFGE label)
- (#IFGT label)
- (#IFLE label)
- (#IFLT label)
-
- (#TABLESWITCH Int Int label (List label))
- (#LOOKUPSWITCH label (List [Int label]))
-
- (#IF_ACMPEQ label)
- (#IF_ACMPNE label)
- (#IFNONNULL label)
- (#IFNULL label))
-
-(type: #export (Exception label)
- (#Try label label label (Type Class))
- #ATHROW)
-
-(type: #export Concurrency
- #MONITORENTER
- #MONITOREXIT)
-
-(type: #export Return
- #RETURN
- #IRETURN
- #LRETURN
- #FRETURN
- #DRETURN
- #ARETURN)
-
-(type: #export (Control label)
- (#GOTO label)
- (#Branching (Branching label))
- (#Exception (Exception label))
- (#Concurrency Concurrency)
- (#Return Return))
-
-(type: #export (Instruction embedded label)
- #NOP
- (#Constant Constant)
- (#Arithmetic Arithmetic)
- (#Bitwise Bitwise)
- (#Conversion Conversion)
- (#Array Array)
- (#Object Object)
- (#Local Local)
- (#Stack Stack)
- (#Comparison Comparison)
- (#Control (Control label))
- (#Embedded embedded))
-
-(type: #export (Bytecode embedded label)
- (Row (Instruction embedded label)))
diff --git a/stdlib/source/lux/target/jvm/attribute.lux b/stdlib/source/lux/target/jvm/attribute.lux
deleted file mode 100644
index 0b8457a9c..000000000
--- a/stdlib/source/lux/target/jvm/attribute.lux
+++ /dev/null
@@ -1,122 +0,0 @@
-(.module:
- [lux (#- Info Code)
- [abstract
- [monad (#+ do)]
- ["." equivalence (#+ Equivalence)]]
- [control
- ["." try]
- ["." exception (#+ exception:)]]
- [data
- ["." sum]
- ["." product]
- [format
- [".F" binary (#+ Writer)]]]
- [math
- [number
- ["n" nat]]]]
- ["." // #_
- ["#." index (#+ Index)]
- [encoding
- ["#." unsigned (#+ U2 U4)]]
- ["#." constant (#+ UTF8 Class Value)
- ["#/." pool (#+ Pool Resource)]]]
- ["." / #_
- ["#." constant (#+ Constant)]
- ["#." code]])
-
-(type: #export (Info about)
- {#name (Index UTF8)
- #length U4
- #info about})
-
-(def: #export (info_equivalence Equivalence<about>)
- (All [about]
- (-> (Equivalence about)
- (Equivalence (Info about))))
- ($_ product.equivalence
- //index.equivalence
- //unsigned.equivalence
- Equivalence<about>))
-
-(def: (info_writer writer)
- (All [about]
- (-> (Writer about)
- (Writer (Info about))))
- (function (_ [name length info])
- (let [[nameS nameT] (//index.writer name)
- [lengthS lengthT] (//unsigned.writer/4 length)
- [infoS infoT] (writer info)]
- [($_ n.+ nameS lengthS infoS)
- (|>> nameT lengthT infoT)])))
-
-(with_expansions [<Code> (as_is (/code.Code Attribute))]
- (type: #export #rec Attribute
- (#Constant (Info (Constant Any)))
- (#Code (Info <Code>)))
-
- (type: #export Code
- <Code>)
- )
-
-(def: #export equivalence
- (Equivalence Attribute)
- (equivalence.rec
- (function (_ equivalence)
- ($_ sum.equivalence
- (info_equivalence /constant.equivalence)
- (info_equivalence (/code.equivalence equivalence))))))
-
-(def: common_attribute_length
- ($_ n.+
- ## u2 attribute_name_index;
- //unsigned.bytes/2
- ## u4 attribute_length;
- //unsigned.bytes/4
- ))
-
-(def: (length attribute)
- (-> Attribute Nat)
- (case attribute
- (^template [<tag>]
- [(<tag> [name length info])
- (|> length //unsigned.value (n.+ ..common_attribute_length))])
- ([#Constant] [#Code])))
-
-## TODO: Inline ASAP
-(def: (constant' @name index)
- (-> (Index UTF8) (Constant Any) Attribute)
- (#Constant {#name @name
- #length (|> /constant.length //unsigned.u4 try.assume)
- #info index}))
-
-(def: #export (constant index)
- (-> (Constant Any) (Resource Attribute))
- (do //constant/pool.monad
- [@name (//constant/pool.utf8 "ConstantValue")]
- (wrap (constant' @name index))))
-
-## TODO: Inline ASAP
-(def: (code' @name specification)
- (-> (Index UTF8) Code Attribute)
- (#Code {#name @name
- ## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3
- #length (|> specification
- (/code.length ..length)
- //unsigned.u4
- try.assume)
- #info specification}))
-
-(def: #export (code specification)
- (-> Code (Resource Attribute))
- (do //constant/pool.monad
- [@name (//constant/pool.utf8 "Code")]
- (wrap (code' @name specification))))
-
-(def: #export (writer value)
- (Writer Attribute)
- (case value
- (#Constant attribute)
- ((info_writer /constant.writer) attribute)
-
- (#Code attribute)
- ((info_writer (/code.writer writer)) attribute)))
diff --git a/stdlib/source/lux/target/jvm/attribute/code.lux b/stdlib/source/lux/target/jvm/attribute/code.lux
deleted file mode 100644
index 212d44765..000000000
--- a/stdlib/source/lux/target/jvm/attribute/code.lux
+++ /dev/null
@@ -1,82 +0,0 @@
-(.module:
- [lux (#- Code)
- [type (#+ :share)]
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- ["." product]
- ["." binary (#+ Binary)]
- [format
- [".F" binary (#+ Writer) ("#\." monoid)]]
- [collection
- ["." row (#+ Row) ("#\." functor fold)]]]
- [math
- [number
- ["n" nat]]]]
- ["." /// #_
- [bytecode
- [environment
- ["#." limit (#+ Limit)]]]
- [encoding
- ["#." unsigned (#+ U2)]]]
- ["." / #_
- ["#." exception (#+ Exception)]])
-
-(type: #export (Code Attribute)
- {#limit Limit
- #code Binary
- #exception_table (Row Exception)
- #attributes (Row Attribute)})
-
-(def: #export (length length code)
- (All [Attribute] (-> (-> Attribute Nat) (Code Attribute) Nat))
- ($_ n.+
- ## u2 max_stack;
- ## u2 max_locals;
- ///limit.length
- ## u4 code_length;
- ///unsigned.bytes/4
- ## u1 code[code_length];
- (binary.size (get@ #code code))
- ## u2 exception_table_length;
- ///unsigned.bytes/2
- ## exception_table[exception_table_length];
- (|> code
- (get@ #exception_table)
- row.size
- (n.* /exception.length))
- ## u2 attributes_count;
- ///unsigned.bytes/2
- ## attribute_info attributes[attributes_count];
- (|> code
- (get@ #attributes)
- (row\map length)
- (row\fold n.+ 0))))
-
-(def: #export (equivalence attribute_equivalence)
- (All [attribute]
- (-> (Equivalence attribute) (Equivalence (Code attribute))))
- ($_ product.equivalence
- ///limit.equivalence
- binary.equivalence
- (row.equivalence /exception.equivalence)
- (row.equivalence attribute_equivalence)
- ))
-
-## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3
-(def: #export (writer writer code)
- (All [Attribute] (-> (Writer Attribute) (Writer (Code Attribute))))
- ($_ binaryF\compose
- ## u2 max_stack;
- ## u2 max_locals;
- (///limit.writer (get@ #limit code))
- ## u4 code_length;
- ## u1 code[code_length];
- (binaryF.binary/32 (get@ #code code))
- ## u2 exception_table_length;
- ## exception_table[exception_table_length];
- ((binaryF.row/16 /exception.writer) (get@ #exception_table code))
- ## u2 attributes_count;
- ## attribute_info attributes[attributes_count];
- ((binaryF.row/16 writer) (get@ #attributes code))
- ))
diff --git a/stdlib/source/lux/target/jvm/attribute/code/exception.lux b/stdlib/source/lux/target/jvm/attribute/code/exception.lux
deleted file mode 100644
index 9ae264438..000000000
--- a/stdlib/source/lux/target/jvm/attribute/code/exception.lux
+++ /dev/null
@@ -1,57 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- ["." product]
- ["." format #_
- ["#" binary (#+ Writer)]]]
- [math
- [number
- ["n" nat]]]]
- ["." // #_
- ["//#" /// #_
- [constant (#+ Class)]
- ["#." index (#+ Index)]
- [bytecode
- ["#." address (#+ Address)]]
- [encoding
- ["#." unsigned (#+ U2)]]]])
-
-(type: #export Exception
- {#start Address
- #end Address
- #handler Address
- #catch (Index Class)})
-
-(def: #export equivalence
- (Equivalence Exception)
- ($_ product.equivalence
- ////address.equivalence
- ////address.equivalence
- ////address.equivalence
- ////index.equivalence
- ))
-
-## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3
-(def: #export length
- Nat
- ($_ n.+
- ## u2 start_pc;
- ////unsigned.bytes/2
- ## u2 end_pc;
- ////unsigned.bytes/2
- ## u2 handler_pc;
- ////unsigned.bytes/2
- ## u2 catch_type;
- ////unsigned.bytes/2
- ))
-
-(def: #export writer
- (Writer Exception)
- ($_ format.and
- ////address.writer
- ////address.writer
- ////address.writer
- ////index.writer
- ))
diff --git a/stdlib/source/lux/target/jvm/attribute/constant.lux b/stdlib/source/lux/target/jvm/attribute/constant.lux
deleted file mode 100644
index c5605bcc3..000000000
--- a/stdlib/source/lux/target/jvm/attribute/constant.lux
+++ /dev/null
@@ -1,26 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- [format
- [binary (#+ Writer)]]]]
- ["." /// #_
- [constant (#+ Value)]
- ["#." index (#+ Index)]
- [encoding
- ["#." unsigned (#+ U2 U4)]]])
-
-(type: #export (Constant a)
- (Index (Value a)))
-
-(def: #export equivalence
- (All [a] (Equivalence (Constant a)))
- ///index.equivalence)
-
-(def: #export length
- ///index.length)
-
-(def: #export writer
- (All [a] (Writer (Constant a)))
- ///index.writer)
diff --git a/stdlib/source/lux/target/jvm/bytecode.lux b/stdlib/source/lux/target/jvm/bytecode.lux
deleted file mode 100644
index 551b51087..000000000
--- a/stdlib/source/lux/target/jvm/bytecode.lux
+++ /dev/null
@@ -1,1045 +0,0 @@
-(.module:
- [lux (#- Type int try)
- ["." ffi (#+ import:)]
- [abstract
- [monoid (#+ Monoid)]
- ["." monad (#+ Monad do)]]
- [control
- ["." writer (#+ Writer)]
- ["." state (#+ State')]
- ["." function]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." product]
- ["." maybe]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." dictionary (#+ Dictionary)]
- ["." row (#+ Row)]]]
- [macro
- ["." template]]
- [math
- [number
- ["n" nat]
- ["i" int]
- ["." i32 (#+ I32)]]]]
- ["." / #_
- ["#." address (#+ Address)]
- ["#." jump (#+ Jump Big_Jump)]
- ["_" instruction (#+ Primitive_Array_Type Instruction Estimator) ("#\." monoid)]
- ["#." environment (#+ Environment)
- [limit
- ["/." registry (#+ Register Registry)]
- ["/." stack (#+ Stack)]]]
- ["/#" // #_
- ["#." index (#+ Index)]
- [encoding
- ["#." name]
- ["#." unsigned (#+ U1 U2)]
- ["#." signed (#+ S1 S2 S4)]]
- ["#." constant (#+ UTF8)
- ["#/." pool (#+ Pool Resource)]]
- [attribute
- [code
- ["#." exception (#+ Exception)]]]
- ["." type (#+ Type)
- [category (#+ Class Object Value' Value Return' Return Method)]
- ["." reflection]
- ["." parser]]]])
-
-(type: #export Label Nat)
-
-(type: #export Resolver (Dictionary Label [Stack (Maybe Address)]))
-
-(type: #export Tracker
- {#program_counter Address
- #next Label
- #known Resolver})
-
-(def: fresh
- Tracker
- {#program_counter /address.start
- #next 0
- #known (dictionary.new n.hash)})
-
-(type: #export Relative
- (-> Resolver (Try [(Row Exception) Instruction])))
-
-(def: no_exceptions
- (Row Exception)
- row.empty)
-
-(def: relative_identity
- Relative
- (function.constant (#try.Success [..no_exceptions _.empty])))
-
-(implementation: relative_monoid
- (Monoid Relative)
-
- (def: identity ..relative_identity)
-
- (def: (compose left right)
- (cond (is? ..relative_identity left)
- right
-
- (is? ..relative_identity right)
- left
-
- ## else
- (function (_ resolver)
- (do try.monad
- [[left_exceptions left_instruction] (left resolver)
- [right_exceptions right_instruction] (right resolver)]
- (wrap [(\ row.monoid compose left_exceptions right_exceptions)
- (_\compose left_instruction right_instruction)]))))))
-
-(type: #export (Bytecode a)
- (State' Try [Pool Environment Tracker] (Writer Relative a)))
-
-(def: #export new_label
- (Bytecode Label)
- (function (_ [pool environment tracker])
- (#try.Success [[pool
- environment
- (update@ #next inc tracker)]
- [..relative_identity
- (get@ #next tracker)]])))
-
-(exception: #export (label_has_already_been_set {label Label})
- (exception.report
- ["Label" (%.nat label)]))
-
-(exception: #export (mismatched_environments {instruction Name}
- {label Label}
- {address Address}
- {expected Stack}
- {actual Stack})
- (exception.report
- ["Instruction" (%.name instruction)]
- ["Label" (%.nat label)]
- ["Address" (/address.format address)]
- ["Expected" (/stack.format expected)]
- ["Actual" (/stack.format actual)]))
-
-(with_expansions [<success> (as_is (wrap [[pool
- environment
- (update@ #known
- (dictionary.put label [actual (#.Some @here)])
- tracker)]
- [..relative_identity
- []]]))]
- (def: #export (set_label label)
- (-> Label (Bytecode Any))
- (function (_ [pool environment tracker])
- (let [@here (get@ #program_counter tracker)]
- (case (dictionary.get label (get@ #known tracker))
- (#.Some [expected (#.Some address)])
- (exception.throw ..label_has_already_been_set [label])
-
- (#.Some [expected #.None])
- (do try.monad
- [[actual environment] (/environment.continue expected environment)]
- <success>)
-
- #.None
- (do try.monad
- [[actual environment] (/environment.continue (|> environment
- (get@ #/environment.stack)
- (maybe.default /stack.empty))
- environment)]
- <success>))))))
-
-(def: #export monad
- (Monad Bytecode)
- (<| (:as (Monad Bytecode))
- (writer.with ..relative_monoid)
- (: (Monad (State' Try [Pool Environment Tracker])))
- state.with
- (: (Monad Try))
- try.monad))
-
-(def: #export fail
- (-> Text Bytecode)
- (|>> #try.Failure function.constant))
-
-(def: #export (throw exception value)
- (All [e] (-> (exception.Exception e) e Bytecode))
- (..fail (exception.construct exception value)))
-
-(def: #export (resolve environment bytecode)
- (All [a] (-> Environment (Bytecode a) (Resource [Environment (Row Exception) Instruction a])))
- (function (_ pool)
- (do try.monad
- [[[pool environment tracker] [relative output]] (bytecode [pool environment ..fresh])
- [exceptions instruction] (relative (get@ #known tracker))]
- (wrap [pool [environment exceptions instruction output]]))))
-
-(def: (step estimator counter)
- (-> Estimator Address (Try Address))
- (/address.move (estimator counter) counter))
-
-(def: (bytecode consumption production registry [estimator bytecode] input)
- (All [a] (-> U2 U2 Registry [Estimator (-> [a] Instruction)] [a] (Bytecode Any)))
- (function (_ [pool environment tracker])
- (do {! try.monad}
- [environment' (|> environment
- (/environment.consumes consumption)
- (monad.bind ! (/environment.produces production))
- (monad.bind ! (/environment.has registry)))
- program_counter' (step estimator (get@ #program_counter tracker))]
- (wrap [[pool
- environment'
- (set@ #program_counter program_counter' tracker)]
- [(function.constant (wrap [..no_exceptions (bytecode input)]))
- []]]))))
-
-(template [<name> <frames>]
- [(def: <name> U2 (|> <frames> //unsigned.u2 try.assume))]
-
- [$0 0]
- [$1 1]
- [$2 2]
- [$3 3]
- [$4 4]
- [$5 5]
- [$6 6]
- )
-
-(template [<name> <registry>]
- [(def: <name> Registry (|> <registry> //unsigned.u2 try.assume /registry.registry))]
-
- [@_ 0]
- [@0 1]
- [@1 2]
- [@2 3]
- [@3 4]
- [@4 5]
- )
-
-(template [<name> <consumption> <production> <registry> <instruction>]
- [(def: #export <name>
- (Bytecode Any)
- (..bytecode <consumption>
- <production>
- <registry>
- <instruction>
- []))]
-
- [nop $0 $0 @_ _.nop]
-
- [aconst_null $0 $1 @_ _.aconst_null]
-
- [iconst_m1 $0 $1 @_ _.iconst_m1]
- [iconst_0 $0 $1 @_ _.iconst_0]
- [iconst_1 $0 $1 @_ _.iconst_1]
- [iconst_2 $0 $1 @_ _.iconst_2]
- [iconst_3 $0 $1 @_ _.iconst_3]
- [iconst_4 $0 $1 @_ _.iconst_4]
- [iconst_5 $0 $1 @_ _.iconst_5]
-
- [lconst_0 $0 $2 @_ _.lconst_0]
- [lconst_1 $0 $2 @_ _.lconst_1]
-
- [fconst_0 $0 $1 @_ _.fconst_0]
- [fconst_1 $0 $1 @_ _.fconst_1]
- [fconst_2 $0 $1 @_ _.fconst_2]
-
- [dconst_0 $0 $2 @_ _.dconst_0]
- [dconst_1 $0 $2 @_ _.dconst_1]
-
- [pop $1 $0 @_ _.pop]
- [pop2 $2 $0 @_ _.pop2]
-
- [dup $1 $2 @_ _.dup]
- [dup_x1 $2 $3 @_ _.dup_x1]
- [dup_x2 $3 $4 @_ _.dup_x2]
- [dup2 $2 $4 @_ _.dup2]
- [dup2_x1 $3 $5 @_ _.dup2_x1]
- [dup2_x2 $4 $6 @_ _.dup2_x2]
-
- [swap $2 $2 @_ _.swap]
-
- [iaload $2 $1 @_ _.iaload]
- [laload $2 $2 @_ _.laload]
- [faload $2 $1 @_ _.faload]
- [daload $2 $2 @_ _.daload]
- [aaload $2 $1 @_ _.aaload]
- [baload $2 $1 @_ _.baload]
- [caload $2 $1 @_ _.caload]
- [saload $2 $1 @_ _.saload]
-
- [iload_0 $0 $1 @0 _.iload_0]
- [iload_1 $0 $1 @1 _.iload_1]
- [iload_2 $0 $1 @2 _.iload_2]
- [iload_3 $0 $1 @3 _.iload_3]
-
- [lload_0 $0 $2 @1 _.lload_0]
- [lload_1 $0 $2 @2 _.lload_1]
- [lload_2 $0 $2 @3 _.lload_2]
- [lload_3 $0 $2 @4 _.lload_3]
-
- [fload_0 $0 $1 @0 _.fload_0]
- [fload_1 $0 $1 @1 _.fload_1]
- [fload_2 $0 $1 @2 _.fload_2]
- [fload_3 $0 $1 @3 _.fload_3]
-
- [dload_0 $0 $2 @1 _.dload_0]
- [dload_1 $0 $2 @2 _.dload_1]
- [dload_2 $0 $2 @3 _.dload_2]
- [dload_3 $0 $2 @4 _.dload_3]
-
- [aload_0 $0 $1 @0 _.aload_0]
- [aload_1 $0 $1 @1 _.aload_1]
- [aload_2 $0 $1 @2 _.aload_2]
- [aload_3 $0 $1 @3 _.aload_3]
-
- [iastore $3 $1 @_ _.iastore]
- [lastore $4 $1 @_ _.lastore]
- [fastore $3 $1 @_ _.fastore]
- [dastore $4 $1 @_ _.dastore]
- [aastore $3 $1 @_ _.aastore]
- [bastore $3 $1 @_ _.bastore]
- [castore $3 $1 @_ _.castore]
- [sastore $3 $1 @_ _.sastore]
-
- [istore_0 $1 $0 @0 _.istore_0]
- [istore_1 $1 $0 @1 _.istore_1]
- [istore_2 $1 $0 @2 _.istore_2]
- [istore_3 $1 $0 @3 _.istore_3]
-
- [lstore_0 $2 $0 @1 _.lstore_0]
- [lstore_1 $2 $0 @2 _.lstore_1]
- [lstore_2 $2 $0 @3 _.lstore_2]
- [lstore_3 $2 $0 @4 _.lstore_3]
-
- [fstore_0 $1 $0 @0 _.fstore_0]
- [fstore_1 $1 $0 @1 _.fstore_1]
- [fstore_2 $1 $0 @2 _.fstore_2]
- [fstore_3 $1 $0 @3 _.fstore_3]
-
- [dstore_0 $2 $0 @1 _.dstore_0]
- [dstore_1 $2 $0 @2 _.dstore_1]
- [dstore_2 $2 $0 @3 _.dstore_2]
- [dstore_3 $2 $0 @4 _.dstore_3]
-
- [astore_0 $1 $0 @0 _.astore_0]
- [astore_1 $1 $0 @1 _.astore_1]
- [astore_2 $1 $0 @2 _.astore_2]
- [astore_3 $1 $0 @3 _.astore_3]
-
- [iadd $2 $1 @_ _.iadd]
- [isub $2 $1 @_ _.isub]
- [imul $2 $1 @_ _.imul]
- [idiv $2 $1 @_ _.idiv]
- [irem $2 $1 @_ _.irem]
- [ineg $1 $1 @_ _.ineg]
- [iand $2 $1 @_ _.iand]
- [ior $2 $1 @_ _.ior]
- [ixor $2 $1 @_ _.ixor]
- [ishl $2 $1 @_ _.ishl]
- [ishr $2 $1 @_ _.ishr]
- [iushr $2 $1 @_ _.iushr]
-
- [ladd $4 $2 @_ _.ladd]
- [lsub $4 $2 @_ _.lsub]
- [lmul $4 $2 @_ _.lmul]
- [ldiv $4 $2 @_ _.ldiv]
- [lrem $4 $2 @_ _.lrem]
- [lneg $2 $2 @_ _.lneg]
- [land $4 $2 @_ _.land]
- [lor $4 $2 @_ _.lor]
- [lxor $4 $2 @_ _.lxor]
- [lshl $3 $2 @_ _.lshl]
- [lshr $3 $2 @_ _.lshr]
- [lushr $3 $2 @_ _.lushr]
-
- [fadd $2 $1 @_ _.fadd]
- [fsub $2 $1 @_ _.fsub]
- [fmul $2 $1 @_ _.fmul]
- [fdiv $2 $1 @_ _.fdiv]
- [frem $2 $1 @_ _.frem]
- [fneg $1 $1 @_ _.fneg]
-
- [dadd $4 $2 @_ _.dadd]
- [dsub $4 $2 @_ _.dsub]
- [dmul $4 $2 @_ _.dmul]
- [ddiv $4 $2 @_ _.ddiv]
- [drem $4 $2 @_ _.drem]
- [dneg $2 $2 @_ _.dneg]
-
- [l2i $2 $1 @_ _.l2i]
- [l2f $2 $1 @_ _.l2f]
- [l2d $2 $2 @_ _.l2d]
-
- [f2i $1 $1 @_ _.f2i]
- [f2l $1 $2 @_ _.f2l]
- [f2d $1 $2 @_ _.f2d]
-
- [d2i $2 $1 @_ _.d2i]
- [d2l $2 $2 @_ _.d2l]
- [d2f $2 $1 @_ _.d2f]
-
- [i2l $1 $2 @_ _.i2l]
- [i2f $1 $1 @_ _.i2f]
- [i2d $1 $2 @_ _.i2d]
- [i2b $1 $1 @_ _.i2b]
- [i2c $1 $1 @_ _.i2c]
- [i2s $1 $1 @_ _.i2s]
-
- [lcmp $4 $1 @_ _.lcmp]
-
- [fcmpl $2 $1 @_ _.fcmpl]
- [fcmpg $2 $1 @_ _.fcmpg]
-
- [dcmpl $4 $1 @_ _.dcmpl]
- [dcmpg $4 $1 @_ _.dcmpg]
-
- [arraylength $1 $1 @_ _.arraylength]
-
- [monitorenter $1 $0 @_ _.monitorenter]
- [monitorexit $1 $0 @_ _.monitorexit]
- )
-
-(def: discontinuity!
- (Bytecode Any)
- (function (_ [pool environment tracker])
- (do try.monad
- [_ (/environment.stack environment)]
- (wrap [[pool
- (/environment.discontinue environment)
- tracker]
- [..relative_identity
- []]]))))
-
-(template [<name> <consumption> <instruction>]
- [(def: #export <name>
- (Bytecode Any)
- (do ..monad
- [_ (..bytecode <consumption> $0 @_ <instruction> [])]
- ..discontinuity!))]
-
- [ireturn $1 _.ireturn]
- [lreturn $2 _.lreturn]
- [freturn $1 _.freturn]
- [dreturn $2 _.dreturn]
- [areturn $1 _.areturn]
- [return $0 _.return]
-
- [athrow $1 _.athrow]
- )
-
-(def: #export (bipush byte)
- (-> S1 (Bytecode Any))
- (..bytecode $0 $1 @_ _.bipush [byte]))
-
-(def: (lift resource)
- (All [a]
- (-> (Resource a)
- (Bytecode a)))
- (function (_ [pool environment tracker])
- (do try.monad
- [[pool' output] (resource pool)]
- (wrap [[pool' environment tracker]
- [..relative_identity
- output]]))))
-
-(def: #export (string value)
- (-> //constant.UTF8 (Bytecode Any))
- (do ..monad
- [index (..lift (//constant/pool.string value))]
- (case (|> index //index.value //unsigned.value //unsigned.u1)
- (#try.Success index)
- (..bytecode $0 $1 @_ _.ldc [index])
-
- (#try.Failure _)
- (..bytecode $0 $1 @_ _.ldc_w/string [index]))))
-
-(import: java/lang/Float
- ["#::."
- (#static floatToRawIntBits #manual [float] int)])
-
-(import: java/lang/Double
- ["#::."
- (#static doubleToRawLongBits #manual [double] long)])
-
-(template [<name> <type> <constructor> <constant> <wide> <to_lux> <specializations>]
- [(def: #export (<name> value)
- (-> <type> (Bytecode Any))
- (case (|> value <to_lux>)
- (^template [<special> <instruction>]
- [<special> (..bytecode $0 $1 @_ <instruction> [])])
- <specializations>
-
- _ (do ..monad
- [index (..lift (<constant> (<constructor> value)))]
- (case (|> index //index.value //unsigned.value //unsigned.u1)
- (#try.Success index)
- (..bytecode $0 $1 @_ _.ldc [index])
-
- (#try.Failure _)
- (..bytecode $0 $1 @_ <wide> [index])))))]
-
- [int I32 //constant.integer //constant/pool.integer _.ldc_w/integer
- (<| .int i32.i64)
- ([-1 _.iconst_m1]
- [+0 _.iconst_0]
- [+1 _.iconst_1]
- [+2 _.iconst_2]
- [+3 _.iconst_3]
- [+4 _.iconst_4]
- [+5 _.iconst_5])]
- )
-
-(def: (arbitrary_float value)
- (-> java/lang/Float (Bytecode Any))
- (do ..monad
- [index (..lift (//constant/pool.float (//constant.float value)))]
- (case (|> index //index.value //unsigned.value //unsigned.u1)
- (#try.Success index)
- (..bytecode $0 $1 @_ _.ldc [index])
-
- (#try.Failure _)
- (..bytecode $0 $1 @_ _.ldc_w/float [index]))))
-
-(def: float_bits
- (-> java/lang/Float Int)
- (|>> java/lang/Float::floatToRawIntBits
- ffi.int_to_long
- (:as Int)))
-
-(def: negative_zero_float_bits
- (|> -0.0 (:as java/lang/Double) ffi.double_to_float ..float_bits))
-
-(def: #export (float value)
- (-> java/lang/Float (Bytecode Any))
- (if (i.= ..negative_zero_float_bits
- (..float_bits value))
- (..arbitrary_float value)
- (case (|> value ffi.float_to_double (:as Frac))
- (^template [<special> <instruction>]
- [<special> (..bytecode $0 $1 @_ <instruction> [])])
- ([+0.0 _.fconst_0]
- [+1.0 _.fconst_1]
- [+2.0 _.fconst_2])
-
- _ (..arbitrary_float value))))
-
-(template [<name> <type> <constructor> <constant> <wide> <to_lux> <specializations>]
- [(def: #export (<name> value)
- (-> <type> (Bytecode Any))
- (case (|> value <to_lux>)
- (^template [<special> <instruction>]
- [<special> (..bytecode $0 $2 @_ <instruction> [])])
- <specializations>
-
- _ (do ..monad
- [index (..lift (<constant> (<constructor> value)))]
- (..bytecode $0 $2 @_ <wide> [index]))))]
-
- [long Int //constant.long //constant/pool.long _.ldc2_w/long
- (<|)
- ([+0 _.lconst_0]
- [+1 _.lconst_1])]
- )
-
-(def: (arbitrary_double value)
- (-> java/lang/Double (Bytecode Any))
- (do ..monad
- [index (..lift (//constant/pool.double (//constant.double (:as Frac value))))]
- (..bytecode $0 $2 @_ _.ldc2_w/double [index])))
-
-(def: double_bits
- (-> java/lang/Double Int)
- (|>> java/lang/Double::doubleToRawLongBits
- (:as Int)))
-
-(def: negative_zero_double_bits
- (..double_bits (:as java/lang/Double -0.0)))
-
-(def: #export (double value)
- (-> java/lang/Double (Bytecode Any))
- (if (i.= ..negative_zero_double_bits
- (..double_bits value))
- (..arbitrary_double value)
- (case (:as Frac value)
- (^template [<special> <instruction>]
- [<special> (..bytecode $0 $2 @_ <instruction> [])])
- ([+0.0 _.dconst_0]
- [+1.0 _.dconst_1])
-
- _ (..arbitrary_double value))))
-
-(exception: #export (invalid_register {id Nat})
- (exception.report
- ["ID" (%.nat id)]))
-
-(def: (register id)
- (-> Nat (Bytecode Register))
- (case (//unsigned.u1 id)
- (#try.Success register)
- (\ ..monad wrap register)
-
- (#try.Failure error)
- (..throw ..invalid_register [id])))
-
-(template [<for> <size> <name> <general> <specials>]
- [(def: #export (<name> local)
- (-> Nat (Bytecode Any))
- (with_expansions [<specials>' (template.splice <specials>)]
- (`` (case local
- (~~ (template [<case> <instruction> <registry>]
- [<case> (..bytecode $0 <size> <registry> <instruction> [])]
-
- <specials>'))
- _ (do ..monad
- [local (..register local)]
- (..bytecode $0 <size> (<for> local) <general> [local]))))))]
-
- [/registry.for $1 iload _.iload
- [[0 _.iload_0 @0]
- [1 _.iload_1 @1]
- [2 _.iload_2 @2]
- [3 _.iload_3 @3]]]
- [/registry.for_wide $2 lload _.lload
- [[0 _.lload_0 @1]
- [1 _.lload_1 @2]
- [2 _.lload_2 @3]
- [3 _.lload_3 @4]]]
- [/registry.for $1 fload _.fload
- [[0 _.fload_0 @0]
- [1 _.fload_1 @1]
- [2 _.fload_2 @2]
- [3 _.fload_3 @3]]]
- [/registry.for_wide $2 dload _.dload
- [[0 _.dload_0 @1]
- [1 _.dload_1 @2]
- [2 _.dload_2 @3]
- [3 _.dload_3 @4]]]
- [/registry.for $1 aload _.aload
- [[0 _.aload_0 @0]
- [1 _.aload_1 @1]
- [2 _.aload_2 @2]
- [3 _.aload_3 @3]]]
- )
-
-(template [<for> <size> <name> <general> <specials>]
- [(def: #export (<name> local)
- (-> Nat (Bytecode Any))
- (with_expansions [<specials>' (template.splice <specials>)]
- (`` (case local
- (~~ (template [<case> <instruction> <registry>]
- [<case> (..bytecode <size> $0 <registry> <instruction> [])]
-
- <specials>'))
- _ (do ..monad
- [local (..register local)]
- (..bytecode <size> $0 (<for> local) <general> [local]))))))]
-
- [/registry.for $1 istore _.istore
- [[0 _.istore_0 @0]
- [1 _.istore_1 @1]
- [2 _.istore_2 @2]
- [3 _.istore_3 @3]]]
- [/registry.for_wide $2 lstore _.lstore
- [[0 _.lstore_0 @1]
- [1 _.lstore_1 @2]
- [2 _.lstore_2 @3]
- [3 _.lstore_3 @4]]]
- [/registry.for $1 fstore _.fstore
- [[0 _.fstore_0 @0]
- [1 _.fstore_1 @1]
- [2 _.fstore_2 @2]
- [3 _.fstore_3 @3]]]
- [/registry.for_wide $2 dstore _.dstore
- [[0 _.dstore_0 @1]
- [1 _.dstore_1 @2]
- [2 _.dstore_2 @3]
- [3 _.dstore_3 @4]]]
- [/registry.for $1 astore _.astore
- [[0 _.astore_0 @0]
- [1 _.astore_1 @1]
- [2 _.astore_2 @2]
- [3 _.astore_3 @3]]]
- )
-
-(template [<consumption> <production> <name> <instruction> <input>]
- [(def: #export <name>
- (-> <input> (Bytecode Any))
- (..bytecode <consumption> <production> @_ <instruction>))]
-
- [$1 $1 newarray _.newarray Primitive_Array_Type]
- [$0 $1 sipush _.sipush S2]
- )
-
-(exception: #export (unknown_label {label Label})
- (exception.report
- ["Label" (%.nat label)]))
-
-(exception: #export (cannot_do_a_big_jump {label Label}
- {@from Address}
- {jump Big_Jump})
- (exception.report
- ["Label" (%.nat label)]
- ["Start" (|> @from /address.value //unsigned.value %.nat)]
- ["Target" (|> jump //signed.value %.int)]))
-
-(type: Any_Jump (Either Big_Jump Jump))
-
-(def: (jump @from @to)
- (-> Address Address (Try Any_Jump))
- (do {! try.monad}
- [jump (\ ! map //signed.value
- (/address.jump @from @to))]
- (let [big? (n.> (//unsigned.value //unsigned.maximum/2)
- (.nat (i.* (if (i.>= +0 jump)
- +1
- -1)
- jump)))]
- (if big?
- (\ ! map (|>> #.Left) (//signed.s4 jump))
- (\ ! map (|>> #.Right) (//signed.s2 jump))))))
-
-(exception: #export (unset_label {label Label})
- (exception.report
- ["Label" (%.nat label)]))
-
-(def: (resolve_label label resolver)
- (-> Label Resolver (Try [Stack Address]))
- (case (dictionary.get label resolver)
- (#.Some [actual (#.Some address)])
- (#try.Success [actual address])
-
- (#.Some [actual #.None])
- (exception.throw ..unset_label [label])
-
- #.None
- (exception.throw ..unknown_label [label])))
-
-(def: (acknowledge_label stack label tracker)
- (-> Stack Label Tracker Tracker)
- (case (dictionary.get label (get@ #known tracker))
- (#.Some _)
- tracker
-
- #.None
- (update@ #known (dictionary.put label [stack #.None]) tracker)))
-
-(template [<consumption> <name> <instruction>]
- [(def: #export (<name> label)
- (-> Label (Bytecode Any))
- (let [[estimator bytecode] <instruction>]
- (function (_ [pool environment tracker])
- (let [@here (get@ #program_counter tracker)]
- (do try.monad
- [environment' (|> environment
- (/environment.consumes <consumption>))
- actual (/environment.stack environment')
- program_counter' (step estimator @here)]
- (wrap (let [@from @here]
- [[pool
- environment'
- (|> tracker
- (..acknowledge_label actual label)
- (set@ #program_counter program_counter'))]
- [(function (_ resolver)
- (do try.monad
- [[expected @to] (..resolve_label label resolver)
- _ (exception.assert ..mismatched_environments [(name_of <instruction>) label @here expected actual]
- (\ /stack.equivalence = expected actual))
- jump (..jump @from @to)]
- (case jump
- (#.Left jump)
- (exception.throw ..cannot_do_a_big_jump [label @from jump])
-
- (#.Right jump)
- (wrap [..no_exceptions (bytecode jump)]))))
- []]])))))))]
-
- [$1 ifeq _.ifeq]
- [$1 ifne _.ifne]
- [$1 iflt _.iflt]
- [$1 ifge _.ifge]
- [$1 ifgt _.ifgt]
- [$1 ifle _.ifle]
-
- [$1 ifnull _.ifnull]
- [$1 ifnonnull _.ifnonnull]
-
- [$2 if_icmpeq _.if_icmpeq]
- [$2 if_icmpne _.if_icmpne]
- [$2 if_icmplt _.if_icmplt]
- [$2 if_icmpge _.if_icmpge]
- [$2 if_icmpgt _.if_icmpgt]
- [$2 if_icmple _.if_icmple]
-
- [$2 if_acmpeq _.if_acmpeq]
- [$2 if_acmpne _.if_acmpne]
- )
-
-(template [<name> <instruction> <on_long_jump> <on_short_jump>]
- [(def: #export (<name> label)
- (-> Label (Bytecode Any))
- (let [[estimator bytecode] <instruction>]
- (function (_ [pool environment tracker])
- (do try.monad
- [actual (/environment.stack environment)
- #let [@here (get@ #program_counter tracker)]
- program_counter' (step estimator @here)]
- (wrap (let [@from @here]
- [[pool
- (/environment.discontinue environment)
- (|> tracker
- (..acknowledge_label actual label)
- (set@ #program_counter program_counter'))]
- [(function (_ resolver)
- (case (dictionary.get label resolver)
- (#.Some [expected (#.Some @to)])
- (do try.monad
- [_ (exception.assert ..mismatched_environments [(name_of <instruction>) label @here expected actual]
- (\ /stack.equivalence = expected actual))
- jump (..jump @from @to)]
- (case jump
- (#.Left jump)
- <on_long_jump>
-
- (#.Right jump)
- <on_short_jump>))
-
- (#.Some [expected #.None])
- (exception.throw ..unset_label [label])
-
- #.None
- (exception.throw ..unknown_label [label])))
- []]]))))))]
-
- [goto _.goto
- (exception.throw ..cannot_do_a_big_jump [label @from jump])
- (wrap [..no_exceptions (bytecode jump)])]
- [goto_w _.goto_w
- (wrap [..no_exceptions (bytecode jump)])
- (wrap [..no_exceptions (bytecode (/jump.lift jump))])]
- )
-
-(def: (big_jump jump)
- (-> Any_Jump Big_Jump)
- (case jump
- (#.Left big)
- big
-
- (#.Right small)
- (/jump.lift small)))
-
-(exception: #export invalid_tableswitch)
-
-(def: #export (tableswitch minimum default [at_minimum afterwards])
- (-> S4 Label [Label (List Label)] (Bytecode Any))
- (let [[estimator bytecode] _.tableswitch]
- (function (_ [pool environment tracker])
- (do try.monad
- [environment' (|> environment
- (/environment.consumes $1))
- actual (/environment.stack environment')
- program_counter' (step (estimator (list.size afterwards)) (get@ #program_counter tracker))]
- (wrap (let [@from (get@ #program_counter tracker)]
- [[pool
- environment'
- (|> (list\fold (..acknowledge_label actual) tracker (list& default at_minimum afterwards))
- (set@ #program_counter program_counter'))]
- [(function (_ resolver)
- (let [get (: (-> Label (Maybe [Stack (Maybe Address)]))
- (function (_ label)
- (dictionary.get label resolver)))]
- (case (do {! maybe.monad}
- [@default (|> default get (monad.bind ! product.right))
- @at_minimum (|> at_minimum get (monad.bind ! product.right))
- @afterwards (|> afterwards
- (monad.map ! get)
- (monad.bind ! (monad.map ! product.right)))]
- (wrap [@default @at_minimum @afterwards]))
- (#.Some [@default @at_minimum @afterwards])
- (do {! try.monad}
- [>default (\ ! map ..big_jump (..jump @from @default))
- >at_minimum (\ ! map ..big_jump (..jump @from @at_minimum))
- >afterwards (monad.map ! (|>> (..jump @from) (\ ! map ..big_jump))
- @afterwards)]
- (wrap [..no_exceptions (bytecode minimum >default [>at_minimum >afterwards])]))
-
- #.None
- (exception.throw ..invalid_tableswitch []))))
- []]]))))))
-
-(exception: #export invalid_lookupswitch)
-
-(def: #export (lookupswitch default cases)
- (-> Label (List [S4 Label]) (Bytecode Any))
- (let [cases (list.sort (function (_ [left _] [right _])
- (i.< (//signed.value left)
- (//signed.value right)))
- cases)
- [estimator bytecode] _.lookupswitch]
- (function (_ [pool environment tracker])
- (do try.monad
- [environment' (|> environment
- (/environment.consumes $1))
- actual (/environment.stack environment')
- program_counter' (step (estimator (list.size cases)) (get@ #program_counter tracker))]
- (wrap (let [@from (get@ #program_counter tracker)]
- [[pool
- environment'
- (|> (list\fold (..acknowledge_label actual) tracker (list& default (list\map product.right cases)))
- (set@ #program_counter program_counter'))]
- [(function (_ resolver)
- (let [get (: (-> Label (Maybe [Stack (Maybe Address)]))
- (function (_ label)
- (dictionary.get label resolver)))]
- (case (do {! maybe.monad}
- [@default (|> default get (monad.bind ! product.right))
- @cases (|> cases
- (monad.map ! (|>> product.right get))
- (monad.bind ! (monad.map ! product.right)))]
- (wrap [@default @cases]))
- (#.Some [@default @cases])
- (do {! try.monad}
- [>default (\ ! map ..big_jump (..jump @from @default))
- >cases (|> @cases
- (monad.map ! (|>> (..jump @from) (\ ! map ..big_jump)))
- (\ ! map (|>> (list.zip/2 (list\map product.left cases)))))]
- (wrap [..no_exceptions (bytecode >default >cases)]))
-
- #.None
- (exception.throw ..invalid_lookupswitch []))))
- []]]))))))
-
-(def: reflection
- (All [category]
- (-> (Type (<| Return' Value' category)) Text))
- (|>> type.reflection reflection.reflection))
-
-(template [<consumption> <production> <name> <category> <instruction>]
- [(def: #export (<name> class)
- (-> (Type <category>) (Bytecode Any))
- (do ..monad
- [## TODO: Make sure it's impossible to have indexes greater than U2.
- index (..lift (//constant/pool.class (//name.internal (..reflection class))))]
- (..bytecode <consumption> <production> @_ <instruction> [index])))]
-
- [$0 $1 new Class _.new]
- [$1 $1 anewarray Object _.anewarray]
- [$1 $1 checkcast Object _.checkcast]
- [$1 $1 instanceof Object _.instanceof]
- )
-
-(def: #export (iinc register increase)
- (-> Nat U1 (Bytecode Any))
- (do ..monad
- [register (..register register)]
- (..bytecode $0 $0 (/registry.for register) _.iinc [register increase])))
-
-(exception: #export (multiarray_cannot_be_zero_dimensional {class (Type Object)})
- (exception.report ["Class" (..reflection class)]))
-
-(def: #export (multianewarray class dimensions)
- (-> (Type Object) U1 (Bytecode Any))
- (do ..monad
- [_ (: (Bytecode Any)
- (case (|> dimensions //unsigned.value)
- 0 (..throw ..multiarray_cannot_be_zero_dimensional [class])
- _ (wrap [])))
- index (..lift (//constant/pool.class (//name.internal (..reflection class))))]
- (..bytecode (//unsigned.lift/2 dimensions) $1 @_ _.multianewarray [index dimensions])))
-
-(def: (type_size type)
- (-> (Type Return) Nat)
- (cond (is? type.void type)
- 0
-
- (or (is? type.long type)
- (is? type.double type))
- 2
-
- ## else
- 1))
-
-(template [<static?> <name> <instruction> <method>]
- [(def: #export (<name> class method type)
- (-> (Type Class) Text (Type Method) (Bytecode Any))
- (let [[inputs output exceptions] (parser.method type)]
- (do ..monad
- [index (<| ..lift
- (<method> (..reflection class))
- {#//constant/pool.name method
- #//constant/pool.descriptor (type.descriptor type)})
- #let [consumption (|> inputs
- (list\map ..type_size)
- (list\fold n.+ (if <static?> 0 1))
- //unsigned.u1
- try.assume)
- production (|> output ..type_size //unsigned.u1 try.assume)]]
- (..bytecode (//unsigned.lift/2 consumption)
- (//unsigned.lift/2 production)
- @_
- <instruction> [index consumption production]))))]
-
- [#1 invokestatic _.invokestatic //constant/pool.method]
- [#0 invokevirtual _.invokevirtual //constant/pool.method]
- [#0 invokespecial _.invokespecial //constant/pool.method]
- [#0 invokeinterface _.invokeinterface //constant/pool.interface_method]
- )
-
-(template [<consumption> <name> <1> <2>]
- [(def: #export (<name> class field type)
- (-> (Type Class) Text (Type Value) (Bytecode Any))
- (do ..monad
- [index (<| ..lift
- (//constant/pool.field (..reflection class))
- {#//constant/pool.name field
- #//constant/pool.descriptor (type.descriptor type)})]
- (if (or (is? type.long type)
- (is? type.double type))
- (..bytecode <consumption> $2 @_ <2> [index])
- (..bytecode <consumption> $1 @_ <1> [index]))))]
-
- [$0 getstatic _.getstatic/1 _.getstatic/2]
- [$1 putstatic _.putstatic/1 _.putstatic/2]
- [$1 getfield _.getfield/1 _.getfield/2]
- [$2 putfield _.putfield/1 _.putfield/2]
- )
-
-(exception: #export (invalid_range_for_try {start Address} {end Address})
- (exception.report
- ["Start" (|> start /address.value //unsigned.value %.nat)]
- ["End" (|> end /address.value //unsigned.value %.nat)]))
-
-(def: #export (try @start @end @handler catch)
- (-> Label Label Label (Type Class) (Bytecode Any))
- (do ..monad
- [@catch (..lift (//constant/pool.class (//name.internal (..reflection catch))))]
- (function (_ [pool environment tracker])
- (#try.Success
- [[pool
- environment
- (..acknowledge_label /stack.catch @handler tracker)]
- [(function (_ resolver)
- (do try.monad
- [[_ @start] (..resolve_label @start resolver)
- [_ @end] (..resolve_label @end resolver)
- _ (if (/address.after? @start @end)
- (wrap [])
- (exception.throw ..invalid_range_for_try [@start @end]))
- [_ @handler] (..resolve_label @handler resolver)]
- (wrap [(row.row {#//exception.start @start
- #//exception.end @end
- #//exception.handler @handler
- #//exception.catch @catch})
- _.empty])))
- []]]))))
-
-(def: #export (compose pre post)
- (All [pre post]
- (-> (Bytecode pre) (Bytecode post) (Bytecode post)))
- (do ..monad
- [_ pre]
- post))
diff --git a/stdlib/source/lux/target/jvm/bytecode/address.lux b/stdlib/source/lux/target/jvm/bytecode/address.lux
deleted file mode 100644
index b158bbd05..000000000
--- a/stdlib/source/lux/target/jvm/bytecode/address.lux
+++ /dev/null
@@ -1,73 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]]
- [data
- [format
- [binary (#+ Writer)]]
- [text
- ["%" format (#+ Format)]]]
- [math
- [number
- ["n" nat]]]
- [type
- abstract]]
- ["." // #_
- [jump (#+ Big_Jump)]
- ["/#" // #_
- [encoding
- ["#." unsigned (#+ U2)]
- ["#." signed (#+ S4)]]]])
-
-(abstract: #export Address
- U2
-
- (def: #export value
- (-> Address U2)
- (|>> :representation))
-
- (def: #export start
- Address
- (|> 0 ///unsigned.u2 try.assume :abstraction))
-
- (def: #export (move distance)
- (-> U2 (-> Address (Try Address)))
- (|>> :representation
- (///unsigned.+/2 distance)
- (\ try.functor map (|>> :abstraction))))
-
- (def: with_sign
- (-> Address (Try S4))
- (|>> :representation ///unsigned.value .int ///signed.s4))
-
- (def: #export (jump from to)
- (-> Address Address (Try Big_Jump))
- (do try.monad
- [from (with_sign from)
- to (with_sign to)]
- (///signed.-/4 from to)))
-
- (def: #export (after? reference subject)
- (-> Address Address Bit)
- (n.> (|> reference :representation ///unsigned.value)
- (|> subject :representation ///unsigned.value)))
-
- (implementation: #export equivalence
- (Equivalence Address)
-
- (def: (= reference subject)
- (\ ///unsigned.equivalence =
- (:representation reference)
- (:representation subject))))
-
- (def: #export writer
- (Writer Address)
- (|>> :representation ///unsigned.writer/2))
-
- (def: #export format
- (Format Address)
- (|>> :representation ///unsigned.value %.nat))
- )
diff --git a/stdlib/source/lux/target/jvm/bytecode/environment.lux b/stdlib/source/lux/target/jvm/bytecode/environment.lux
deleted file mode 100644
index 23bcb4558..000000000
--- a/stdlib/source/lux/target/jvm/bytecode/environment.lux
+++ /dev/null
@@ -1,107 +0,0 @@
-(.module:
- [lux (#- Type static)
- [abstract
- [monad (#+ do)]
- [monoid (#+ Monoid)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]]
- [/
- ["/." limit (#+ Limit)
- ["/." stack (#+ Stack)]
- ["/." registry (#+ Registry)]]
- [///
- [encoding
- [unsigned (#+ U2)]]
- [type (#+ Type)
- [category (#+ Method)]]]])
-
-(type: #export Environment
- {#limit Limit
- #stack (Maybe Stack)})
-
-(template [<name> <limit>]
- [(def: #export (<name> type)
- (-> (Type Method) (Try Environment))
- (do try.monad
- [limit (<limit> type)]
- (wrap {#limit limit
- #stack (#.Some /stack.empty)})))]
-
- [static /limit.static]
- [virtual /limit.virtual]
- )
-
-(type: #export Condition
- (-> Environment (Try Environment)))
-
-(implementation: #export monoid
- (Monoid Condition)
-
- (def: identity (|>> #try.Success))
-
- (def: (compose left right)
- (function (_ environment)
- (do try.monad
- [environment (left environment)]
- (right environment)))))
-
-(exception: #export discontinuity)
-
-(def: #export (stack environment)
- (-> Environment (Try Stack))
- (case (get@ #..stack environment)
- (#.Some stack)
- (#try.Success stack)
-
- #.None
- (exception.throw ..discontinuity [])))
-
-(def: #export discontinue
- (-> Environment Environment)
- (set@ #..stack #.None))
-
-(exception: #export (mismatched_stacks {expected Stack}
- {actual Stack})
- (exception.report
- ["Expected" (/stack.format expected)]
- ["Actual" (/stack.format actual)]))
-
-(def: #export (continue expected environment)
- (-> Stack Environment (Try [Stack Environment]))
- (case (get@ #..stack environment)
- (#.Some actual)
- (if (\ /stack.equivalence = expected actual)
- (#try.Success [actual environment])
- (exception.throw ..mismatched_stacks [expected actual]))
-
- #.None
- (#try.Success [expected (set@ #..stack (#.Some expected) environment)])))
-
-(def: #export (consumes amount)
- (-> U2 Condition)
- ## TODO: Revisit this definition once lenses/optics have been implemented,
- ## since it can probably be simplified with them.
- (function (_ environment)
- (do try.monad
- [previous (..stack environment)
- current (/stack.pop amount previous)]
- (wrap (set@ #..stack (#.Some current) environment)))))
-
-(def: #export (produces amount)
- (-> U2 Condition)
- (function (_ environment)
- (do try.monad
- [previous (..stack environment)
- current (/stack.push amount previous)
- #let [limit (|> environment
- (get@ [#..limit #/limit.stack])
- (/stack.max current))]]
- (wrap (|> environment
- (set@ #..stack (#.Some current))
- (set@ [#..limit #/limit.stack] limit))))))
-
-(def: #export (has registry)
- (-> Registry Condition)
- (|>> (update@ [#..limit #/limit.registry] (/registry.has registry))
- #try.Success))
diff --git a/stdlib/source/lux/target/jvm/bytecode/environment/limit.lux b/stdlib/source/lux/target/jvm/bytecode/environment/limit.lux
deleted file mode 100644
index 7c277d4c6..000000000
--- a/stdlib/source/lux/target/jvm/bytecode/environment/limit.lux
+++ /dev/null
@@ -1,57 +0,0 @@
-(.module:
- [lux (#- Type static)
- [abstract
- [monad (#+ do)]
- [equivalence (#+ Equivalence)]]
- [control
- ["." try (#+ Try)]]
- [data
- ["." product]
- ["." format #_
- ["#" binary (#+ Writer) ("#\." monoid)]]]
- [math
- [number
- ["n" nat]]]]
- ["." / #_
- ["#." stack (#+ Stack)]
- ["#." registry (#+ Registry)]
- [////
- [type (#+ Type)
- [category (#+ Method)]]]])
-
-(type: #export Limit
- {#stack Stack
- #registry Registry})
-
-(template [<name> <registry>]
- [(def: #export (<name> type)
- (-> (Type Method) (Try Limit))
- (do try.monad
- [registry (<registry> type)]
- (wrap {#stack /stack.empty
- #registry registry})))]
-
- [static /registry.static]
- [virtual /registry.virtual]
- )
-
-(def: #export length
- ($_ n.+
- ## u2 max_stack;
- /stack.length
- ## u2 max_locals;
- /registry.length))
-
-(def: #export equivalence
- (Equivalence Limit)
- ($_ product.equivalence
- /stack.equivalence
- /registry.equivalence
- ))
-
-(def: #export (writer limit)
- (Writer Limit)
- ($_ format\compose
- (/stack.writer (get@ #stack limit))
- (/registry.writer (get@ #registry limit))
- ))
diff --git a/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux b/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux
deleted file mode 100644
index 9165dfacb..000000000
--- a/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux
+++ /dev/null
@@ -1,90 +0,0 @@
-(.module:
- [lux (#- Type for static)
- [abstract
- ["." equivalence (#+ Equivalence)]]
- [control
- ["." try (#+ Try) ("#\." functor)]]
- [data
- [format
- [binary (#+ Writer)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [math
- [number
- ["n" nat]]]
- [type
- abstract]]
- ["." ///// #_
- [encoding
- ["#." unsigned (#+ U1 U2)]]
- ["#." type (#+ Type)
- [category (#+ Method)]
- ["#/." parser]]])
-
-(type: #export Register U1)
-
-(def: normal 1)
-(def: wide 2)
-
-(abstract: #export Registry
- U2
-
- (def: #export registry
- (-> U2 Registry)
- (|>> :abstraction))
-
- (def: (minimal type)
- (-> (Type Method) Nat)
- (let [[inputs output exceptions] (/////type/parser.method type)]
- (|> inputs
- (list\map (function (_ input)
- (if (or (is? /////type.long input)
- (is? /////type.double input))
- ..wide
- ..normal)))
- (list\fold n.+ 0))))
-
- (template [<start> <name>]
- [(def: #export <name>
- (-> (Type Method) (Try Registry))
- (|>> ..minimal
- (n.+ <start>)
- /////unsigned.u2
- (try\map ..registry)))]
-
- [0 static]
- [1 virtual]
- )
-
- (def: #export equivalence
- (Equivalence Registry)
- (\ equivalence.functor map
- (|>> :representation)
- /////unsigned.equivalence))
-
- (def: #export writer
- (Writer Registry)
- (|>> :representation /////unsigned.writer/2))
-
- (def: #export (has needed)
- (-> Registry Registry Registry)
- (|>> :representation
- (/////unsigned.max/2 (:representation needed))
- :abstraction))
-
- (template [<name> <extra>]
- [(def: #export <name>
- (-> Register Registry)
- (let [extra (|> <extra> /////unsigned.u2 try.assume)]
- (|>> /////unsigned.lift/2
- (/////unsigned.+/2 extra)
- try.assume
- :abstraction)))]
-
- [for ..normal]
- [for_wide ..wide]
- )
- )
-
-(def: #export length
- /////unsigned.bytes/2)
diff --git a/stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux b/stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux
deleted file mode 100644
index e561d2a04..000000000
--- a/stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux
+++ /dev/null
@@ -1,68 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." equivalence (#+ Equivalence)]]
- [control
- ["." try (#+ Try)]]
- [data
- ["." maybe]
- [text
- ["%" format (#+ Format)]]
- [format
- [binary (#+ Writer)]]]
- [type
- abstract]]
- ["." ///// #_
- [encoding
- ["#." unsigned (#+ U2)]]])
-
-(abstract: #export Stack
- U2
-
- (template [<frames> <name>]
- [(def: #export <name>
- Stack
- (|> <frames> /////unsigned.u2 maybe.assume :abstraction))]
-
- [0 empty]
- [1 catch]
- )
-
- (def: #export equivalence
- (Equivalence Stack)
- (\ equivalence.functor map
- (|>> :representation)
- /////unsigned.equivalence))
-
- (def: #export writer
- (Writer Stack)
- (|>> :representation /////unsigned.writer/2))
-
- (def: stack
- (-> U2 Stack)
- (|>> :abstraction))
-
- (template [<op> <name>]
- [(def: #export (<name> amount)
- (-> U2 (-> Stack (Try Stack)))
- (|>> :representation
- (<op> amount)
- (\ try.functor map ..stack)))]
-
- [/////unsigned.+/2 push]
- [/////unsigned.-/2 pop]
- )
-
- (def: #export (max left right)
- (-> Stack Stack Stack)
- (:abstraction
- (/////unsigned.max/2 (:representation left)
- (:representation right))))
-
- (def: #export format
- (Format Stack)
- (|>> :representation /////unsigned.value %.nat))
- )
-
-(def: #export length
- /////unsigned.bytes/2)
diff --git a/stdlib/source/lux/target/jvm/bytecode/instruction.lux b/stdlib/source/lux/target/jvm/bytecode/instruction.lux
deleted file mode 100644
index 718f14199..000000000
--- a/stdlib/source/lux/target/jvm/bytecode/instruction.lux
+++ /dev/null
@@ -1,713 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]
- [monoid (#+ Monoid)]]
- [control
- ["." function]
- ["." try]]
- [data
- ["." product]
- ["." binary]
- ["." format #_
- ["#" binary (#+ Mutation Specification)]]
- [collection
- ["." list]]]
- [macro
- ["." template]]
- [math
- [number (#+ hex)
- ["n" nat]]]
- [type
- abstract]]
- ["." // #_
- ["#." address (#+ Address)]
- ["#." jump (#+ Jump Big_Jump)]
- [environment
- [limit
- [registry (#+ Register)]]]
- ["/#" // #_
- ["#." index (#+ Index)]
- ["#." constant (#+ Class Reference)]
- [encoding
- ["#." unsigned (#+ U1 U2 U4)]
- ["#." signed (#+ S1 S2 S4)]]
- [type
- [category (#+ Value Method)]]]])
-
-(type: #export Size U2)
-
-(type: #export Estimator
- (-> Address Size))
-
-(def: fixed
- (-> Size Estimator)
- function.constant)
-
-(type: #export Instruction
- (-> Specification Specification))
-
-(def: #export empty
- Instruction
- function.identity)
-
-(def: #export run
- (-> Instruction Specification)
- (function.apply format.no_op))
-
-(type: Opcode Nat)
-
-(template [<name> <size>]
- [(def: <name> Size (|> <size> ///unsigned.u2 try.assume))]
-
- [opcode_size 1]
- [register_size 1]
- [byte_size 1]
- [index_size 2]
- [big_jump_size 4]
- [integer_size 4]
- )
-
-(def: (nullary' opcode)
- (-> Opcode Mutation)
- (function (_ [offset binary])
- [(n.+ (///unsigned.value ..opcode_size)
- offset)
- (try.assume
- (binary.write/8 offset opcode binary))]))
-
-(def: nullary
- [Estimator (-> Opcode Instruction)]
- [(..fixed ..opcode_size)
- (function (_ opcode [size mutation])
- [(n.+ (///unsigned.value ..opcode_size)
- size)
- (|>> mutation ((nullary' opcode)))])])
-
-(template [<name> <size>]
- [(def: <name>
- Size
- (|> ..opcode_size
- (///unsigned.+/2 <size>) try.assume))]
-
- [size/1 ..register_size]
- [size/2 ..index_size]
- [size/4 ..big_jump_size]
- )
-
-(template [<shift> <name> <inputT> <writer> <unwrap>]
- [(with_expansions [<private> (template.identifier ["'" <name>])]
- (def: (<private> opcode input0)
- (-> Opcode <inputT> Mutation)
- (function (_ [offset binary])
- [(n.+ (///unsigned.value <shift>) offset)
- (try.assume
- (do try.monad
- [_ (binary.write/8 offset opcode binary)]
- (<writer> (n.+ (///unsigned.value ..opcode_size) offset)
- (<unwrap> input0)
- binary)))]))
-
- (def: <name>
- [Estimator (-> Opcode <inputT> Instruction)]
- [(..fixed <shift>)
- (function (_ opcode input0 [size mutation])
- [(n.+ (///unsigned.value <shift>) size)
- (|>> mutation ((<private> opcode input0)))])]))]
-
- [..size/1 unary/1 U1 binary.write/8 ///unsigned.value]
- [..size/2 unary/2 U2 binary.write/16 ///unsigned.value]
- [..size/2 jump/2 Jump binary.write/16 ///signed.value]
- [..size/4 jump/4 Big_Jump binary.write/32 ///signed.value]
- )
-
-(template [<shift> <name> <inputT> <writer>]
- [(with_expansions [<private> (template.identifier ["'" <name>])]
- (def: (<private> opcode input0)
- (-> Opcode <inputT> Mutation)
- (function (_ [offset binary])
- [(n.+ (///unsigned.value <shift>) offset)
- (try.assume
- (do try.monad
- [_ (binary.write/8 offset opcode binary)]
- (<writer> (n.+ (///unsigned.value ..opcode_size) offset)
- (///signed.value input0)
- binary)))]))
-
- (def: <name>
- [Estimator (-> Opcode <inputT> Instruction)]
- [(..fixed <shift>)
- (function (_ opcode input0 [size mutation])
- [(n.+ (///unsigned.value <shift>) size)
- (|>> mutation ((<private> opcode input0)))])]))]
-
- [..size/1 unary/1' S1 binary.write/8]
- [..size/2 unary/2' S2 binary.write/16]
- )
-
-(def: size/11
- Size
- (|> ..opcode_size
- (///unsigned.+/2 ..register_size) try.assume
- (///unsigned.+/2 ..byte_size) try.assume))
-
-(def: (binary/11' opcode input0 input1)
- (-> Opcode U1 U1 Mutation)
- (function (_ [offset binary])
- [(n.+ (///unsigned.value ..size/11) offset)
- (try.assume
- (do try.monad
- [_ (binary.write/8 offset opcode binary)
- _ (binary.write/8 (n.+ (///unsigned.value ..opcode_size) offset)
- (///unsigned.value input0)
- binary)]
- (binary.write/8 (n.+ (///unsigned.value ..size/1) offset)
- (///unsigned.value input1)
- binary)))]))
-
-(def: binary/11
- [Estimator (-> Opcode U1 U1 Instruction)]
- [(..fixed ..size/11)
- (function (_ opcode input0 input1 [size mutation])
- [(n.+ (///unsigned.value ..size/11) size)
- (|>> mutation ((binary/11' opcode input0 input1)))])])
-
-(def: size/21
- Size
- (|> ..opcode_size
- (///unsigned.+/2 ..index_size) try.assume
- (///unsigned.+/2 ..byte_size) try.assume))
-
-(def: (binary/21' opcode input0 input1)
- (-> Opcode U2 U1 Mutation)
- (function (_ [offset binary])
- [(n.+ (///unsigned.value ..size/21) offset)
- (try.assume
- (do try.monad
- [_ (binary.write/8 offset opcode binary)
- _ (binary.write/16 (n.+ (///unsigned.value ..opcode_size) offset)
- (///unsigned.value input0)
- binary)]
- (binary.write/8 (n.+ (///unsigned.value ..size/2) offset)
- (///unsigned.value input1)
- binary)))]))
-
-(def: binary/21
- [Estimator (-> Opcode U2 U1 Instruction)]
- [(..fixed ..size/21)
- (function (_ opcode input0 input1 [size mutation])
- [(n.+ (///unsigned.value ..size/21) size)
- (|>> mutation ((binary/21' opcode input0 input1)))])])
-
-(def: size/211
- Size
- (|> ..opcode_size
- (///unsigned.+/2 ..index_size) try.assume
- (///unsigned.+/2 ..byte_size) try.assume
- (///unsigned.+/2 ..byte_size) try.assume))
-
-(def: (trinary/211' opcode input0 input1 input2)
- (-> Opcode U2 U1 U1 Mutation)
- (function (_ [offset binary])
- [(n.+ (///unsigned.value ..size/211) offset)
- (try.assume
- (do try.monad
- [_ (binary.write/8 offset opcode binary)
- _ (binary.write/16 (n.+ (///unsigned.value ..opcode_size) offset)
- (///unsigned.value input0)
- binary)
- _ (binary.write/8 (n.+ (///unsigned.value ..size/2) offset)
- (///unsigned.value input1)
- binary)]
- (binary.write/8 (n.+ (///unsigned.value ..size/21) offset)
- (///unsigned.value input2)
- binary)))]))
-
-(def: trinary/211
- [Estimator (-> Opcode U2 U1 U1 Instruction)]
- [(..fixed ..size/211)
- (function (_ opcode input0 input1 input2 [size mutation])
- [(n.+ (///unsigned.value ..size/211) size)
- (|>> mutation ((trinary/211' opcode input0 input1 input2)))])])
-
-(abstract: #export Primitive_Array_Type
- U1
-
- (def: code
- (-> Primitive_Array_Type U1)
- (|>> :representation))
-
- (template [<code> <name>]
- [(def: #export <name> (|> <code> ///unsigned.u1 try.assume :abstraction))]
-
- [04 t_boolean]
- [05 t_char]
- [06 t_float]
- [07 t_double]
- [08 t_byte]
- [09 t_short]
- [10 t_int]
- [11 t_long]
- ))
-
-## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-6.html#jvms-6.5
-(with_expansions [<constants> (template [<code> <name>]
- [[<code> <name> [] []]]
-
- ["01" aconst_null]
-
- ["02" iconst_m1]
- ["03" iconst_0]
- ["04" iconst_1]
- ["05" iconst_2]
- ["06" iconst_3]
- ["07" iconst_4]
- ["08" iconst_5]
-
- ["09" lconst_0]
- ["0A" lconst_1]
-
- ["0B" fconst_0]
- ["0C" fconst_1]
- ["0D" fconst_2]
-
- ["0E" dconst_0]
- ["0F" dconst_1])
- <register_loads> (template [<code> <name>]
- [[<code> <name> [[register Register]] [register]]]
-
- ["15" iload]
- ["16" lload]
- ["17" fload]
- ["18" dload]
- ["19" aload])
- <simple_register_loads> (template [<code> <name>]
- [[<code> <name> [] []]]
-
- ["1A" iload_0]
- ["1B" iload_1]
- ["1C" iload_2]
- ["1D" iload_3]
-
- ["1E" lload_0]
- ["1F" lload_1]
- ["20" lload_2]
- ["21" lload_3]
-
- ["22" fload_0]
- ["23" fload_1]
- ["24" fload_2]
- ["25" fload_3]
-
- ["26" dload_0]
- ["27" dload_1]
- ["28" dload_2]
- ["29" dload_3]
-
- ["2A" aload_0]
- ["2B" aload_1]
- ["2C" aload_2]
- ["2D" aload_3])
- <register_stores> (template [<code> <name>]
- [[<code> <name> [[register Register]] [register]]]
-
- ["36" istore]
- ["37" lstore]
- ["38" fstore]
- ["39" dstore]
- ["3A" astore])
- <simple_register_stores> (template [<code> <name>]
- [[<code> <name> [] []]]
-
- ["3B" istore_0]
- ["3C" istore_1]
- ["3D" istore_2]
- ["3E" istore_3]
-
- ["3F" lstore_0]
- ["40" lstore_1]
- ["41" lstore_2]
- ["42" lstore_3]
-
- ["43" fstore_0]
- ["44" fstore_1]
- ["45" fstore_2]
- ["46" fstore_3]
-
- ["47" dstore_0]
- ["48" dstore_1]
- ["49" dstore_2]
- ["4A" dstore_3]
-
- ["4B" astore_0]
- ["4C" astore_1]
- ["4D" astore_2]
- ["4E" astore_3])
- <array_loads> (template [<code> <name>]
- [[<code> <name> [] []]]
-
- ["2E" iaload]
- ["2F" laload]
- ["30" faload]
- ["31" daload]
- ["32" aaload]
- ["33" baload]
- ["34" caload]
- ["35" saload])
- <array_stores> (template [<code> <name>]
- [[<code> <name> [] []]]
-
- ["4f" iastore]
- ["50" lastore]
- ["51" fastore]
- ["52" dastore]
- ["53" aastore]
- ["54" bastore]
- ["55" castore]
- ["56" sastore])
- <arithmetic> (template [<code> <name>]
- [[<code> <name> [] []]]
-
- ["60" iadd]
- ["64" isub]
- ["68" imul]
- ["6c" idiv]
- ["70" irem]
- ["74" ineg]
- ["78" ishl]
- ["7a" ishr]
- ["7c" iushr]
- ["7e" iand]
- ["80" ior]
- ["82" ixor]
-
- ["61" ladd]
- ["65" lsub]
- ["69" lmul]
- ["6D" ldiv]
- ["71" lrem]
- ["75" lneg]
- ["7F" land]
- ["81" lor]
- ["83" lxor]
-
- ["62" fadd]
- ["66" fsub]
- ["6A" fmul]
- ["6E" fdiv]
- ["72" frem]
- ["76" fneg]
-
- ["63" dadd]
- ["67" dsub]
- ["6B" dmul]
- ["6F" ddiv]
- ["73" drem]
- ["77" dneg])
- <conversions> (template [<code> <name>]
- [[<code> <name> [] []]]
-
- ["88" l2i]
- ["89" l2f]
- ["8A" l2d]
-
- ["8B" f2i]
- ["8C" f2l]
- ["8D" f2d]
-
- ["8E" d2i]
- ["8F" d2l]
- ["90" d2f]
-
- ["85" i2l]
- ["86" i2f]
- ["87" i2d]
- ["91" i2b]
- ["92" i2c]
- ["93" i2s])
- <comparisons> (template [<code> <name>]
- [[<code> <name> [] []]]
-
- ["94" lcmp]
-
- ["95" fcmpl]
- ["96" fcmpg]
-
- ["97" dcmpl]
- ["98" dcmpg])
- <returns> (template [<code> <name>]
- [[<code> <name> [] []]]
-
- ["AC" ireturn]
- ["AD" lreturn]
- ["AE" freturn]
- ["AF" dreturn]
- ["B0" areturn]
- ["B1" return]
- )
- <jumps> (template [<code> <name>]
- [[<code> <name> [[jump Jump]] [jump]]]
-
- ["99" ifeq]
- ["9A" ifne]
- ["9B" iflt]
- ["9C" ifge]
- ["9D" ifgt]
- ["9E" ifle]
-
- ["9F" if_icmpeq]
- ["A0" if_icmpne]
- ["A1" if_icmplt]
- ["A2" if_icmpge]
- ["A3" if_icmpgt]
- ["A4" if_icmple]
-
- ["A5" if_acmpeq]
- ["A6" if_acmpne]
-
- ["A7" goto]
- ["A8" jsr]
-
- ["C6" ifnull]
- ["C7" ifnonnull])
- <fields> (template [<code> <name>]
- [[<code> <name> [[index (Index (Reference Value))]] [(///index.value index)]]]
-
- ["B2" getstatic/1] ["B2" getstatic/2]
- ["B3" putstatic/1] ["B3" putstatic/2]
- ["B4" getfield/1] ["B4" getfield/2]
- ["B5" putfield/1] ["B5" putfield/2])]
- (template [<arity> <definitions>]
- [(with_expansions [<definitions>' (template.splice <definitions>)]
- (template [<code> <name> <instruction_inputs> <arity_inputs>]
- [(with_expansions [<inputs>' (template.splice <instruction_inputs>)
- <input_types> (template [<input_name> <input_type>]
- [<input_type>]
-
- <inputs>')
- <input_names> (template [<input_name> <input_type>]
- [<input_name>]
-
- <inputs>')]
- (def: #export <name>
- [Estimator (-> [<input_types>] Instruction)]
- (let [[estimator <arity>'] <arity>]
- [estimator
- (function (_ [<input_names>])
- (`` (<arity>' (hex <code>) (~~ (template.splice <arity_inputs>)))))])))]
-
- <definitions>'
- ))]
-
- [..nullary
- [["00" nop [] []]
- <constants>
- ["57" pop [] []]
- ["58" pop2 [] []]
- ["59" dup [] []]
- ["5A" dup_x1 [] []]
- ["5B" dup_x2 [] []]
- ["5C" dup2 [] []]
- ["5D" dup2_x1 [] []]
- ["5E" dup2_x2 [] []]
- ["5F" swap [] []]
- <simple_register_loads>
- <array_loads>
- <simple_register_stores>
- <array_stores>
- <arithmetic>
- ["79" lshl [] []]
- ["7B" lshr [] []]
- ["7D" lushr [] []]
- <conversions>
- <comparisons>
- <returns>
- ["BE" arraylength [] []]
- ["BF" athrow [] []]
- ["C2" monitorenter [] []]
- ["C3" monitorexit [] []]]]
-
- [..unary/1
- [["12" ldc [[index U1]] [index]]
- <register_loads>
- <register_stores>
- ["A9" ret [[register Register]] [register]]
- ["BC" newarray [[type Primitive_Array_Type]] [(..code type)]]]]
-
- [..unary/1'
- [["10" bipush [[byte S1]] [byte]]]]
-
- [..unary/2
- [["13" ldc_w/integer [[index (Index ///constant.Integer)]] [(///index.value index)]]
- ["13" ldc_w/float [[index (Index ///constant.Float)]] [(///index.value index)]]
- ["13" ldc_w/string [[index (Index ///constant.String)]] [(///index.value index)]]
- ["14" ldc2_w/long [[index (Index ///constant.Long)]] [(///index.value index)]]
- ["14" ldc2_w/double [[index (Index ///constant.Double)]] [(///index.value index)]]
- <fields>
- ["BB" new [[index (Index Class)]] [(///index.value index)]]
- ["BD" anewarray [[index (Index Class)]] [(///index.value index)]]
- ["C0" checkcast [[index (Index Class)]] [(///index.value index)]]
- ["C1" instanceof [[index (Index Class)]] [(///index.value index)]]
- ["B6" invokevirtual [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index)]]
- ["B7" invokespecial [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index)]]
- ["B8" invokestatic [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index)]]]]
-
- [..unary/2'
- [["11" sipush [[short S2]] [short]]]]
-
- [..jump/2
- [<jumps>]]
-
- [..jump/4
- [["C8" goto_w [[jump Big_Jump]] [jump]]
- ["C9" jsr_w [[jump Big_Jump]] [jump]]]]
-
- [..binary/11
- [["84" iinc [[register Register] [byte U1]] [register byte]]]]
-
- [..binary/21
- [["C5" multianewarray [[index (Index Class)] [count U1]] [(///index.value index) count]]]]
-
- [..trinary/211
- [["B9" invokeinterface [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index) count (try.assume (///unsigned.u1 0))]]]]
- ))
-
-(def: (switch_padding offset)
- (-> Nat Nat)
- (let [parameter_start (n.+ (///unsigned.value ..opcode_size)
- offset)]
- (n.% 4
- (n.- (n.% 4 parameter_start)
- 4))))
-
-(def: #export tableswitch
- [(-> Nat Estimator)
- (-> S4 Big_Jump [Big_Jump (List Big_Jump)] Instruction)]
- (let [estimator (: (-> Nat Estimator)
- (function (_ amount_of_afterwards offset)
- (|> ($_ n.+
- (///unsigned.value ..opcode_size)
- (switch_padding (///unsigned.value (//address.value offset)))
- (///unsigned.value ..big_jump_size)
- (///unsigned.value ..integer_size)
- (///unsigned.value ..integer_size)
- (n.* (///unsigned.value ..big_jump_size)
- (inc amount_of_afterwards)))
- ///unsigned.u2
- try.assume)))]
- [estimator
- (function (_ minimum default [at_minimum afterwards])
- (let [amount_of_afterwards (list.size afterwards)
- estimator (estimator amount_of_afterwards)]
- (function (_ [size mutation])
- (let [padding (switch_padding size)
- tableswitch_size (try.assume
- (do {! try.monad}
- [size (///unsigned.u2 size)]
- (\ ! map (|>> estimator ///unsigned.value)
- (//address.move size //address.start))))
- tableswitch_mutation (: Mutation
- (function (_ [offset binary])
- [(n.+ tableswitch_size offset)
- (try.assume
- (do {! try.monad}
- [amount_of_afterwards (|> amount_of_afterwards .int ///signed.s4)
- maximum (///signed.+/4 minimum amount_of_afterwards)
- _ (binary.write/8 offset (hex "AA") binary)
- #let [offset (n.+ (///unsigned.value ..opcode_size) offset)]
- _ (case padding
- 3 (do !
- [_ (binary.write/8 offset 0 binary)]
- (binary.write/16 (inc offset) 0 binary))
- 2 (binary.write/16 offset 0 binary)
- 1 (binary.write/8 offset 0 binary)
- _ (wrap binary))
- #let [offset (n.+ padding offset)]
- _ (binary.write/32 offset (///signed.value default) binary)
- #let [offset (n.+ (///unsigned.value ..big_jump_size) offset)]
- _ (binary.write/32 offset (///signed.value minimum) binary)
- #let [offset (n.+ (///unsigned.value ..integer_size) offset)]
- _ (binary.write/32 offset (///signed.value maximum) binary)]
- (loop [offset (n.+ (///unsigned.value ..integer_size) offset)
- afterwards (: (List Big_Jump)
- (#.Cons at_minimum afterwards))]
- (case afterwards
- #.Nil
- (wrap binary)
-
- (#.Cons head tail)
- (do !
- [_ (binary.write/32 offset (///signed.value head) binary)]
- (recur (n.+ (///unsigned.value ..big_jump_size) offset)
- tail))))))]))]
- [(n.+ tableswitch_size
- size)
- (|>> mutation tableswitch_mutation)]))))]))
-
-(def: #export lookupswitch
- [(-> Nat Estimator)
- (-> Big_Jump (List [S4 Big_Jump]) Instruction)]
- (let [case_size (n.+ (///unsigned.value ..integer_size)
- (///unsigned.value ..big_jump_size))
- estimator (: (-> Nat Estimator)
- (function (_ amount_of_cases offset)
- (|> ($_ n.+
- (///unsigned.value ..opcode_size)
- (switch_padding (///unsigned.value (//address.value offset)))
- (///unsigned.value ..big_jump_size)
- (///unsigned.value ..integer_size)
- (n.* amount_of_cases case_size))
- ///unsigned.u2
- try.assume)))]
- [estimator
- (function (_ default cases)
- (let [amount_of_cases (list.size cases)
- estimator (estimator amount_of_cases)]
- (function (_ [size mutation])
- (let [padding (switch_padding size)
- lookupswitch_size (try.assume
- (do {! try.monad}
- [size (///unsigned.u2 size)]
- (\ ! map (|>> estimator ///unsigned.value)
- (//address.move size //address.start))))
- lookupswitch_mutation (: Mutation
- (function (_ [offset binary])
- [(n.+ lookupswitch_size offset)
- (try.assume
- (do {! try.monad}
- [_ (binary.write/8 offset (hex "AB") binary)
- #let [offset (n.+ (///unsigned.value ..opcode_size) offset)]
- _ (case padding
- 3 (do !
- [_ (binary.write/8 offset 0 binary)]
- (binary.write/16 (inc offset) 0 binary))
- 2 (binary.write/16 offset 0 binary)
- 1 (binary.write/8 offset 0 binary)
- _ (wrap binary))
- #let [offset (n.+ padding offset)]
- _ (binary.write/32 offset (///signed.value default) binary)
- #let [offset (n.+ (///unsigned.value ..big_jump_size) offset)]
- _ (binary.write/32 offset amount_of_cases binary)]
- (loop [offset (n.+ (///unsigned.value ..integer_size) offset)
- cases cases]
- (case cases
- #.Nil
- (wrap binary)
-
- (#.Cons [value jump] tail)
- (do !
- [_ (binary.write/32 offset (///signed.value value) binary)
- _ (binary.write/32 (n.+ (///unsigned.value ..integer_size) offset) (///signed.value jump) binary)]
- (recur (n.+ case_size offset)
- tail))))))]))]
- [(n.+ lookupswitch_size
- size)
- (|>> mutation lookupswitch_mutation)]))))]))
-
-(implementation: #export monoid
- (Monoid Instruction)
-
- (def: identity ..empty)
-
- (def: (compose left right)
- (|>> left right)))
diff --git a/stdlib/source/lux/target/jvm/bytecode/jump.lux b/stdlib/source/lux/target/jvm/bytecode/jump.lux
deleted file mode 100644
index 4670b07ea..000000000
--- a/stdlib/source/lux/target/jvm/bytecode/jump.lux
+++ /dev/null
@@ -1,26 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- ["." format #_
- ["#" binary (#+ Writer)]]]]
- ["." /// #_
- [encoding
- ["#." signed (#+ S2 S4)]]])
-
-(type: #export Jump S2)
-
-(def: #export equivalence
- (Equivalence Jump)
- ///signed.equivalence)
-
-(def: #export writer
- (Writer Jump)
- ///signed.writer/2)
-
-(type: #export Big_Jump S4)
-
-(def: #export lift
- (-> Jump Big_Jump)
- ///signed.lift/4)
diff --git a/stdlib/source/lux/target/jvm/class.lux b/stdlib/source/lux/target/jvm/class.lux
deleted file mode 100644
index ad90c3db5..000000000
--- a/stdlib/source/lux/target/jvm/class.lux
+++ /dev/null
@@ -1,133 +0,0 @@
- (.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- ["." monad (#+ do)]]
- [control
- ["." state]
- ["." try (#+ Try)]]
- [data
- ["." product]
- [format
- [".F" binary (#+ Writer) ("#\." monoid)]]
- [collection
- ["." row (#+ Row)]]]]
- ["." // #_
- ["#." modifier (#+ Modifier modifiers:)]
- ["#." version (#+ Version Minor Major)]
- ["#." magic (#+ Magic)]
- ["#." index (#+ Index)]
- ["#." attribute (#+ Attribute)]
- ["#." field (#+ Field)]
- ["#." method (#+ Method)]
- [encoding
- ["#." unsigned]
- ["#." name (#+ Internal)]]
- ["#." constant (#+ Constant)
- ["#/." pool (#+ Pool Resource)]]])
-
-(type: #export #rec Class
- {#magic Magic
- #minor_version Minor
- #major_version Major
- #constant_pool Pool
- #modifier (Modifier Class)
- #this (Index //constant.Class)
- #super (Index //constant.Class)
- #interfaces (Row (Index //constant.Class))
- #fields (Row Field)
- #methods (Row Method)
- #attributes (Row Attribute)})
-
-(modifiers: Class
- ["0001" public]
- ["0010" final]
- ["0020" super]
- ["0200" interface]
- ["0400" abstract]
- ["1000" synthetic]
- ["2000" annotation]
- ["4000" enum]
- )
-
-(def: #export equivalence
- (Equivalence Class)
- ($_ product.equivalence
- //unsigned.equivalence
- //unsigned.equivalence
- //unsigned.equivalence
- //constant/pool.equivalence
- //modifier.equivalence
- //index.equivalence
- //index.equivalence
- (row.equivalence //index.equivalence)
- (row.equivalence //field.equivalence)
- (row.equivalence //method.equivalence)
- (row.equivalence //attribute.equivalence)))
-
-(def: (install_classes this super interfaces)
- (-> Internal Internal (List Internal)
- (Resource [(Index //constant.Class) (Index //constant.Class) (Row (Index //constant.Class))]))
- (do {! //constant/pool.monad}
- [@this (//constant/pool.class this)
- @super (//constant/pool.class super)
- @interfaces (: (Resource (Row (Index //constant.Class)))
- (monad.fold ! (function (_ interface @interfaces)
- (do !
- [@interface (//constant/pool.class interface)]
- (wrap (row.add @interface @interfaces))))
- row.empty
- interfaces))]
- (wrap [@this @super @interfaces])))
-
-(def: #export (class version modifier
- this super interfaces
- fields methods attributes)
- (-> Major (Modifier Class)
- Internal Internal (List Internal)
- (List (Resource Field))
- (List (Resource Method))
- (Row Attribute)
- (Try Class))
- (do try.monad
- [[pool [@this @super @interfaces] =fields =methods]
- (<| (state.run' //constant/pool.empty)
- (do //constant/pool.monad
- [classes (install_classes this super interfaces)
- =fields (monad.seq //constant/pool.monad fields)
- =methods (monad.seq //constant/pool.monad methods)]
- (wrap [classes =fields =methods])))]
- (wrap {#magic //magic.code
- #minor_version //version.default_minor
- #major_version version
- #constant_pool pool
- #modifier modifier
- #this @this
- #super @super
- #interfaces @interfaces
- #fields (row.from_list =fields)
- #methods (row.from_list =methods)
- #attributes attributes})))
-
-(def: #export (writer class)
- (Writer Class)
- (`` ($_ binaryF\compose
- (~~ (template [<writer> <slot>]
- [(<writer> (get@ <slot> class))]
-
- [//magic.writer #magic]
- [//version.writer #minor_version]
- [//version.writer #major_version]
- [//constant/pool.writer #constant_pool]
- [//modifier.writer #modifier]
- [//index.writer #this]
- [//index.writer #super]))
- (~~ (template [<writer> <slot>]
- [((binaryF.row/16 <writer>) (get@ <slot> class))]
-
- [//index.writer #interfaces]
- [//field.writer #fields]
- [//method.writer #methods]
- [//attribute.writer #attributes]
- ))
- )))
diff --git a/stdlib/source/lux/target/jvm/constant.lux b/stdlib/source/lux/target/jvm/constant.lux
deleted file mode 100644
index 651f667ee..000000000
--- a/stdlib/source/lux/target/jvm/constant.lux
+++ /dev/null
@@ -1,245 +0,0 @@
-(.module:
- [lux #*
- ["." ffi (#+ import:)]
- ["@" target]
- [abstract
- [monad (#+ do)]
- ["." equivalence (#+ Equivalence)]]
- [data
- ["." sum]
- ["." product]
- ["." text]
- [format
- [".F" binary (#+ Writer) ("#\." monoid)]]
- [collection
- ["." row (#+ Row)]]]
- [macro
- ["." template]]
- [math
- [number
- ["." i32 (#+ I32)]
- ["." i64]
- ["." int]
- ["." frac]]]
- [type
- abstract]]
- ["." / #_
- ["#." tag]
- ["/#" // #_
- ["#." index (#+ Index)]
- [type
- ["#." category]
- ["#." descriptor (#+ Descriptor)]]
- [encoding
- ["#." unsigned]]]])
-
-(type: #export UTF8 Text)
-
-(def: utf8_writer
- (Writer UTF8)
- binaryF.utf8/16)
-
-(abstract: #export Class
- (Index UTF8)
-
- (def: #export index
- (-> Class (Index UTF8))
- (|>> :representation))
-
- (def: #export class
- (-> (Index UTF8) Class)
- (|>> :abstraction))
-
- (def: #export class_equivalence
- (Equivalence Class)
- (\ equivalence.functor map
- ..index
- //index.equivalence))
-
- (def: class_writer
- (Writer Class)
- (|>> :representation //index.writer))
- )
-
-(import: java/lang/Float
- ["#::."
- (#static floatToRawIntBits #manual [float] int)])
-
-(implementation: #export float_equivalence
- (Equivalence java/lang/Float)
-
- (def: (= parameter subject)
- (for {@.old
- ("jvm feq" parameter subject)
-
- @.jvm
- ("jvm float ="
- ("jvm object cast" parameter)
- ("jvm object cast" subject))})))
-
-(import: java/lang/Double
- ["#::."
- (#static doubleToRawLongBits [double] long)])
-
-(abstract: #export (Value kind)
- kind
-
- (def: #export value
- (All [kind] (-> (Value kind) kind))
- (|>> :representation))
-
- (def: #export (value_equivalence Equivalence<kind>)
- (All [kind]
- (-> (Equivalence kind)
- (Equivalence (Value kind))))
- (\ equivalence.functor map
- (|>> :representation)
- Equivalence<kind>))
-
- (template [<constructor> <type> <marker>]
- [(type: #export <type> (Value <marker>))
-
- (def: #export <constructor>
- (-> <marker> <type>)
- (|>> :abstraction))]
-
- [integer Integer I32]
- [float Float java/lang/Float]
- [long Long .Int]
- [double Double Frac]
- [string String (Index UTF8)]
- )
-
- (template [<writer_name> <type> <write> <writer>]
- [(def: <writer_name>
- (Writer <type>)
- (`` (|>> :representation
- (~~ (template.splice <write>))
- (~~ (template.splice <writer>)))))]
-
- [integer_writer Integer [] [binaryF.bits/32]]
- [float_writer Float [java/lang/Float::floatToRawIntBits ffi.int_to_long (:as I64)] [i32.i32 binaryF.bits/32]]
- [long_writer Long [] [binaryF.bits/64]]
- [double_writer Double [java/lang/Double::doubleToRawLongBits] [binaryF.bits/64]]
- [string_writer String [] [//index.writer]]
- )
- )
-
-(type: #export (Name_And_Type of)
- {#name (Index UTF8)
- #descriptor (Index (Descriptor of))})
-
-(type: #export (Reference of)
- {#class (Index Class)
- #name_and_type (Index (Name_And_Type of))})
-
-(template [<type> <equivalence> <writer>]
- [(def: #export <equivalence>
- (Equivalence (<type> Any))
- ($_ product.equivalence
- //index.equivalence
- //index.equivalence))
-
- (def: <writer>
- (Writer (<type> Any))
- ($_ binaryF.and
- //index.writer
- //index.writer))]
-
- [Name_And_Type name_and_type_equivalence name_and_type_writer]
- [Reference reference_equivalence reference_writer]
- )
-
-(type: #export Constant
- (#UTF8 UTF8)
- (#Integer Integer)
- (#Float Float)
- (#Long Long)
- (#Double Double)
- (#Class Class)
- (#String String)
- (#Field (Reference //category.Value))
- (#Method (Reference //category.Method))
- (#Interface_Method (Reference //category.Method))
- (#Name_And_Type (Name_And_Type Any)))
-
-(def: #export (size constant)
- (-> Constant Nat)
- (case constant
- (^or (#Long _) (#Double _))
- 2
-
- _
- 1))
-
-(def: #export equivalence
- (Equivalence Constant)
- ## TODO: Delete the explicit "implementation" and use the combinator
- ## version below as soon as the new format for variants is implemented.
- (implementation
- (def: (= reference sample)
- (case [reference sample]
- (^template [<tag> <equivalence>]
- [[(<tag> reference) (<tag> sample)]
- (\ <equivalence> = reference sample)])
- ([#UTF8 text.equivalence]
- [#Integer (..value_equivalence i32.equivalence)]
- [#Long (..value_equivalence int.equivalence)]
- [#Float (..value_equivalence float_equivalence)]
- [#Double (..value_equivalence frac.equivalence)]
- [#Class ..class_equivalence]
- [#String (..value_equivalence //index.equivalence)]
- [#Field ..reference_equivalence]
- [#Method ..reference_equivalence]
- [#Interface_Method ..reference_equivalence]
- [#Name_And_Type ..name_and_type_equivalence])
-
- _
- false)))
- ## ($_ sum.equivalence
- ## ## #UTF8
- ## text.equivalence
- ## ## #Long
- ## (..value_equivalence int.equivalence)
- ## ## #Double
- ## (..value_equivalence frac.equivalence)
- ## ## #Class
- ## ..class_equivalence
- ## ## #String
- ## (..value_equivalence //index.equivalence)
- ## ## #Field
- ## ..reference_equivalence
- ## ## #Method
- ## ..reference_equivalence
- ## ## #Interface_Method
- ## ..reference_equivalence
- ## ## #Name_And_Type
- ## ..name_and_type_equivalence
- ## )
- )
-
-(def: #export writer
- (Writer Constant)
- (with_expansions [<constants> (as_is [#UTF8 /tag.utf8 ..utf8_writer]
- [#Integer /tag.integer ..integer_writer]
- [#Float /tag.float ..float_writer]
- [#Long /tag.long ..long_writer]
- [#Double /tag.double ..double_writer]
- [#Class /tag.class ..class_writer]
- [#String /tag.string ..string_writer]
- [#Field /tag.field ..reference_writer]
- [#Method /tag.method ..reference_writer]
- [#Interface_Method /tag.interface_method ..reference_writer]
- [#Name_And_Type /tag.name_and_type ..name_and_type_writer]
- ## TODO: Method_Handle
- ## TODO: Method_Type
- ## TODO: Invoke_Dynamic
- )]
- (function (_ value)
- (case value
- (^template [<case> <tag> <writer>]
- [(<case> value)
- (binaryF\compose (/tag.writer <tag>)
- (<writer> value))])
- (<constants>)
- ))))
diff --git a/stdlib/source/lux/target/jvm/constant/pool.lux b/stdlib/source/lux/target/jvm/constant/pool.lux
deleted file mode 100644
index 8f378ed00..000000000
--- a/stdlib/source/lux/target/jvm/constant/pool.lux
+++ /dev/null
@@ -1,157 +0,0 @@
-(.module:
- [lux #*
- ["." ffi]
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ Monad do)]]
- [control
- ["." state (#+ State')]
- ["." try (#+ Try)]]
- [data
- ["." product]
- ["." text]
- ["." format #_
- ["#" binary (#+ Writer) ("specification\." monoid)]]
- [collection
- ["." row (#+ Row) ("#\." fold)]]]
- [macro
- ["." template]]
- [math
- [number
- ["." i32]
- ["n" nat]
- ["." int]
- ["." frac]]]
- [type
- abstract]]
- ["." // (#+ UTF8 String Class Integer Float Long Double Constant Name_And_Type Reference)
- [//
- [encoding
- ["#." name (#+ Internal External)]
- ["#." unsigned]]
- ["#." index (#+ Index)]
- [type
- [category (#+ Value Method)]
- ["#." descriptor (#+ Descriptor)]]]])
-
-(type: #export Pool [Index (Row [Index Constant])])
-
-(def: #export equivalence
- (Equivalence Pool)
- (product.equivalence //index.equivalence
- (row.equivalence (product.equivalence //index.equivalence
- //.equivalence))))
-
-(type: #export (Resource a)
- (State' Try Pool a))
-
-(def: #export monad
- (Monad Resource)
- (state.with try.monad))
-
-(template: (!add <tag> <equivalence> <value>)
- (function (_ [current pool])
- (let [<value>' <value>]
- (with_expansions [<try_again> (as_is (recur (.inc idx)))]
- (loop [idx 0]
- (case (row.nth idx pool)
- (#try.Success entry)
- (case entry
- [index (<tag> reference)]
- (if (\ <equivalence> = reference <value>')
- (#try.Success [[current pool]
- index])
- <try_again>)
-
- _
- <try_again>)
-
- (#try.Failure _)
- (let [new (<tag> <value>')]
- (do {! try.monad}
- [@new (//unsigned.u2 (//.size new))
- next (: (Try Index)
- (|> current
- //index.value
- (//unsigned.+/2 @new)
- (\ ! map //index.index)))]
- (wrap [[next
- (row.add [current new] pool)]
- current])))))))))
-
-(template: (!index <index>)
- (|> <index> //index.value //unsigned.value))
-
-(type: (Adder of)
- (-> of (Resource (Index of))))
-
-(template [<name> <type> <tag> <equivalence>]
- [(def: #export (<name> value)
- (Adder <type>)
- (!add <tag> <equivalence> value))]
-
- [integer Integer #//.Integer (//.value_equivalence i32.equivalence)]
- [float Float #//.Float (//.value_equivalence //.float_equivalence)]
- [long Long #//.Long (//.value_equivalence int.equivalence)]
- [double Double #//.Double (//.value_equivalence frac.equivalence)]
- [utf8 UTF8 #//.UTF8 text.equivalence]
- )
-
-(def: #export (string value)
- (-> Text (Resource (Index String)))
- (do ..monad
- [@value (utf8 value)
- #let [value (//.string @value)]]
- (!add #//.String (//.value_equivalence //index.equivalence) value)))
-
-(def: #export (class name)
- (-> Internal (Resource (Index Class)))
- (do ..monad
- [@name (utf8 (//name.read name))
- #let [value (//.class @name)]]
- (!add #//.Class //.class_equivalence value)))
-
-(def: #export (descriptor value)
- (All [kind]
- (-> (Descriptor kind)
- (Resource (Index (Descriptor kind)))))
- (let [value (//descriptor.descriptor value)]
- (!add #//.UTF8 text.equivalence value)))
-
-(type: #export (Member of)
- {#name UTF8
- #descriptor (Descriptor of)})
-
-(def: #export (name_and_type [name descriptor])
- (All [of]
- (-> (Member of) (Resource (Index (Name_And_Type of)))))
- (do ..monad
- [@name (utf8 name)
- @descriptor (..descriptor descriptor)]
- (!add #//.Name_And_Type //.name_and_type_equivalence {#//.name @name #//.descriptor @descriptor})))
-
-(template [<name> <tag> <of>]
- [(def: #export (<name> class member)
- (-> External (Member <of>) (Resource (Index (Reference <of>))))
- (do ..monad
- [@class (..class (//name.internal class))
- @name_and_type (name_and_type member)]
- (!add <tag> //.reference_equivalence {#//.class @class #//.name_and_type @name_and_type})))]
-
- [field #//.Field Value]
- [method #//.Method Method]
- [interface_method #//.Interface_Method Method]
- )
-
-(def: #export writer
- (Writer Pool)
- (function (_ [next pool])
- (row\fold (function (_ [_index post] pre)
- (specification\compose pre (//.writer post)))
- (format.bits/16 (!index next))
- pool)))
-
-(def: #export empty
- Pool
- [(|> 1 //unsigned.u2 try.assume //index.index)
- row.empty])
diff --git a/stdlib/source/lux/target/jvm/constant/tag.lux b/stdlib/source/lux/target/jvm/constant/tag.lux
deleted file mode 100644
index 011e38374..000000000
--- a/stdlib/source/lux/target/jvm/constant/tag.lux
+++ /dev/null
@@ -1,49 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]
- [control
- ["." try]]
- [data
- [format
- [binary (#+ Writer)]]]
- [type
- abstract]]
- ["." /// #_
- [encoding
- ["#." unsigned (#+ U1) ("u1//." equivalence)]]])
-
-(abstract: #export Tag
- U1
-
- (implementation: #export equivalence
- (Equivalence Tag)
- (def: (= reference sample)
- (u1//= (:representation reference)
- (:representation sample))))
-
- (template [<code> <name>]
- [(def: #export <name>
- Tag
- (|> <code> ///unsigned.u1 try.assume :abstraction))]
-
- [01 utf8]
- [03 integer]
- [04 float]
- [05 long]
- [06 double]
- [07 class]
- [08 string]
- [09 field]
- [10 method]
- [11 interface_method]
- [12 name_and_type]
- [15 method_handle]
- [16 method_type]
- [18 invoke_dynamic]
- )
-
- (def: #export writer
- (Writer Tag)
- (|>> :representation ///unsigned.writer/1))
- )
diff --git a/stdlib/source/lux/target/jvm/encoding/name.lux b/stdlib/source/lux/target/jvm/encoding/name.lux
deleted file mode 100644
index 606c7439c..000000000
--- a/stdlib/source/lux/target/jvm/encoding/name.lux
+++ /dev/null
@@ -1,39 +0,0 @@
-(.module:
- [lux #*
- [data
- ["." text
- ["%" format (#+ format)]]]
- [type
- abstract]])
-
-(def: #export internal_separator "/")
-(def: #export external_separator ".")
-
-(type: #export External Text)
-
-(abstract: #export Internal
- Text
-
- (def: #export internal
- (-> External Internal)
- (|>> (text.replace_all ..external_separator
- ..internal_separator)
- :abstraction))
-
- (def: #export read
- (-> Internal Text)
- (|>> :representation))
-
- (def: #export external
- (-> Internal External)
- (|>> :representation
- (text.replace_all ..internal_separator
- ..external_separator))))
-
-(def: #export sanitize
- (-> Text External)
- (|>> ..internal ..external))
-
-(def: #export (qualify package class)
- (-> Text External External)
- (format (..sanitize package) ..external_separator class))
diff --git a/stdlib/source/lux/target/jvm/encoding/signed.lux b/stdlib/source/lux/target/jvm/encoding/signed.lux
deleted file mode 100644
index 934d48ce2..000000000
--- a/stdlib/source/lux/target/jvm/encoding/signed.lux
+++ /dev/null
@@ -1,106 +0,0 @@
-(.module:
- [lux (#- int)
- [abstract
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- [text
- ["%" format (#+ format)]]
- ["." format #_
- ["#" binary (#+ Writer)]]]
- [macro
- ["." template]]
- [math
- [number
- ["." i64]
- ["n" nat]
- ["i" int]]]
- [type
- abstract]])
-
-(abstract: #export (Signed brand)
- Int
-
- (def: #export value
- (-> (Signed Any) Int)
- (|>> :representation))
-
- (implementation: #export equivalence
- (All [brand] (Equivalence (Signed brand)))
- (def: (= reference sample)
- (i.= (:representation reference) (:representation sample))))
-
- (implementation: #export order
- (All [brand] (Order (Signed brand)))
-
- (def: &equivalence ..equivalence)
- (def: (< reference sample)
- (i.< (:representation reference) (:representation sample))))
-
- (exception: #export (value_exceeds_the_scope {value Int}
- {scope Nat})
- (exception.report
- ["Value" (%.int value)]
- ["Scope (in bytes)" (%.nat scope)]))
-
- (template [<bytes> <name> <size> <constructor> <maximum> <+> <->]
- [(with_expansions [<raw> (template.identifier [<name> "'"])]
- (abstract: #export <raw> Any)
- (type: #export <name> (Signed <raw>)))
-
- (def: #export <size> <bytes>)
-
- (def: #export <maximum>
- <name>
- (|> <bytes> (n.* i64.bits_per_byte) dec i64.mask :abstraction))
-
- (def: #export <constructor>
- (-> Int (Try <name>))
- (let [positive (|> <bytes> (n.* i64.bits_per_byte) i64.mask)
- negative (|> positive .int (i.right_shift 1) i64.not)]
- (function (_ value)
- (if (i.= (if (i.< +0 value)
- (i64.or negative value)
- (i64.and positive value))
- value)
- (#try.Success (:abstraction value))
- (exception.throw ..value_exceeds_the_scope [value <size>])))))
-
- (template [<abstract_operation> <concrete_operation>]
- [(def: #export (<abstract_operation> parameter subject)
- (-> <name> <name> (Try <name>))
- (<constructor>
- (<concrete_operation> (:representation parameter)
- (:representation subject))))]
-
- [<+> i.+]
- [<-> i.-]
- )]
-
- [1 S1 bytes/1 s1 maximum/1 +/1 -/1]
- [2 S2 bytes/2 s2 maximum/2 +/2 -/2]
- [4 S4 bytes/4 s4 maximum/4 +/4 -/4]
- )
-
- (template [<name> <from> <to>]
- [(def: #export <name>
- (-> <from> <to>)
- (|>> :transmutation))]
-
- [lift/2 S1 S2]
- [lift/4 S2 S4]
- )
-
- (template [<writer_name> <type> <writer>]
- [(def: #export <writer_name>
- (Writer <type>)
- (|>> :representation <writer>))]
-
- [writer/1 S1 format.bits/8]
- [writer/2 S2 format.bits/16]
- [writer/4 S4 format.bits/32]
- )
- )
diff --git a/stdlib/source/lux/target/jvm/encoding/unsigned.lux b/stdlib/source/lux/target/jvm/encoding/unsigned.lux
deleted file mode 100644
index 4cff01d68..000000000
--- a/stdlib/source/lux/target/jvm/encoding/unsigned.lux
+++ /dev/null
@@ -1,120 +0,0 @@
-(.module:
- [lux (#- nat)
- [abstract
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- [text
- ["%" format (#+ format)]]
- ["." format #_
- ["#" binary (#+ Writer)]]]
- [macro
- ["." template]]
- [math
- [number
- ["n" nat]
- ["." i64]]]
- [type
- abstract]])
-
-(abstract: #export (Unsigned brand)
- Nat
-
- (def: #export value
- (-> (Unsigned Any) Nat)
- (|>> :representation))
-
- (implementation: #export equivalence
- (All [brand] (Equivalence (Unsigned brand)))
- (def: (= reference sample)
- (n.= (:representation reference)
- (:representation sample))))
-
- (implementation: #export order
- (All [brand] (Order (Unsigned brand)))
-
- (def: &equivalence ..equivalence)
- (def: (< reference sample)
- (n.< (:representation reference)
- (:representation sample))))
-
- (exception: #export (value_exceeds_the_maximum {type Name}
- {value Nat}
- {maximum (Unsigned Any)})
- (exception.report
- ["Type" (%.name type)]
- ["Value" (%.nat value)]
- ["Maximum" (%.nat (:representation maximum))]))
-
- (exception: #export [brand] (subtraction_cannot_yield_negative_value
- {type Name}
- {parameter (Unsigned brand)}
- {subject (Unsigned brand)})
- (exception.report
- ["Type" (%.name type)]
- ["Parameter" (%.nat (:representation parameter))]
- ["Subject" (%.nat (:representation subject))]))
-
- (template [<bytes> <name> <size> <constructor> <maximum> <+> <-> <max>]
- [(with_expansions [<raw> (template.identifier [<name> "'"])]
- (abstract: #export <raw> Any)
- (type: #export <name> (Unsigned <raw>)))
-
- (def: #export <size> <bytes>)
-
- (def: #export <maximum>
- <name>
- (|> <bytes> (n.* i64.bits_per_byte) i64.mask :abstraction))
-
- (def: #export (<constructor> value)
- (-> Nat (Try <name>))
- (if (n.<= (:representation <maximum>) value)
- (#try.Success (:abstraction value))
- (exception.throw ..value_exceeds_the_maximum [(name_of <name>) value <maximum>])))
-
- (def: #export (<+> parameter subject)
- (-> <name> <name> (Try <name>))
- (<constructor>
- (n.+ (:representation parameter)
- (:representation subject))))
-
- (def: #export (<-> parameter subject)
- (-> <name> <name> (Try <name>))
- (let [parameter' (:representation parameter)
- subject' (:representation subject)]
- (if (n.<= subject' parameter')
- (#try.Success (:abstraction (n.- parameter' subject')))
- (exception.throw ..subtraction_cannot_yield_negative_value [(name_of <name>) parameter subject]))))
-
- (def: #export (<max> left right)
- (-> <name> <name> <name>)
- (:abstraction (n.max (:representation left)
- (:representation right))))]
-
- [1 U1 bytes/1 u1 maximum/1 +/1 -/1 max/1]
- [2 U2 bytes/2 u2 maximum/2 +/2 -/2 max/2]
- [4 U4 bytes/4 u4 maximum/4 +/4 -/4 max/4]
- )
-
- (template [<name> <from> <to>]
- [(def: #export <name>
- (-> <from> <to>)
- (|>> :transmutation))]
-
- [lift/2 U1 U2]
- [lift/4 U2 U4]
- )
-
- (template [<writer_name> <type> <writer>]
- [(def: #export <writer_name>
- (Writer <type>)
- (|>> :representation <writer>))]
-
- [writer/1 U1 format.bits/8]
- [writer/2 U2 format.bits/16]
- [writer/4 U4 format.bits/32]
- )
- )
diff --git a/stdlib/source/lux/target/jvm/field.lux b/stdlib/source/lux/target/jvm/field.lux
deleted file mode 100644
index 2e8863f57..000000000
--- a/stdlib/source/lux/target/jvm/field.lux
+++ /dev/null
@@ -1,69 +0,0 @@
-(.module:
- [lux (#- Type static)
- [abstract
- [equivalence (#+ Equivalence)]
- ["." monad (#+ do)]]
- [data
- ["." product]
- [format
- [".F" binary (#+ Writer) ("#\." monoid)]]
- [collection
- ["." row (#+ Row)]]]]
- ["." // #_
- ["." modifier (#+ Modifier modifiers:)]
- ["#." constant (#+ UTF8)
- ["#/." pool (#+ Pool Resource)]]
- ["#." index (#+ Index)]
- ["#." attribute (#+ Attribute)]
- ["#." type (#+ Type)
- [category (#+ Value)]
- [descriptor (#+ Descriptor)]]])
-
-(type: #export #rec Field
- {#modifier (Modifier Field)
- #name (Index UTF8)
- #descriptor (Index (Descriptor Value))
- #attributes (Row Attribute)})
-
-(modifiers: Field
- ["0001" public]
- ["0002" private]
- ["0004" protected]
- ["0008" static]
- ["0010" final]
- ["0040" volatile]
- ["0080" transient]
- ["1000" synthetic]
- ["4000" enum]
- )
-
-(def: #export equivalence
- (Equivalence Field)
- ($_ product.equivalence
- modifier.equivalence
- //index.equivalence
- //index.equivalence
- (row.equivalence //attribute.equivalence)))
-
-(def: #export (writer field)
- (Writer Field)
- (`` ($_ binaryF\compose
- (~~ (template [<writer> <slot>]
- [(<writer> (get@ <slot> field))]
-
- [modifier.writer #modifier]
- [//index.writer #name]
- [//index.writer #descriptor]
- [(binaryF.row/16 //attribute.writer) #attributes]))
- )))
-
-(def: #export (field modifier name type attributes)
- (-> (Modifier Field) UTF8 (Type Value) (Row Attribute)
- (Resource Field))
- (do //constant/pool.monad
- [@name (//constant/pool.utf8 name)
- @descriptor (//constant/pool.descriptor (//type.descriptor type))]
- (wrap {#modifier modifier
- #name @name
- #descriptor @descriptor
- #attributes attributes})))
diff --git a/stdlib/source/lux/target/jvm/index.lux b/stdlib/source/lux/target/jvm/index.lux
deleted file mode 100644
index c4f0ec9d1..000000000
--- a/stdlib/source/lux/target/jvm/index.lux
+++ /dev/null
@@ -1,37 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." equivalence (#+ Equivalence)]]
- [data
- [format
- [binary (#+ Writer)]]]
- [type
- abstract]]
- ["." // #_
- [encoding
- ["#." unsigned (#+ U2)]]])
-
-(def: #export length
- //unsigned.bytes/2)
-
-(abstract: #export (Index kind)
- U2
-
- (def: #export index
- (All [kind] (-> U2 (Index kind)))
- (|>> :abstraction))
-
- (def: #export value
- (-> (Index Any) U2)
- (|>> :representation))
-
- (def: #export equivalence
- (All [kind] (Equivalence (Index kind)))
- (\ equivalence.functor map
- ..value
- //unsigned.equivalence))
-
- (def: #export writer
- (All [kind] (Writer (Index kind)))
- (|>> :representation //unsigned.writer/2))
- )
diff --git a/stdlib/source/lux/target/jvm/loader.lux b/stdlib/source/lux/target/jvm/loader.lux
deleted file mode 100644
index 4ca391382..000000000
--- a/stdlib/source/lux/target/jvm/loader.lux
+++ /dev/null
@@ -1,142 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." io (#+ IO)]
- [concurrency
- ["." atom (#+ Atom)]]]
- [data
- ["." binary (#+ Binary)]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." array]
- ["." dictionary (#+ Dictionary)]]]
- ["." ffi (#+ import: object do_to)]])
-
-(type: #export Library
- (Atom (Dictionary Text Binary)))
-
-(exception: #export (already_stored {class Text})
- (exception.report
- ["Class" class]))
-
-(exception: #export (unknown {class Text} {known_classes (List Text)})
- (exception.report
- ["Class" class]
- ["Known classes" (exception.enumerate (|>>) known_classes)]))
-
-(exception: #export (cannot_define {class Text} {error Text})
- (exception.report
- ["Class" class]
- ["Error" error]))
-
-(import: java/lang/Object
- ["#::."
- (getClass [] (java/lang/Class java/lang/Object))])
-
-(import: java/lang/String)
-
-(import: java/lang/reflect/Method
- ["#::."
- (invoke [java/lang/Object [java/lang/Object]] #try java/lang/Object)])
-
-(import: (java/lang/Class a)
- ["#::."
- (getDeclaredMethod [java/lang/String [(java/lang/Class [? < java/lang/Object])]] java/lang/reflect/Method)])
-
-(import: java/lang/Integer
- ["#::."
- (#static TYPE (java/lang/Class java/lang/Integer))])
-
-(import: java/lang/reflect/AccessibleObject
- ["#::."
- (setAccessible [boolean] void)])
-
-(import: java/lang/ClassLoader
- ["#::."
- (loadClass [java/lang/String]
- #io #try (java/lang/Class java/lang/Object))])
-
-(with_expansions [<elemT> (as_is (java/lang/Class java/lang/Object))]
- (def: java/lang/ClassLoader::defineClass
- java/lang/reflect/Method
- (let [signature (|> (ffi.array <elemT> 4)
- (ffi.array_write 0 (:as <elemT>
- (ffi.class_for java/lang/String)))
- (ffi.array_write 1 (java/lang/Object::getClass (ffi.array byte 0)))
- (ffi.array_write 2 (:as <elemT>
- (java/lang/Integer::TYPE)))
- (ffi.array_write 3 (:as <elemT>
- (java/lang/Integer::TYPE))))]
- (do_to (java/lang/Class::getDeclaredMethod "defineClass"
- signature
- (ffi.class_for java/lang/ClassLoader))
- (java/lang/reflect/AccessibleObject::setAccessible true)))))
-
-(def: #export (define class_name bytecode loader)
- (-> Text Binary java/lang/ClassLoader (Try java/lang/Object))
- (let [signature (array.from_list (list (:as java/lang/Object
- class_name)
- (:as java/lang/Object
- bytecode)
- (:as java/lang/Object
- (|> 0
- (:as (primitive "java.lang.Long"))
- ffi.long_to_int))
- (:as java/lang/Object
- (|> bytecode
- binary.size
- (:as (primitive "java.lang.Long"))
- ffi.long_to_int))))]
- (java/lang/reflect/Method::invoke loader signature java/lang/ClassLoader::defineClass)))
-
-(def: #export (new_library _)
- (-> Any Library)
- (atom.atom (dictionary.new text.hash)))
-
-(def: #export (memory library)
- (-> Library java/lang/ClassLoader)
- (with_expansions [<cast> (for {@.old
- (<|)
-
- @.jvm
- "jvm object cast"})]
- (<| <cast>
- (object [] java/lang/ClassLoader []
- []
- (java/lang/ClassLoader (findClass self {class_name java/lang/String})
- (java/lang/Class [? < java/lang/Object])
- #throws [java/lang/ClassNotFoundException]
- (let [class_name (:as Text class_name)
- classes (|> library atom.read io.run)]
- (case (dictionary.get class_name classes)
- (#.Some bytecode)
- (case (..define class_name bytecode (<| <cast> self))
- (#try.Success class)
- (:assume class)
-
- (#try.Failure error)
- (error! (exception.construct ..cannot_define [class_name error])))
-
- #.None
- (error! (exception.construct ..unknown [class_name (dictionary.keys classes)])))))))))
-
-(def: #export (store name bytecode library)
- (-> Text Binary Library (IO (Try Any)))
- (do {! io.monad}
- [library' (atom.read library)]
- (if (dictionary.key? library' name)
- (wrap (exception.throw ..already_stored name))
- (do !
- [_ (atom.update (dictionary.put name bytecode) library)]
- (wrap (#try.Success []))))))
-
-(def: #export (load name loader)
- (-> Text java/lang/ClassLoader
- (IO (Try (java/lang/Class java/lang/Object))))
- (java/lang/ClassLoader::loadClass name loader))
diff --git a/stdlib/source/lux/target/jvm/magic.lux b/stdlib/source/lux/target/jvm/magic.lux
deleted file mode 100644
index 370d8e09b..000000000
--- a/stdlib/source/lux/target/jvm/magic.lux
+++ /dev/null
@@ -1,19 +0,0 @@
-(.module:
- [lux #*
- [control
- ["." try]]
- [math
- [number (#+ hex)]]]
- ["." // #_
- [encoding
- ["#." unsigned (#+ U4)]]])
-
-(type: #export Magic
- U4)
-
-(def: #export code
- Magic
- (|> (hex "CAFEBABE") //unsigned.u4 try.assume))
-
-(def: #export writer
- //unsigned.writer/4)
diff --git a/stdlib/source/lux/target/jvm/method.lux b/stdlib/source/lux/target/jvm/method.lux
deleted file mode 100644
index 6219a1c1d..000000000
--- a/stdlib/source/lux/target/jvm/method.lux
+++ /dev/null
@@ -1,103 +0,0 @@
-(.module:
- [lux (#- Type static)
- [abstract
- [equivalence (#+ Equivalence)]
- ["." monad (#+ do)]]
- [control
- ["." try]]
- [data
- ["." product]
- ["." format #_
- ["#" binary (#+ Writer) ("#\." monoid)]]
- [collection
- ["." row (#+ Row)]]]]
- ["." // #_
- ["#." modifier (#+ Modifier modifiers:)]
- ["#." index (#+ Index)]
- ["#." attribute (#+ Attribute)
- ["#/." code]]
- ["#." constant (#+ UTF8)
- ["#/." pool (#+ Pool Resource)]]
- ["#." bytecode (#+ Bytecode)
- ["#/." environment (#+ Environment)]
- ["#/." instruction]]
- ["#." type (#+ Type)
- ["#/." category]
- ["#." descriptor (#+ Descriptor)]]])
-
-(type: #export #rec Method
- {#modifier (Modifier Method)
- #name (Index UTF8)
- #descriptor (Index (Descriptor //type/category.Method))
- #attributes (Row Attribute)})
-
-(modifiers: Method
- ["0001" public]
- ["0002" private]
- ["0004" protected]
- ["0008" static]
- ["0010" final]
- ["0020" synchronized]
- ["0040" bridge]
- ["0080" var_args]
- ["0100" native]
- ["0400" abstract]
- ["0800" strict]
- ["1000" synthetic]
- )
-
-(def: #export (method modifier name type attributes code)
- (-> (Modifier Method) UTF8 (Type //type/category.Method) (List (Resource Attribute)) (Maybe (Bytecode Any))
- (Resource Method))
- (do {! //constant/pool.monad}
- [@name (//constant/pool.utf8 name)
- @descriptor (//constant/pool.descriptor (//type.descriptor type))
- attributes (|> attributes
- (monad.seq !)
- (\ ! map row.from_list))
- attributes (case code
- (#.Some code)
- (do !
- [environment (case (if (//modifier.has? static modifier)
- (//bytecode/environment.static type)
- (//bytecode/environment.virtual type))
- (#try.Success environment)
- (wrap environment)
-
- (#try.Failure error)
- (function (_ _) (#try.Failure error)))
- [environment exceptions instruction output] (//bytecode.resolve environment code)
- #let [bytecode (|> instruction //bytecode/instruction.run format.instance)]
- @code (//attribute.code {#//attribute/code.limit (get@ #//bytecode/environment.limit environment)
- #//attribute/code.code bytecode
- #//attribute/code.exception_table exceptions
- #//attribute/code.attributes (row.row)})]
- (wrap (row.add @code attributes)))
-
- #.None
- (wrap attributes))]
- (wrap {#modifier modifier
- #name @name
- #descriptor @descriptor
- #attributes attributes})))
-
-(def: #export equivalence
- (Equivalence Method)
- ($_ product.equivalence
- //modifier.equivalence
- //index.equivalence
- //index.equivalence
- (row.equivalence //attribute.equivalence)
- ))
-
-(def: #export (writer field)
- (Writer Method)
- (`` ($_ format\compose
- (~~ (template [<writer> <slot>]
- [(<writer> (get@ <slot> field))]
-
- [//modifier.writer #modifier]
- [//index.writer #name]
- [//index.writer #descriptor]
- [(format.row/16 //attribute.writer) #attributes]))
- )))
diff --git a/stdlib/source/lux/target/jvm/modifier.lux b/stdlib/source/lux/target/jvm/modifier.lux
deleted file mode 100644
index 80e353f33..000000000
--- a/stdlib/source/lux/target/jvm/modifier.lux
+++ /dev/null
@@ -1,87 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." equivalence (#+ Equivalence)]
- ["." monoid (#+ Monoid)]]
- [control
- ["." try]
- ["<>" parser
- ["<c>" code]]]
- [data
- [format
- [".F" binary (#+ Writer)]]]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- ["." number (#+ hex)
- ["." i64]]]
- [type
- abstract]]
- ["." // #_
- [encoding
- ["#." unsigned]]])
-
-(abstract: #export (Modifier of)
- //unsigned.U2
-
- (def: #export code
- (-> (Modifier Any) //unsigned.U2)
- (|>> :representation))
-
- (implementation: #export equivalence
- (All [of] (Equivalence (Modifier of)))
-
- (def: (= reference sample)
- (\ //unsigned.equivalence =
- (:representation reference)
- (:representation sample))))
-
- (template: (!wrap value)
- (|> value
- //unsigned.u2
- try.assume
- :abstraction))
-
- (template: (!unwrap value)
- (|> value
- :representation
- //unsigned.value))
-
- (def: #export (has? sub super)
- (All [of] (-> (Modifier of) (Modifier of) Bit))
- (let [sub (!unwrap sub)]
- (|> (!unwrap super)
- (i64.and sub)
- (\ i64.equivalence = sub))))
-
- (implementation: #export monoid
- (All [of] (Monoid (Modifier of)))
-
- (def: identity
- (!wrap (hex "0000")))
-
- (def: (compose left right)
- (!wrap (i64.or (!unwrap left) (!unwrap right)))))
-
- (def: #export empty
- Modifier
- (\ ..monoid identity))
-
- (def: #export writer
- (All [of] (Writer (Modifier of)))
- (|>> :representation //unsigned.writer/2))
-
- (def: modifier
- (-> Nat Modifier)
- (|>> !wrap))
- )
-
-(syntax: #export (modifiers: ofT {options (<>.many <c>.any)})
- (with_gensyms [g!modifier g!code]
- (wrap (list (` (template [(~ g!code) (~ g!modifier)]
- [(def: (~' #export) (~ g!modifier)
- (..Modifier (~ ofT))
- ((~! ..modifier) ((~! number.hex) (~ g!code))))]
-
- (~+ options)))))))
diff --git a/stdlib/source/lux/target/jvm/modifier/inner.lux b/stdlib/source/lux/target/jvm/modifier/inner.lux
deleted file mode 100644
index ff6f5d50e..000000000
--- a/stdlib/source/lux/target/jvm/modifier/inner.lux
+++ /dev/null
@@ -1,20 +0,0 @@
-(.module:
- [lux (#- static)
- [type
- abstract]]
- [// (#+ modifiers:)])
-
-(abstract: #export Inner Any)
-
-(modifiers: Inner
- ["0001" public]
- ["0002" private]
- ["0004" protected]
- ["0008" static]
- ["0010" final]
- ["0200" interface]
- ["0400" abstract]
- ["1000" synthetic]
- ["2000" annotation]
- ["4000" enum]
- )
diff --git a/stdlib/source/lux/target/jvm/reflection.lux b/stdlib/source/lux/target/jvm/reflection.lux
deleted file mode 100644
index 02c6b0ab0..000000000
--- a/stdlib/source/lux/target/jvm/reflection.lux
+++ /dev/null
@@ -1,381 +0,0 @@
-(.module:
- [lux (#- type)
- ["." ffi (#+ import:)]
- ["." type]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- [parser
- ["<t>" text]]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." fold functor)]
- ["." array]
- ["." dictionary]]]
- [math
- [number
- ["n" nat]]]]
- ["." // #_
- [encoding
- ["#." name (#+ External)]]
- ["/" type
- [category (#+ Void Value Return Method Primitive Object Class Array Parameter)]
- ["#." lux (#+ Mapping)]
- ["#." descriptor]
- ["#." reflection]
- ["#." parser]]])
-
-(import: java/lang/String)
-
-(import: java/lang/Object
- ["#::."
- (toString [] java/lang/String)
- (getClass [] (java/lang/Class java/lang/Object))])
-
-(import: java/lang/reflect/Type
- ["#::."
- (getTypeName [] java/lang/String)])
-
-(import: java/lang/reflect/GenericArrayType
- ["#::."
- (getGenericComponentType [] java/lang/reflect/Type)])
-
-(import: java/lang/reflect/ParameterizedType
- ["#::."
- (getRawType [] java/lang/reflect/Type)
- (getActualTypeArguments [] [java/lang/reflect/Type])])
-
-(import: (java/lang/reflect/TypeVariable d)
- ["#::."
- (getName [] java/lang/String)
- (getBounds [] [java/lang/reflect/Type])])
-
-(import: (java/lang/reflect/WildcardType d)
- ["#::."
- (getLowerBounds [] [java/lang/reflect/Type])
- (getUpperBounds [] [java/lang/reflect/Type])])
-
-(import: java/lang/reflect/Modifier
- ["#::."
- (#static isStatic [int] boolean)
- (#static isFinal [int] boolean)
- (#static isInterface [int] boolean)
- (#static isAbstract [int] boolean)])
-
-(import: java/lang/annotation/Annotation)
-
-(import: java/lang/Deprecated)
-
-(import: java/lang/reflect/Field
- ["#::."
- (getDeclaringClass [] (java/lang/Class java/lang/Object))
- (getModifiers [] int)
- (getGenericType [] java/lang/reflect/Type)
- (getDeclaredAnnotations [] [java/lang/annotation/Annotation])])
-
-(import: java/lang/reflect/Method
- ["#::."
- (getName [] java/lang/String)
- (getModifiers [] int)
- (getDeclaringClass [] (java/lang/Class java/lang/Object))
- (getTypeParameters [] [(java/lang/reflect/TypeVariable java/lang/reflect/Method)])
- (getGenericParameterTypes [] [java/lang/reflect/Type])
- (getGenericReturnType [] java/lang/reflect/Type)
- (getGenericExceptionTypes [] [java/lang/reflect/Type])])
-
-(import: (java/lang/reflect/Constructor c)
- ["#::."
- (getModifiers [] int)
- (getDeclaringClass [] (java/lang/Class c))
- (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/reflect/Constructor c))])
- (getGenericParameterTypes [] [java/lang/reflect/Type])
- (getGenericExceptionTypes [] [java/lang/reflect/Type])])
-
-(import: (java/lang/Class c)
- ["#::."
- (#static forName [java/lang/String] #try (java/lang/Class java/lang/Object))
- (getName [] java/lang/String)
- (getModifiers [] int)
- (isAssignableFrom [(java/lang/Class java/lang/Object)] boolean)
- (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/Class c))])
- (getGenericInterfaces [] [java/lang/reflect/Type])
- (getGenericSuperclass [] #? java/lang/reflect/Type)
- (getDeclaredField [java/lang/String] #try java/lang/reflect/Field)
- (getConstructors [] [(java/lang/reflect/Constructor java/lang/Object)])
- (getDeclaredMethods [] [java/lang/reflect/Method])])
-
-(exception: #export (unknown_class {class External})
- (exception.report
- ["Class" (%.text class)]))
-
-(template [<name>]
- [(exception: #export (<name> {jvm_type java/lang/reflect/Type})
- (exception.report
- ["Type" (java/lang/reflect/Type::getTypeName jvm_type)]
- ["Class" (|> jvm_type java/lang/Object::getClass java/lang/Object::toString)]))]
-
- [not_a_class]
- [cannot_convert_to_a_lux_type]
- )
-
-(def: #export (load name)
- (-> External (Try (java/lang/Class java/lang/Object)))
- (case (java/lang/Class::forName name)
- (#try.Success class)
- (#try.Success class)
-
- (#try.Failure _)
- (exception.throw ..unknown_class name)))
-
-(def: #export (sub? super sub)
- (-> External External (Try Bit))
- (do try.monad
- [super (..load super)
- sub (..load sub)]
- (wrap (java/lang/Class::isAssignableFrom sub super))))
-
-(def: (class' parameter reflection)
- (-> (-> java/lang/reflect/Type (Try (/.Type Parameter)))
- java/lang/reflect/Type
- (Try (/.Type Class)))
- (<| (case (ffi.check java/lang/Class reflection)
- (#.Some class)
- (let [class_name (|> class
- (:as (java/lang/Class java/lang/Object))
- java/lang/Class::getName)]
- (`` (if (or (~~ (template [<reflection>]
- [(text\= (/reflection.reflection <reflection>)
- class_name)]
-
- [/reflection.boolean]
- [/reflection.byte]
- [/reflection.short]
- [/reflection.int]
- [/reflection.long]
- [/reflection.float]
- [/reflection.double]
- [/reflection.char]))
- (text.starts_with? /descriptor.array_prefix class_name))
- (exception.throw ..not_a_class reflection)
- (#try.Success (/.class class_name (list))))))
- _)
- (case (ffi.check java/lang/reflect/ParameterizedType reflection)
- (#.Some reflection)
- (let [raw (java/lang/reflect/ParameterizedType::getRawType reflection)]
- (case (ffi.check java/lang/Class raw)
- (#.Some raw)
- (do {! try.monad}
- [paramsT (|> reflection
- java/lang/reflect/ParameterizedType::getActualTypeArguments
- array.to_list
- (monad.map ! parameter))]
- (wrap (/.class (|> raw
- (:as (java/lang/Class java/lang/Object))
- java/lang/Class::getName)
- paramsT)))
-
- _
- (exception.throw ..not_a_class raw)))
- _)
- ## else
- (exception.throw ..cannot_convert_to_a_lux_type reflection)))
-
-(def: #export (parameter reflection)
- (-> java/lang/reflect/Type (Try (/.Type Parameter)))
- (<| (case (ffi.check java/lang/reflect/TypeVariable reflection)
- (#.Some reflection)
- (#try.Success (/.var (java/lang/reflect/TypeVariable::getName reflection)))
- _)
- (case (ffi.check java/lang/reflect/WildcardType reflection)
- (#.Some reflection)
- ## TODO: Instead of having single lower/upper bounds, should
- ## allow for multiple ones.
- (case [(array.read 0 (java/lang/reflect/WildcardType::getLowerBounds reflection))
- (array.read 0 (java/lang/reflect/WildcardType::getUpperBounds reflection))]
- (^template [<pattern> <kind>]
- [<pattern>
- (case (ffi.check java/lang/reflect/GenericArrayType bound)
- (#.Some _)
- ## TODO: Array bounds should not be "erased" as they
- ## are right now.
- (#try.Success /.wildcard)
-
- _
- (\ try.monad map <kind> (..class' parameter bound)))])
- ([[_ (#.Some bound)] /.upper]
- [[(#.Some bound) _] /.lower])
-
- _
- (#try.Success /.wildcard))
- _)
- (..class' parameter reflection)))
-
-(def: #export class
- (-> java/lang/reflect/Type
- (Try (/.Type Class)))
- (..class' ..parameter))
-
-(def: #export (type reflection)
- (-> java/lang/reflect/Type (Try (/.Type Value)))
- (<| (case (ffi.check java/lang/Class reflection)
- (#.Some reflection)
- (let [class_name (|> reflection
- (:as (java/lang/Class java/lang/Object))
- java/lang/Class::getName)]
- (`` (cond (~~ (template [<reflection> <type>]
- [(text\= (/reflection.reflection <reflection>)
- class_name)
- (#try.Success <type>)]
-
- [/reflection.boolean /.boolean]
- [/reflection.byte /.byte]
- [/reflection.short /.short]
- [/reflection.int /.int]
- [/reflection.long /.long]
- [/reflection.float /.float]
- [/reflection.double /.double]
- [/reflection.char /.char]))
- (if (text.starts_with? /descriptor.array_prefix class_name)
- (<t>.run /parser.value (|> class_name //name.internal //name.read))
- (#try.Success (/.class class_name (list)))))))
- _)
- (case (ffi.check java/lang/reflect/GenericArrayType reflection)
- (#.Some reflection)
- (|> reflection
- java/lang/reflect/GenericArrayType::getGenericComponentType
- type
- (\ try.monad map /.array))
- _)
- ## else
- (..parameter reflection)))
-
-(def: #export (return reflection)
- (-> java/lang/reflect/Type (Try (/.Type Return)))
- (with_expansions [<else> (as_is (..type reflection))]
- (case (ffi.check java/lang/Class reflection)
- (#.Some class)
- (let [class_name (|> reflection
- (:as (java/lang/Class java/lang/Object))
- java/lang/Class::getName)]
- (if (text\= (/reflection.reflection /reflection.void)
- class_name)
- (#try.Success /.void)
- <else>))
-
- #.None
- <else>)))
-
-(exception: #export (cannot_correspond {class (java/lang/Class java/lang/Object)}
- {type Type})
- (exception.report
- ["Class" (java/lang/Object::toString class)]
- ["Type" (%.type type)]))
-
-(exception: #export (type_parameter_mismatch {expected Nat}
- {actual Nat}
- {class (java/lang/Class java/lang/Object)}
- {type Type})
- (exception.report
- ["Expected" (%.nat expected)]
- ["Actual" (%.nat actual)]
- ["Class" (java/lang/Object::toString class)]
- ["Type" (%.type type)]))
-
-(exception: #export (non_jvm_type {type Type})
- (exception.report
- ["Type" (%.type type)]))
-
-(def: #export (correspond class type)
- (-> (java/lang/Class java/lang/Object) Type (Try Mapping))
- (case type
- (#.Primitive name params)
- (let [class_name (java/lang/Class::getName class)
- class_params (array.to_list (java/lang/Class::getTypeParameters class))
- num_class_params (list.size class_params)
- num_type_params (list.size params)]
- (if (text\= class_name name)
- (if (n.= num_class_params num_type_params)
- (|> params
- (list.zip/2 (list\map (|>> java/lang/reflect/TypeVariable::getName)
- class_params))
- (list\fold (function (_ [name paramT] mapping)
- (dictionary.put name paramT mapping))
- /lux.fresh)
- #try.Success)
- (exception.throw ..type_parameter_mismatch [num_class_params num_type_params class type]))
- (exception.throw ..cannot_correspond [class type])))
-
- (#.Named name anonymousT)
- (correspond class anonymousT)
-
- (#.Apply inputT abstractionT)
- (case (type.apply (list inputT) abstractionT)
- (#.Some outputT)
- (correspond class outputT)
-
- #.None
- (exception.throw ..non_jvm_type [type]))
-
- _
- (exception.throw ..non_jvm_type [type])))
-
-(exception: #export (mistaken_field_owner {field java/lang/reflect/Field}
- {owner (java/lang/Class java/lang/Object)}
- {target (java/lang/Class java/lang/Object)})
- (exception.report
- ["Field" (java/lang/Object::toString field)]
- ["Owner" (java/lang/Object::toString owner)]
- ["Target" (java/lang/Object::toString target)]))
-
-(template [<name>]
- [(exception: #export (<name> {field Text}
- {class (java/lang/Class java/lang/Object)})
- (exception.report
- ["Field" (%.text field)]
- ["Class" (java/lang/Object::toString class)]))]
-
- [unknown_field]
- [not_a_static_field]
- [not_a_virtual_field]
- )
-
-(def: #export (field field target)
- (-> Text (java/lang/Class java/lang/Object) (Try java/lang/reflect/Field))
- (case (java/lang/Class::getDeclaredField field target)
- (#try.Success field)
- (let [owner (java/lang/reflect/Field::getDeclaringClass field)]
- (if (is? owner target)
- (#try.Success field)
- (exception.throw ..mistaken_field_owner [field owner target])))
-
- (#try.Failure _)
- (exception.throw ..unknown_field [field target])))
-
-(def: #export deprecated?
- (-> (array.Array java/lang/annotation/Annotation) Bit)
- (|>> array.to_list
- (list.all (|>> (ffi.check java/lang/Deprecated)))
- list.empty?
- not))
-
-(template [<name> <exception> <then?> <else?>]
- [(def: #export (<name> field class)
- (-> Text (java/lang/Class java/lang/Object) (Try [Bit Bit (/.Type Value)]))
- (do {! try.monad}
- [fieldJ (..field field class)
- #let [modifiers (java/lang/reflect/Field::getModifiers fieldJ)]]
- (case (java/lang/reflect/Modifier::isStatic modifiers)
- <then?> (|> fieldJ
- java/lang/reflect/Field::getGenericType
- ..type
- (\ ! map (|>> [(java/lang/reflect/Modifier::isFinal modifiers)
- (..deprecated? (java/lang/reflect/Field::getDeclaredAnnotations fieldJ))])))
- <else?> (exception.throw <exception> [field class]))))]
-
- [static_field ..not_a_static_field #1 #0]
- [virtual_field ..not_a_virtual_field #0 #1]
- )
diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux
deleted file mode 100644
index 0e3d9be92..000000000
--- a/stdlib/source/lux/target/jvm/type.lux
+++ /dev/null
@@ -1,204 +0,0 @@
-(.module:
- [lux (#- Type int char)
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]]
- [data
- ["." maybe]
- ["." text
- ["%" format (#+ Format)]]
- [collection
- ["." list ("#\." functor)]]]
- [math
- [number
- ["n" nat]]]
- [type
- abstract]]
- ["." // #_
- [encoding
- ["#." name (#+ External)]]]
- ["." / #_
- [category (#+ Void Value' Value Return' Return Method Primitive Object Class Array Var Parameter Declaration)]
- ["#." signature (#+ Signature)]
- ["#." descriptor (#+ Descriptor)]
- ["#." reflection (#+ Reflection)]])
-
-(abstract: #export (Type category)
- [(Signature category) (Descriptor category) (Reflection category)]
-
- (type: #export Argument
- [Text (Type Value)])
-
- (type: #export (Typed a)
- [(Type Value) a])
-
- (type: #export Constraint
- {#name Text
- #super_class (Type Class)
- #super_interfaces (List (Type Class))})
-
- (template [<name> <style>]
- [(def: #export (<name> type)
- (All [category] (-> (Type category) (<style> category)))
- (let [[signature descriptor reflection] (:representation type)]
- <name>))]
-
- [signature Signature]
- [descriptor Descriptor]
- )
-
- (def: #export (reflection type)
- (All [category]
- (-> (Type (<| Return' Value' category))
- (Reflection (<| Return' Value' category))))
- (let [[signature descriptor reflection] (:representation type)]
- reflection))
-
- (template [<category> <name> <signature> <descriptor> <reflection>]
- [(def: #export <name>
- (Type <category>)
- (:abstraction [<signature> <descriptor> <reflection>]))]
-
- [Void void /signature.void /descriptor.void /reflection.void]
- [Primitive boolean /signature.boolean /descriptor.boolean /reflection.boolean]
- [Primitive byte /signature.byte /descriptor.byte /reflection.byte]
- [Primitive short /signature.short /descriptor.short /reflection.short]
- [Primitive int /signature.int /descriptor.int /reflection.int]
- [Primitive long /signature.long /descriptor.long /reflection.long]
- [Primitive float /signature.float /descriptor.float /reflection.float]
- [Primitive double /signature.double /descriptor.double /reflection.double]
- [Primitive char /signature.char /descriptor.char /reflection.char]
- )
-
- (def: #export (array type)
- (-> (Type Value) (Type Array))
- (:abstraction
- [(/signature.array (..signature type))
- (/descriptor.array (..descriptor type))
- (/reflection.array (..reflection type))]))
-
- (def: #export (class name parameters)
- (-> External (List (Type Parameter)) (Type Class))
- (:abstraction
- [(/signature.class name (list\map ..signature parameters))
- (/descriptor.class name)
- (/reflection.class name)]))
-
- (def: #export (declaration name variables)
- (-> External (List (Type Var)) (Type Declaration))
- (:abstraction
- [(/signature.declaration name (list\map ..signature variables))
- (/descriptor.declaration name)
- (/reflection.declaration name)]))
-
- (def: #export (as_class type)
- (-> (Type Declaration) (Type Class))
- (:abstraction
- (let [[signature descriptor reflection] (:representation type)]
- [(/signature.as_class signature)
- (/descriptor.as_class descriptor)
- (/reflection.as_class reflection)])))
-
- (def: #export wildcard
- (Type Parameter)
- (:abstraction
- [/signature.wildcard
- /descriptor.wildcard
- /reflection.wildcard]))
-
- (def: #export (var name)
- (-> Text (Type Var))
- (:abstraction
- [(/signature.var name)
- /descriptor.var
- /reflection.var]))
-
- (def: #export (lower bound)
- (-> (Type Class) (Type Parameter))
- (:abstraction
- (let [[signature descriptor reflection] (:representation bound)]
- [(/signature.lower signature)
- (/descriptor.lower descriptor)
- (/reflection.lower reflection)])))
-
- (def: #export (upper bound)
- (-> (Type Class) (Type Parameter))
- (:abstraction
- (let [[signature descriptor reflection] (:representation bound)]
- [(/signature.upper signature)
- (/descriptor.upper descriptor)
- (/reflection.upper reflection)])))
-
- (def: #export (method [inputs output exceptions])
- (-> [(List (Type Value))
- (Type Return)
- (List (Type Class))]
- (Type Method))
- (:abstraction
- [(/signature.method [(list\map ..signature inputs)
- (..signature output)
- (list\map ..signature exceptions)])
- (/descriptor.method [(list\map ..descriptor inputs)
- (..descriptor output)])
- (:assume ..void)]))
-
- (implementation: #export equivalence
- (All [category] (Equivalence (Type category)))
-
- (def: (= parameter subject)
- (\ /signature.equivalence =
- (..signature parameter)
- (..signature subject))))
-
- (implementation: #export hash
- (All [category] (Hash (Type category)))
-
- (def: &equivalence ..equivalence)
- (def: hash (|>> ..signature (\ /signature.hash hash))))
-
- (def: #export (primitive? type)
- (-> (Type Value) (Either (Type Object)
- (Type Primitive)))
- (if (`` (or (~~ (template [<type>]
- [(\ ..equivalence = (: (Type Value) <type>) type)]
-
- [..boolean]
- [..byte]
- [..short]
- [..int]
- [..long]
- [..float]
- [..double]
- [..char]))))
- (|> type (:as (Type Primitive)) #.Right)
- (|> type (:as (Type Object)) #.Left)))
-
- (def: #export (void? type)
- (-> (Type Return) (Either (Type Value)
- (Type Void)))
- (if (`` (or (~~ (template [<type>]
- [(\ ..equivalence = (: (Type Return) <type>) type)]
-
- [..void]))))
- (|> type (:as (Type Void)) #.Right)
- (|> type (:as (Type Value)) #.Left)))
- )
-
-(def: #export (class? type)
- (-> (Type Value) (Maybe External))
- (let [repr (|> type ..descriptor /descriptor.descriptor)]
- (if (and (text.starts_with? /descriptor.class_prefix repr)
- (text.ends_with? /descriptor.class_suffix repr))
- (let [prefix_size (text.size /descriptor.class_prefix)
- suffix_size (text.size /descriptor.class_suffix)
- name_size (|> (text.size repr)
- (n.- prefix_size)
- (n.- suffix_size))]
- (|> repr
- (text.clip prefix_size name_size)
- (\ maybe.monad map (|>> //name.internal //name.external))))
- #.None)))
-
-(def: #export format
- (All [a] (Format (Type a)))
- (|>> ..signature /signature.signature))
diff --git a/stdlib/source/lux/target/jvm/type/alias.lux b/stdlib/source/lux/target/jvm/type/alias.lux
deleted file mode 100644
index e474250ca..000000000
--- a/stdlib/source/lux/target/jvm/type/alias.lux
+++ /dev/null
@@ -1,115 +0,0 @@
-(.module:
- [lux (#- Type int char type primitive)
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<t>" text (#+ Parser)]]]
- [data
- ["." maybe]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary (#+ Dictionary)]]]]
- ["." // (#+ Type)
- [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
- ["#." descriptor]
- ["#." signature (#+ Signature)]
- ["#." reflection]
- ["#." parser]
- ["/#" // #_
- [encoding
- ["#." name]]]])
-
-(type: #export Aliasing
- (Dictionary Text Text))
-
-(def: #export fresh
- Aliasing
- (dictionary.new text.hash))
-
-(def: (var aliasing)
- (-> Aliasing (Parser (Type Var)))
- (do <>.monad
- [var //parser.var']
- (wrap (|> aliasing
- (dictionary.get var)
- (maybe.default var)
- //.var))))
-
-(def: (class parameter)
- (-> (Parser (Type Parameter)) (Parser (Type Class)))
- (|> (do <>.monad
- [name //parser.class_name
- parameters (|> (<>.some parameter)
- (<>.after (<t>.this //signature.parameters_start))
- (<>.before (<t>.this //signature.parameters_end))
- (<>.default (list)))]
- (wrap (//.class name parameters)))
- (<>.after (<t>.this //descriptor.class_prefix))
- (<>.before (<t>.this //descriptor.class_suffix))))
-
-(template [<name> <prefix> <bound> <constructor>]
- [(def: <name>
- (-> (Parser (Type Class)) (Parser (Type Parameter)))
- (|>> (<>.after (<t>.this <prefix>))
- (\ <>.monad map <bound>)))]
-
- [lower //signature.lower_prefix //.lower ..Lower]
- [upper //signature.upper_prefix //.upper ..Upper]
- )
-
-(def: (parameter aliasing)
- (-> Aliasing (Parser (Type Parameter)))
- (<>.rec
- (function (_ parameter)
- (let [class (..class parameter)]
- ($_ <>.either
- (..var aliasing)
- //parser.wildcard
- (..lower class)
- (..upper class)
- class
- )))))
-
-(def: (value aliasing)
- (-> Aliasing (Parser (Type Value)))
- (<>.rec
- (function (_ value)
- ($_ <>.either
- //parser.primitive
- (parameter aliasing)
- (//parser.array' value)
- ))))
-
-(def: (inputs aliasing)
- (-> Aliasing (Parser (List (Type Value))))
- (|> (<>.some (..value aliasing))
- (<>.after (<t>.this //signature.arguments_start))
- (<>.before (<t>.this //signature.arguments_end))))
-
-(def: (return aliasing)
- (-> Aliasing (Parser (Type Return)))
- ($_ <>.either
- //parser.void
- (..value aliasing)
- ))
-
-(def: (exception aliasing)
- (-> Aliasing (Parser (Type Class)))
- (|> (..class (..parameter aliasing))
- (<>.after (<t>.this //signature.exception_prefix))))
-
-(def: #export (method aliasing type)
- (-> Aliasing (Type Method) (Type Method))
- (|> type
- //.signature
- //signature.signature
- (<t>.run (do <>.monad
- [inputs (..inputs aliasing)
- return (..return aliasing)
- exceptions (<>.some (..exception aliasing))]
- (wrap (//.method [inputs return exceptions]))))
- try.assume))
diff --git a/stdlib/source/lux/target/jvm/type/box.lux b/stdlib/source/lux/target/jvm/type/box.lux
deleted file mode 100644
index 65816b487..000000000
--- a/stdlib/source/lux/target/jvm/type/box.lux
+++ /dev/null
@@ -1,18 +0,0 @@
-(.module:
- [lux (#- int char)]
- [///
- [encoding
- [name (#+ External)]]])
-
-(template [<name> <box>]
- [(def: #export <name> External <box>)]
-
- [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"]
- )
diff --git a/stdlib/source/lux/target/jvm/type/category.lux b/stdlib/source/lux/target/jvm/type/category.lux
deleted file mode 100644
index 5dfb38ddc..000000000
--- a/stdlib/source/lux/target/jvm/type/category.lux
+++ /dev/null
@@ -1,35 +0,0 @@
-(.module:
- [lux #*
- [macro
- ["." template]]
- [type
- abstract]])
-
-(abstract: #export Void' Any)
-(abstract: #export (Value' kind) Any)
-(abstract: #export (Return' kind) Any)
-(abstract: #export Method Any)
-
-(type: #export Return (<| Return' Any))
-(type: #export Value (<| Return' Value' Any))
-(type: #export Void (<| Return' Void'))
-
-(abstract: #export (Object' brand) Any)
-(type: #export Object (<| Return' Value' Object' Any))
-
-(abstract: #export (Parameter' brand) Any)
-(type: #export Parameter (<| Return' Value' Object' Parameter' Any))
-
-(template [<parents> <child>]
- [(with_expansions [<raw> (template.identifier [<child> "'"])]
- (abstract: #export <raw> Any)
- (type: #export <child>
- (`` (<| Return' Value' (~~ (template.splice <parents>)) <raw>))))]
-
- [[] Primitive]
- [[Object' Parameter'] Var]
- [[Object' Parameter'] Class]
- [[Object'] Array]
- )
-
-(abstract: #export Declaration Any)
diff --git a/stdlib/source/lux/target/jvm/type/descriptor.lux b/stdlib/source/lux/target/jvm/type/descriptor.lux
deleted file mode 100644
index d8d5ea256..000000000
--- a/stdlib/source/lux/target/jvm/type/descriptor.lux
+++ /dev/null
@@ -1,122 +0,0 @@
-(.module:
- [lux (#- int char)
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- ["." maybe]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]]]
- [math
- [number
- ["n" nat]]]
- [type
- abstract]]
- ["." // #_
- [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)]
- ["/#" // #_
- [encoding
- ["#." name (#+ Internal External)]]]])
-
-(abstract: #export (Descriptor category)
- Text
-
- (def: #export descriptor
- (-> (Descriptor Any) Text)
- (|>> :representation))
-
- (template [<sigil> <category> <name>]
- [(def: #export <name>
- (Descriptor <category>)
- (:abstraction <sigil>))]
-
- ["V" Void void]
- ["Z" Primitive boolean]
- ["B" Primitive byte]
- ["S" Primitive short]
- ["I" Primitive int]
- ["J" Primitive long]
- ["F" Primitive float]
- ["D" Primitive double]
- ["C" Primitive char]
- )
-
- (def: #export class_prefix "L")
- (def: #export class_suffix ";")
-
- (def: #export class
- (-> External (Descriptor Class))
- (|>> ///name.internal
- ///name.read
- (text.enclose [..class_prefix ..class_suffix])
- :abstraction))
-
- (def: #export (declaration name)
- (-> External (Descriptor Declaration))
- (:transmutation (..class name)))
-
- (def: #export as_class
- (-> (Descriptor Declaration) (Descriptor Class))
- (|>> :transmutation))
-
- (template [<name> <category>]
- [(def: #export <name>
- (Descriptor <category>)
- (:transmutation
- (..class "java.lang.Object")))]
-
- [var Var]
- [wildcard Parameter]
- )
-
- (def: #export (lower descriptor)
- (-> (Descriptor Class) (Descriptor Parameter))
- ..wildcard)
-
- (def: #export upper
- (-> (Descriptor Class) (Descriptor Parameter))
- (|>> :transmutation))
-
- (def: #export array_prefix "[")
-
- (def: #export array
- (-> (Descriptor Value)
- (Descriptor Array))
- (|>> :representation
- (format ..array_prefix)
- :abstraction))
-
- (def: #export (method [inputs output])
- (-> [(List (Descriptor Value))
- (Descriptor Return)]
- (Descriptor Method))
- (:abstraction
- (format (|> inputs
- (list\map ..descriptor)
- (text.join_with "")
- (text.enclose ["(" ")"]))
- (:representation output))))
-
- (implementation: #export equivalence
- (All [category] (Equivalence (Descriptor category)))
-
- (def: (= parameter subject)
- (text\= (:representation parameter) (:representation subject))))
-
- (def: #export class_name
- (-> (Descriptor Object) Internal)
- (let [prefix_size (text.size ..class_prefix)
- suffix_size (text.size ..class_suffix)]
- (function (_ descriptor)
- (let [repr (:representation descriptor)]
- (if (text.starts_with? ..array_prefix repr)
- (///name.internal repr)
- (|> repr
- (text.clip prefix_size
- (|> (text.size repr)
- (n.- prefix_size)
- (n.- suffix_size)))
- (\ maybe.monad map ///name.internal)
- maybe.assume))))))
- )
diff --git a/stdlib/source/lux/target/jvm/type/lux.lux b/stdlib/source/lux/target/jvm/type/lux.lux
deleted file mode 100644
index e42c54610..000000000
--- a/stdlib/source/lux/target/jvm/type/lux.lux
+++ /dev/null
@@ -1,188 +0,0 @@
-(.module:
- [lux (#- int char type primitive)
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try]
- ["." exception (#+ exception:)]
- ["<>" parser ("#\." monad)
- ["<t>" text (#+ Parser)]]]
- [data
- ["." product]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." array]
- ["." dictionary (#+ Dictionary)]]]
- [type
- abstract
- ["." check (#+ Check) ("#\." monad)]]]
- ["." //
- [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
- ["#." descriptor]
- ["#." signature]
- ["#." reflection]
- ["#." parser]
- ["/#" // #_
- [encoding
- ["#." name]]]])
-
-(template [<name>]
- [(abstract: #export (<name> class) Any)]
-
- [Lower] [Upper]
- )
-
-(type: #export Mapping
- (Dictionary Text Type))
-
-(def: #export fresh
- Mapping
- (dictionary.new text.hash))
-
-(exception: #export (unknown_var {var Text})
- (exception.report
- ["Var" (%.text var)]))
-
-(def: void
- (Parser (Check Type))
- (<>.after //parser.void
- (<>\wrap (check\wrap .Any))))
-
-(template [<name> <parser> <reflection>]
- [(def: <name>
- (Parser (Check Type))
- (<>.after <parser>
- (<>\wrap (check\wrap (#.Primitive (//reflection.reflection <reflection>) #.Nil)))))]
-
- [boolean //parser.boolean //reflection.boolean]
- [byte //parser.byte //reflection.byte]
- [short //parser.short //reflection.short]
- [int //parser.int //reflection.int]
- [long //parser.long //reflection.long]
- [float //parser.float //reflection.float]
- [double //parser.double //reflection.double]
- [char //parser.char //reflection.char]
- )
-
-(def: primitive
- (Parser (Check Type))
- ($_ <>.either
- ..boolean
- ..byte
- ..short
- ..int
- ..long
- ..float
- ..double
- ..char
- ))
-
-(def: wildcard
- (Parser (Check Type))
- (<>.after //parser.wildcard
- (<>\wrap (check\map product.right
- check.existential))))
-
-(def: (var mapping)
- (-> Mapping (Parser (Check Type)))
- (do <>.monad
- [var //parser.var']
- (wrap (case (dictionary.get var mapping)
- #.None
- (check.throw ..unknown_var [var])
-
- (#.Some type)
- (check\wrap type)))))
-
-(def: (class' parameter)
- (-> (Parser (Check Type)) (Parser (Check Type)))
- (|> (do <>.monad
- [name //parser.class_name
- parameters (|> (<>.some parameter)
- (<>.after (<t>.this //signature.parameters_start))
- (<>.before (<t>.this //signature.parameters_end))
- (<>.default (list)))]
- (wrap (do {! check.monad}
- [parameters (monad.seq ! parameters)]
- (wrap (#.Primitive name parameters)))))
- (<>.after (<t>.this //descriptor.class_prefix))
- (<>.before (<t>.this //descriptor.class_suffix))))
-
-(template [<name> <prefix> <constructor>]
- [(def: <name>
- (-> (Parser (Check Type)) (Parser (Check Type)))
- (|> (<>.after (<t>.this <prefix>))
- ## TODO: Re-enable Lower and Upper, instead of using the simplified limit.
- ## (<>\map (check\map (|>> <ctor> .type)))
- ))]
-
- [lower //signature.lower_prefix ..Lower]
- [upper //signature.upper_prefix ..Upper]
- )
-
-(def: (parameter mapping)
- (-> Mapping (Parser (Check Type)))
- (<>.rec
- (function (_ parameter)
- (let [class (..class' parameter)]
- ($_ <>.either
- (..var mapping)
- ..wildcard
- (..lower class)
- (..upper class)
- class
- )))))
-
-(def: #export class
- (-> Mapping (Parser (Check Type)))
- (|>> ..parameter ..class'))
-
-(def: array
- (-> (Parser (Check Type)) (Parser (Check Type)))
- (|>> (<>\map (check\map (function (_ elementT)
- (case elementT
- (#.Primitive name #.Nil)
- (if (`` (or (~~ (template [<reflection>]
- [(text\= (//reflection.reflection <reflection>) name)]
-
- [//reflection.boolean]
- [//reflection.byte]
- [//reflection.short]
- [//reflection.int]
- [//reflection.long]
- [//reflection.float]
- [//reflection.double]
- [//reflection.char]))))
- (#.Primitive (|> name //reflection.class //reflection.array //reflection.reflection) #.Nil)
- (|> elementT array.Array .type))
-
- _
- (|> elementT array.Array .type)))))
- (<>.after (<t>.this //descriptor.array_prefix))))
-
-(def: #export (type mapping)
- (-> Mapping (Parser (Check Type)))
- (<>.rec
- (function (_ type)
- ($_ <>.either
- ..primitive
- (parameter mapping)
- (..array type)
- ))))
-
-(def: #export (return mapping)
- (-> Mapping (Parser (Check Type)))
- ($_ <>.either
- ..void
- (..type mapping)
- ))
-
-(def: #export (check operation input)
- (All [a] (-> (Parser (Check a)) Text (Check a)))
- (case (<t>.run operation input)
- (#try.Success check)
- check
-
- (#try.Failure error)
- (check.fail error)))
diff --git a/stdlib/source/lux/target/jvm/type/parser.lux b/stdlib/source/lux/target/jvm/type/parser.lux
deleted file mode 100644
index 56e992082..000000000
--- a/stdlib/source/lux/target/jvm/type/parser.lux
+++ /dev/null
@@ -1,252 +0,0 @@
-(.module:
- [lux (#- Type int char primitive)
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["." function]
- ["<>" parser ("#\." monad)
- ["<t>" text (#+ Parser)]]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list]]]]
- ["." // (#+ Type)
- [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)]
- ["#." signature]
- ["#." descriptor]
- ["." // #_
- [encoding
- ["#." name (#+ External)]]]])
-
-(template [<category> <name> <signature> <type>]
- [(def: #export <name>
- (Parser (Type <category>))
- (<>.after (<t>.this (//signature.signature <signature>))
- (<>\wrap <type>)))]
-
- [Void void //signature.void //.void]
- [Primitive boolean //signature.boolean //.boolean]
- [Primitive byte //signature.byte //.byte]
- [Primitive short //signature.short //.short]
- [Primitive int //signature.int //.int]
- [Primitive long //signature.long //.long]
- [Primitive float //signature.float //.float]
- [Primitive double //signature.double //.double]
- [Primitive char //signature.char //.char]
- [Parameter wildcard //signature.wildcard //.wildcard]
- )
-
-(def: #export primitive
- (Parser (Type Primitive))
- ($_ <>.either
- ..boolean
- ..byte
- ..short
- ..int
- ..long
- ..float
- ..double
- ..char
- ))
-
-(def: var/head
- (format "abcdefghijklmnopqrstuvwxyz"
- "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- "_"))
-
-(def: var/tail
- (format var/head
- "0123456789$"))
-
-(def: class/set
- (format var/tail //name.internal_separator))
-
-(template [<type> <name> <head> <tail> <adapter>]
- [(def: #export <name>
- (Parser <type>)
- (\ <>.functor map <adapter>
- (<t>.slice (<t>.and! (<t>.one_of! <head>)
- (<t>.some! (<t>.one_of! <tail>))))))]
-
- [External class_name class/set class/set (|>> //name.internal //name.external)]
- [Text var_name var/head var/tail function.identity]
- )
-
-(def: #export var'
- (Parser Text)
- (|> ..var_name
- (<>.after (<t>.this //signature.var_prefix))
- (<>.before (<t>.this //descriptor.class_suffix))))
-
-(def: #export var
- (Parser (Type Var))
- (<>\map //.var ..var'))
-
-(def: #export var?
- (-> (Type Value) (Maybe Text))
- (|>> //.signature
- //signature.signature
- (<t>.run ..var')
- try.to_maybe))
-
-(def: #export name
- (-> (Type Var) Text)
- (|>> //.signature
- //signature.signature
- (<t>.run ..var')
- try.assume))
-
-(template [<name> <prefix> <constructor>]
- [(def: <name>
- (-> (Parser (Type Class)) (Parser (Type Parameter)))
- (|>> (<>.after (<t>.this <prefix>))
- (<>\map <constructor>)))]
-
- [lower //signature.lower_prefix //.lower]
- [upper //signature.upper_prefix //.upper]
- )
-
-(def: (class'' parameter)
- (-> (Parser (Type Parameter)) (Parser [External (List (Type Parameter))]))
- (|> (do <>.monad
- [name ..class_name
- parameters (|> (<>.some parameter)
- (<>.after (<t>.this //signature.parameters_start))
- (<>.before (<t>.this //signature.parameters_end))
- (<>.default (list)))]
- (wrap [name parameters]))
- (<>.after (<t>.this //descriptor.class_prefix))
- (<>.before (<t>.this //descriptor.class_suffix))))
-
-(def: class'
- (-> (Parser (Type Parameter)) (Parser (Type Class)))
- (|>> ..class''
- (\ <>.monad map (product.uncurry //.class))))
-
-(def: #export parameter
- (Parser (Type Parameter))
- (<>.rec
- (function (_ parameter)
- (let [class (..class' parameter)]
- ($_ <>.either
- ..var
- ..wildcard
- (..lower class)
- (..upper class)
- class
- )))))
-
-(def: #export array'
- (-> (Parser (Type Value)) (Parser (Type Array)))
- (|>> (<>.after (<t>.this //descriptor.array_prefix))
- (<>\map //.array)))
-
-(def: #export class
- (Parser (Type Class))
- (..class' ..parameter))
-
-(template [<name> <prefix> <constructor>]
- [(def: #export <name>
- (-> (Type Value) (Maybe (Type Class)))
- (|>> //.signature
- //signature.signature
- (<t>.run (<>.after (<t>.this <prefix>) ..class))
- try.to_maybe))]
-
- [lower? //signature.lower_prefix //.lower]
- [upper? //signature.upper_prefix //.upper]
- )
-
-(def: #export read_class
- (-> (Type Class) [External (List (Type Parameter))])
- (|>> //.signature
- //signature.signature
- (<t>.run (..class'' ..parameter))
- try.assume))
-
-(def: #export value
- (Parser (Type Value))
- (<>.rec
- (function (_ value)
- ($_ <>.either
- ..primitive
- ..parameter
- (..array' value)
- ))))
-
-(def: #export array
- (Parser (Type Array))
- (..array' ..value))
-
-(def: #export object
- (Parser (Type Object))
- ($_ <>.either
- ..class
- ..array))
-
-(def: inputs
- (|> (<>.some ..value)
- (<>.after (<t>.this //signature.arguments_start))
- (<>.before (<t>.this //signature.arguments_end))))
-
-(def: #export return
- (Parser (Type Return))
- (<>.either ..void
- ..value))
-
-(def: exception
- (Parser (Type Class))
- (|> (..class' ..parameter)
- (<>.after (<t>.this //signature.exception_prefix))))
-
-(def: #export method
- (-> (Type Method)
- [(List (Type Value)) (Type Return) (List (Type Class))])
- (let [parser (do <>.monad
- [inputs ..inputs
- return ..return
- exceptions (<>.some ..exception)]
- (wrap [inputs return exceptions]))]
- (|>> //.signature
- //signature.signature
- (<t>.run parser)
- try.assume)))
-
-(template [<name> <category> <parser>]
- [(def: #export <name>
- (-> (Type Value) (Maybe <category>))
- (|>> //.signature
- //signature.signature
- (<t>.run <parser>)
- try.to_maybe))]
-
- [array? (Type Value)
- (do <>.monad
- [_ (<t>.this //descriptor.array_prefix)]
- ..value)]
- [class? [External (List (Type Parameter))]
- (..class'' ..parameter)]
-
- [primitive? (Type Primitive) ..primitive]
- [wildcard? (Type Parameter) ..wildcard]
- [parameter? (Type Parameter) ..parameter]
- [object? (Type Object) ..object]
- )
-
-(def: #export declaration
- (-> (Type Declaration) [External (List (Type Var))])
- (let [declaration' (: (Parser [External (List (Type Var))])
- (|> (<>.and ..class_name
- (|> (<>.some ..var)
- (<>.after (<t>.this //signature.parameters_start))
- (<>.before (<t>.this //signature.parameters_end))
- (<>.default (list))))
- (<>.after (<t>.this //descriptor.class_prefix))
- (<>.before (<t>.this //descriptor.class_suffix))))]
- (|>> //.signature
- //signature.signature
- (<t>.run declaration')
- try.assume)))
diff --git a/stdlib/source/lux/target/jvm/type/reflection.lux b/stdlib/source/lux/target/jvm/type/reflection.lux
deleted file mode 100644
index 7d775b1f9..000000000
--- a/stdlib/source/lux/target/jvm/type/reflection.lux
+++ /dev/null
@@ -1,103 +0,0 @@
-(.module:
- [lux (#- int char)
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]
- [type
- abstract]]
- ["." // #_
- [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)]
- ["#." descriptor]
- [//
- [encoding
- ["#." name (#+ External)]]]])
-
-(abstract: #export (Reflection category)
- Text
-
- (def: #export reflection
- (-> (Reflection Any) Text)
- (|>> :representation))
-
- (implementation: #export equivalence
- (All [category] (Equivalence (Reflection category)))
-
- (def: (= parameter subject)
- (text\= (:representation parameter) (:representation subject))))
-
- (template [<category> <name> <reflection>]
- [(def: #export <name>
- (Reflection <category>)
- (:abstraction <reflection>))]
-
- [Void void "void"]
- [Primitive boolean "boolean"]
- [Primitive byte "byte"]
- [Primitive short "short"]
- [Primitive int "int"]
- [Primitive long "long"]
- [Primitive float "float"]
- [Primitive double "double"]
- [Primitive char "char"]
- )
-
- (def: #export class
- (-> External (Reflection Class))
- (|>> :abstraction))
-
- (def: #export (declaration name)
- (-> External (Reflection Declaration))
- (:transmutation (..class name)))
-
- (def: #export as_class
- (-> (Reflection Declaration) (Reflection Class))
- (|>> :transmutation))
-
- (def: #export (array element)
- (-> (Reflection Value) (Reflection Array))
- (let [element' (:representation element)
- elementR (`` (cond (text.starts_with? //descriptor.array_prefix element')
- element'
-
- (~~ (template [<primitive> <descriptor>]
- [(\ ..equivalence = <primitive> element)
- (//descriptor.descriptor <descriptor>)]
-
- [..boolean //descriptor.boolean]
- [..byte //descriptor.byte]
- [..short //descriptor.short]
- [..int //descriptor.int]
- [..long //descriptor.long]
- [..float //descriptor.float]
- [..double //descriptor.double]
- [..char //descriptor.char]))
-
- (|> element'
- //descriptor.class
- //descriptor.descriptor
- (text.replace_all //name.internal_separator
- //name.external_separator))))]
- (|> elementR
- (format //descriptor.array_prefix)
- :abstraction)))
-
- (template [<name> <category>]
- [(def: #export <name>
- (Reflection <category>)
- (:transmutation
- (..class "java.lang.Object")))]
-
- [var Var]
- [wildcard Parameter]
- )
-
- (def: #export (lower reflection)
- (-> (Reflection Class) (Reflection Parameter))
- ..wildcard)
-
- (def: #export upper
- (-> (Reflection Class) (Reflection Parameter))
- (|>> :transmutation))
- )
diff --git a/stdlib/source/lux/target/jvm/type/signature.lux b/stdlib/source/lux/target/jvm/type/signature.lux
deleted file mode 100644
index ab207bc39..000000000
--- a/stdlib/source/lux/target/jvm/type/signature.lux
+++ /dev/null
@@ -1,133 +0,0 @@
-(.module:
- [lux (#- int char)
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]]
- [data
- ["." text ("#\." hash)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]]]
- [type
- abstract]]
- ["." // #_
- [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)]
- ["#." descriptor]
- ["/#" // #_
- [encoding
- ["#." name (#+ External)]]]])
-
-(abstract: #export (Signature category)
- Text
-
- (def: #export signature
- (-> (Signature Any) Text)
- (|>> :representation))
-
- (template [<category> <name> <descriptor>]
- [(def: #export <name>
- (Signature <category>)
- (:abstraction (//descriptor.descriptor <descriptor>)))]
-
- [Void void //descriptor.void]
- [Primitive boolean //descriptor.boolean]
- [Primitive byte //descriptor.byte]
- [Primitive short //descriptor.short]
- [Primitive int //descriptor.int]
- [Primitive long //descriptor.long]
- [Primitive float //descriptor.float]
- [Primitive double //descriptor.double]
- [Primitive char //descriptor.char]
- )
-
- (def: #export array
- (-> (Signature Value) (Signature Array))
- (|>> :representation
- (format //descriptor.array_prefix)
- :abstraction))
-
- (def: #export wildcard
- (Signature Parameter)
- (:abstraction "*"))
-
- (def: #export var_prefix "T")
-
- (def: #export var
- (-> Text (Signature Var))
- (|>> (text.enclose [..var_prefix //descriptor.class_suffix])
- :abstraction))
-
- (def: #export lower_prefix "-")
- (def: #export upper_prefix "+")
-
- (template [<name> <prefix>]
- [(def: #export <name>
- (-> (Signature Class) (Signature Parameter))
- (|>> :representation (format <prefix>) :abstraction))]
-
- [lower ..lower_prefix]
- [upper ..upper_prefix]
- )
-
- (def: #export parameters_start "<")
- (def: #export parameters_end ">")
-
- (def: #export (class name parameters)
- (-> External (List (Signature Parameter)) (Signature Class))
- (:abstraction
- (format //descriptor.class_prefix
- (|> name ///name.internal ///name.read)
- (case parameters
- #.Nil
- ""
-
- _
- (format ..parameters_start
- (|> parameters
- (list\map ..signature)
- (text.join_with ""))
- ..parameters_end))
- //descriptor.class_suffix)))
-
- (def: #export (declaration name variables)
- (-> External (List (Signature Var)) (Signature Declaration))
- (:transmutation (..class name variables)))
-
- (def: #export as_class
- (-> (Signature Declaration) (Signature Class))
- (|>> :transmutation))
-
- (def: #export arguments_start "(")
- (def: #export arguments_end ")")
-
- (def: #export exception_prefix "^")
-
- (def: #export (method [inputs output exceptions])
- (-> [(List (Signature Value))
- (Signature Return)
- (List (Signature Class))]
- (Signature Method))
- (:abstraction
- (format (|> inputs
- (list\map ..signature)
- (text.join_with "")
- (text.enclose [..arguments_start
- ..arguments_end]))
- (:representation output)
- (|> exceptions
- (list\map (|>> :representation (format ..exception_prefix)))
- (text.join_with "")))))
-
- (implementation: #export equivalence
- (All [category] (Equivalence (Signature category)))
-
- (def: (= parameter subject)
- (text\= (:representation parameter)
- (:representation subject))))
-
- (implementation: #export hash
- (All [category] (Hash (Signature category)))
-
- (def: &equivalence ..equivalence)
- (def: hash (|>> :representation text\hash)))
- )
diff --git a/stdlib/source/lux/target/jvm/version.lux b/stdlib/source/lux/target/jvm/version.lux
deleted file mode 100644
index 66f97351d..000000000
--- a/stdlib/source/lux/target/jvm/version.lux
+++ /dev/null
@@ -1,37 +0,0 @@
-(.module:
- [lux #*
- [control
- ["." try]]]
- ["." // #_
- [encoding
- ["#." unsigned (#+ U2)]]])
-
-(type: #export Version U2)
-(type: #export Minor Version)
-(type: #export Major Version)
-
-(def: #export default_minor
- Minor
- (|> 0 //unsigned.u2 try.assume))
-
-(template [<number> <name>]
- [(def: #export <name>
- Major
- (|> <number> //unsigned.u2 try.assume))]
-
- [45 v1_1]
- [46 v1_2]
- [47 v1_3]
- [48 v1_4]
- [49 v5_0]
- [50 v6_0]
- [51 v7]
- [52 v8]
- [53 v9]
- [54 v10]
- [55 v11]
- [56 v12]
- )
-
-(def: #export writer
- //unsigned.writer/2)
diff --git a/stdlib/source/lux/target/lua.lux b/stdlib/source/lux/target/lua.lux
deleted file mode 100644
index fe675da0f..000000000
--- a/stdlib/source/lux/target/lua.lux
+++ /dev/null
@@ -1,415 +0,0 @@
-(.module:
- [lux (#- Location Code int if cond function or and not let ^)
- ["@" target]
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]
- ["." enum]]
- [control
- [pipe (#+ case> cond> new>)]
- [parser
- ["<.>" code]]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [macro
- [syntax (#+ syntax:)]
- ["." template]
- ["." code]]
- [math
- [number
- ["n" nat]
- ["i" int]
- ["f" frac]]]
- [type
- abstract]])
-
-(def: nest
- (-> Text Text)
- (.let [nested_new_line (format text.new_line text.tab)]
- (|>> (format text.new_line)
- (text.replace_all text.new_line nested_new_line))))
-
-(def: input_separator ", ")
-
-(abstract: #export (Code brand)
- Text
-
- (implementation: #export equivalence
- (All [brand] (Equivalence (Code brand)))
-
- (def: (= reference subject)
- (\ text.equivalence = (:representation reference) (:representation subject))))
-
- (implementation: #export hash
- (All [brand] (Hash (Code brand)))
-
- (def: &equivalence ..equivalence)
- (def: hash (|>> :representation (\ text.hash hash))))
-
- (def: #export manual
- (-> Text Code)
- (|>> :abstraction))
-
- (def: #export code
- (-> (Code Any) Text)
- (|>> :representation))
-
- (template [<type> <super>+]
- [(with_expansions [<brand> (template.identifier [<type> "'"])]
- (abstract: (<brand> brand) Any)
- (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))]
-
- [Expression [Code]]
- [Computation [Expression' Code]]
- [Location [Computation' Expression' Code]]
- [Statement [Code]]
- )
-
- (template [<type> <super>+]
- [(with_expansions [<brand> (template.identifier [<type> "'"])]
- (abstract: #export <brand> Any)
- (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))]
-
- [Literal [Computation' Expression' Code]]
- [Var [Location' Computation' Expression' Code]]
- [Access [Location' Computation' Expression' Code]]
- [Label [Code]]
- )
-
- (def: #export nil
- Literal
- (:abstraction "nil"))
-
- (def: #export bool
- (-> Bit Literal)
- (|>> (case> #0 "false"
- #1 "true")
- :abstraction))
-
- (def: #export int
- (-> Int Literal)
- ## Integers must be turned into hexadecimal to avoid quirks in how Lua parses integers.
- ## In particular, the number -9223372036854775808 will be incorrectly parsed as a float by Lua.
- (.let [to_hex (\ n.hex encode)]
- (|>> .nat
- to_hex
- (format "0x")
- :abstraction)))
-
- (def: #export float
- (-> Frac Literal)
- (|>> (cond> [(f.= f.positive_infinity)]
- [(new> "(1.0/0.0)" [])]
-
- [(f.= f.negative_infinity)]
- [(new> "(-1.0/0.0)" [])]
-
- [(f.= f.not_a_number)]
- [(new> "(0.0/0.0)" [])]
-
- ## else
- [%.frac (text.replace_all "+" "")])
- :abstraction))
-
- (def: sanitize
- (-> Text Text)
- (`` (|>> (~~ (template [<find> <replace>]
- [(text.replace_all <find> <replace>)]
-
- ["\" "\\"]
- [text.tab "\t"]
- [text.vertical_tab "\v"]
- [text.null "\0"]
- [text.back_space "\b"]
- [text.form_feed "\f"]
- [text.new_line "\n"]
- [text.carriage_return "\r"]
- [text.double_quote (format "\" text.double_quote)]
- ))
- )))
-
- (def: #export string
- (-> Text Literal)
- (|>> ..sanitize (text.enclose' text.double_quote) :abstraction))
-
- (def: #export multi
- (-> (List Expression) Literal)
- (|>> (list\map ..code)
- (text.join_with ..input_separator)
- :abstraction))
-
- (def: #export array
- (-> (List Expression) Literal)
- (|>> (list\map ..code)
- (text.join_with ..input_separator)
- (text.enclose ["{" "}"])
- :abstraction))
-
- (def: #export table
- (-> (List [Text Expression]) Literal)
- (|>> (list\map (.function (_ [key value])
- (format key " = " (:representation value))))
- (text.join_with ..input_separator)
- (text.enclose ["{" "}"])
- :abstraction))
-
- (def: #export (nth idx array)
- (-> Expression Expression Access)
- (:abstraction (format (:representation array) "[" (:representation idx) "]")))
-
- (def: #export (the field table)
- (-> Text Expression Computation)
- (:abstraction (format (:representation table) "." field)))
-
- (def: #export length
- (-> Expression Computation)
- (|>> :representation
- (text.enclose ["#(" ")"])
- :abstraction))
-
- (def: #export (apply/* args func)
- (-> (List Expression) Expression Computation)
- (|> args
- (list\map ..code)
- (text.join_with ..input_separator)
- (text.enclose ["(" ")"])
- (format (:representation func))
- :abstraction))
-
- (def: #export (do method args table)
- (-> Text (List Expression) Expression Computation)
- (|> args
- (list\map ..code)
- (text.join_with ..input_separator)
- (text.enclose ["(" ")"])
- (format (:representation table) ":" method)
- :abstraction))
-
- (template [<op> <name>]
- [(def: #export (<name> parameter subject)
- (-> Expression Expression Expression)
- (:abstraction (format "("
- (:representation subject)
- " " <op> " "
- (:representation parameter)
- ")")))]
-
- ["==" =]
- ["<" <]
- ["<=" <=]
- [">" >]
- [">=" >=]
- ["+" +]
- ["-" -]
- ["*" *]
- ["^" ^]
- ["/" /]
- ["//" //]
- ["%" %]
- [".." concat]
-
- ["or" or]
- ["and" and]
- ["|" bit_or]
- ["&" bit_and]
- ["~" bit_xor]
-
- ["<<" bit_shl]
- [">>" bit_shr]
- )
-
- (template [<name> <unary>]
- [(def: #export (<name> subject)
- (-> Expression Expression)
- (:abstraction (format "(" <unary> " " (:representation subject) ")")))]
-
- [not "not"]
- [negate "-"]
- )
-
- (template [<name> <type>]
- [(def: #export <name>
- (-> Text <type>)
- (|>> :abstraction))]
-
- [var Var]
- [label Label]
- )
-
- (def: #export statement
- (-> Expression Statement)
- (|>> :representation :abstraction))
-
- (def: #export (then pre! post!)
- (-> Statement Statement Statement)
- (:abstraction
- (format (:representation pre!)
- text.new_line
- (:representation post!))))
-
- (def: locations
- (-> (List Location) Text)
- (|>> (list\map ..code)
- (text.join_with ..input_separator)))
-
- (def: #export (local vars)
- (-> (List Var) Statement)
- (:abstraction (format "local " (..locations vars))))
-
- (def: #export (set vars value)
- (-> (List Location) Expression Statement)
- (:abstraction (format (..locations vars) " = " (:representation value))))
-
- (def: #export (let vars value)
- (-> (List Var) Expression Statement)
- (:abstraction (format "local " (..locations vars) " = " (:representation value))))
-
- (def: #export (local/1 var value)
- (-> Var Expression Statement)
- (:abstraction (format "local " (:representation var) " = " (:representation value))))
-
- (def: #export (if test then! else!)
- (-> Expression Statement Statement Statement)
- (:abstraction (format "if " (:representation test)
- text.new_line "then" (..nest (:representation then!))
- text.new_line "else" (..nest (:representation else!))
- text.new_line "end")))
-
- (def: #export (when test then!)
- (-> Expression Statement Statement)
- (:abstraction (format "if " (:representation test)
- text.new_line "then" (..nest (:representation then!))
- text.new_line "end")))
-
- (def: #export (while test body!)
- (-> Expression Statement Statement)
- (:abstraction
- (format "while " (:representation test) " do"
- (..nest (:representation body!))
- text.new_line "end")))
-
- (def: #export (repeat until body!)
- (-> Expression Statement Statement)
- (:abstraction
- (format "repeat"
- (..nest (:representation body!))
- text.new_line "until " (:representation until))))
-
- (def: #export (for_in vars source body!)
- (-> (List Var) Expression Statement Statement)
- (:abstraction
- (format "for " (|> vars
- (list\map ..code)
- (text.join_with ..input_separator))
- " in " (:representation source) " do"
- (..nest (:representation body!))
- text.new_line "end")))
-
- (def: #export (for_step var from to step body!)
- (-> Var Expression Expression Expression Statement
- Statement)
- (:abstraction
- (format "for " (:representation var)
- " = " (:representation from)
- ..input_separator (:representation to)
- ..input_separator (:representation step) " do"
- (..nest (:representation body!))
- text.new_line "end")))
-
- (def: #export (return value)
- (-> Expression Statement)
- (:abstraction (format "return " (:representation value))))
-
- (def: #export (closure args body!)
- (-> (List Var) Statement Expression)
- (|> (format "function " (|> args
- ..locations
- (text.enclose ["(" ")"]))
- (..nest (:representation body!))
- text.new_line "end")
- (text.enclose ["(" ")"])
- :abstraction))
-
- (template [<name> <code>]
- [(def: #export (<name> name args body!)
- (-> Var (List Var) Statement Statement)
- (:abstraction
- (format <code> " " (:representation name)
- (|> args
- ..locations
- (text.enclose ["(" ")"]))
- (..nest (:representation body!))
- text.new_line "end")))]
-
- [function "function"]
- [local_function "local function"]
- )
-
- (def: #export break
- Statement
- (:abstraction "break"))
-
- (def: #export (set_label label)
- (-> Label Statement)
- (:abstraction (format "::" (:representation label) "::")))
-
- (def: #export (go_to label)
- (-> Label Statement)
- (:abstraction (format "goto " (:representation label))))
- )
-
-(def: #export (cond clauses else!)
- (-> (List [Expression Statement]) Statement Statement)
- (list\fold (.function (_ [test then!] next!)
- (..if test then! next!))
- else!
- (list.reverse clauses)))
-
-(syntax: (arity_inputs {arity <code>.nat})
- (wrap (case arity
- 0 (.list)
- _ (|> (dec arity)
- (enum.range n.enum 0)
- (list\map (|>> %.nat code.local_identifier))))))
-
-(syntax: (arity_types {arity <code>.nat})
- (wrap (list.repeat arity (` ..Expression))))
-
-(template [<arity> <function>+]
- [(with_expansions [<apply> (template.identifier ["apply/" <arity>])
- <inputs> (arity_inputs <arity>)
- <types> (arity_types <arity>)
- <definitions> (template.splice <function>+)]
- (def: #export (<apply> function <inputs>)
- (-> Expression <types> Computation)
- (..apply/* (.list <inputs>) function))
-
- (template [<function>]
- [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>]))
- (<apply> (..var <function>))))]
-
- <definitions>))]
-
- [1
- [["error"]
- ["print"]
- ["require"]
- ["type"]
- ["ipairs"]]]
-
- [2
- [["print"]
- ["error"]]]
-
- [3
- [["print"]]]
-
- [4
- []]
-
- [5
- []]
- )
diff --git a/stdlib/source/lux/target/php.lux b/stdlib/source/lux/target/php.lux
deleted file mode 100644
index f85bf5f03..000000000
--- a/stdlib/source/lux/target/php.lux
+++ /dev/null
@@ -1,544 +0,0 @@
-(.module:
- [lux (#- Location Code Global static int if cond or and not comment for try)
- ["@" target]
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]
- ["." enum]]
- [control
- [pipe (#+ case> cond> new>)]
- [parser
- ["<.>" code]]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [macro
- [syntax (#+ syntax:)]
- ["." template]
- ["." code]]
- [math
- [number
- ["n" nat]
- ["f" frac]]]
- [type
- abstract]])
-
-(def: input_separator ", ")
-(def: statement_suffix ";")
-
-(def: nest
- (-> Text Text)
- (.let [nested_new_line (format text.new_line text.tab)]
- (|>> (format text.new_line)
- (text.replace_all text.new_line nested_new_line))))
-
-(def: block
- (-> Text Text)
- (|>> ..nest (text.enclose ["{" (format text.new_line "}")])))
-
-(def: group
- (-> Text Text)
- (text.enclose ["(" ")"]))
-
-(abstract: #export (Code brand)
- Text
-
- (implementation: #export equivalence
- (All [brand] (Equivalence (Code brand)))
-
- (def: (= reference subject)
- (\ text.equivalence = (:representation reference) (:representation subject))))
-
- (implementation: #export hash
- (All [brand] (Hash (Code brand)))
-
- (def: &equivalence ..equivalence)
- (def: hash (|>> :representation (\ text.hash hash))))
-
- (def: #export manual
- (-> Text Code)
- (|>> :abstraction))
-
- (def: #export code
- (-> (Code Any) Text)
- (|>> :representation))
-
- (template [<type> <super>+]
- [(with_expansions [<brand> (template.identifier [<type> "'"])]
- (abstract: (<brand> brand) Any)
- (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))]
-
- [Expression [Code]]
- [Computation [Expression' Code]]
- [Location [Computation' Expression' Code]]
- [Statement [Code]]
- )
-
- (template [<type> <super>+]
- [(with_expansions [<brand> (template.identifier [<type> "'"])]
- (abstract: #export <brand> Any)
- (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))]
-
- [Literal [Computation' Expression' Code]]
- [Var [Location' Computation' Expression' Code]]
- [Access [Location' Computation' Expression' Code]]
- [Constant [Location' Computation' Expression' Code]]
- [Global [Location' Computation' Expression' Code]]
- [Label [Code]]
- )
-
- (type: #export Argument
- {#reference? Bit
- #var Var})
-
- (def: #export ;
- (-> Expression Statement)
- (|>> :representation
- (text.suffix ..statement_suffix)
- :abstraction))
-
- (def: #export var
- (-> Text Var)
- (|>> (format "$") :abstraction))
-
- (template [<name> <type>]
- [(def: #export <name>
- (-> Text <type>)
- (|>> :abstraction))]
-
- [constant Constant]
- [label Label]
- )
-
- (def: #export (set_label label)
- (-> Label Statement)
- (:abstraction (format (:representation label) ":")))
-
- (def: #export (go_to label)
- (-> Label Statement)
- (:abstraction
- (format "goto " (:representation label) ..statement_suffix)))
-
- (def: #export null
- Literal
- (:abstraction "NULL"))
-
- (def: #export bool
- (-> Bit Literal)
- (|>> (case> #0 "false"
- #1 "true")
- :abstraction))
-
- (def: #export int
- (-> Int Literal)
- (.let [to_hex (\ n.hex encode)]
- (|>> .nat
- to_hex
- (format "0x")
- :abstraction)))
-
- (def: #export float
- (-> Frac Literal)
- (|>> (cond> [(f.= f.positive_infinity)]
- [(new> "+INF" [])]
-
- [(f.= f.negative_infinity)]
- [(new> "-INF" [])]
-
- [(f.= f.not_a_number)]
- [(new> "NAN" [])]
-
- ## else
- [%.frac])
- :abstraction))
-
- (def: sanitize
- (-> Text Text)
- (`` (|>> (~~ (template [<find> <replace>]
- [(text.replace_all <find> <replace>)]
-
- ["\" "\\"]
- [text.tab "\t"]
- [text.vertical_tab "\v"]
- [text.null "\0"]
- [text.back_space "\b"]
- [text.form_feed "\f"]
- [text.new_line "\n"]
- [text.carriage_return "\r"]
- [text.double_quote (format "\" text.double_quote)]
- ["$" "\$"]
- ))
- )))
-
- (def: #export string
- (-> Text Literal)
- (|>> ..sanitize
- (text.enclose [text.double_quote text.double_quote])
- :abstraction))
-
- (def: arguments
- (-> (List Expression) Text)
- (|>> (list\map ..code) (text.join_with ..input_separator) ..group))
-
- (def: #export (apply/* args func)
- (-> (List Expression) Expression Computation)
- (|> (format (:representation func) (..arguments args))
- :abstraction))
-
- ## TODO: Remove when no longer using JPHP.
- (def: #export (apply/*' args func)
- (-> (List Expression) Expression Computation)
- (apply/* (list& func args) (..constant "call_user_func")))
-
- (def: parameters
- (-> (List Argument) Text)
- (|>> (list\map (function (_ [reference? var])
- (.if reference?
- (format "&" (:representation var))
- (:representation var))))
- (text.join_with ..input_separator)
- ..group))
-
- (template [<name> <reference?>]
- [(def: #export <name>
- (-> Var Argument)
- (|>> [<reference?>]))]
-
- [parameter #0]
- [reference #1]
- )
-
- (def: #export (closure uses arguments body!)
- (-> (List Argument) (List Argument) Statement Literal)
- (let [uses (case uses
- #.Nil
- ""
-
- _
- (format "use " (..parameters uses)))]
- (|> (format "function " (..parameters arguments)
- " " uses " "
- (..block (:representation body!)))
- ..group
- :abstraction)))
-
- (syntax: (arity_inputs {arity <code>.nat})
- (wrap (case arity
- 0 (.list)
- _ (|> (dec arity)
- (enum.range n.enum 0)
- (list\map (|>> %.nat code.local_identifier))))))
-
- (syntax: (arity_types {arity <code>.nat})
- (wrap (list.repeat arity (` ..Expression))))
-
- (template [<arity> <function>+]
- [(with_expansions [<apply> (template.identifier ["apply/" <arity>])
- <inputs> (arity_inputs <arity>)
- <types> (arity_types <arity>)
- <definitions> (template.splice <function>+)]
- (def: #export (<apply> function [<inputs>])
- (-> Expression [<types>] Computation)
- (..apply/* (.list <inputs>) function))
-
- (template [<function>]
- [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>]))
- (<apply> (..constant <function>))))]
-
- <definitions>))]
-
- [0
- [["func_num_args"]
- ["func_get_args"]
- ["time"]
- ["phpversion"]]]
-
- [1
- [["isset"]
- ["var_dump"]
- ["is_null"]
- ["empty"]
- ["count"]
- ["array_pop"]
- ["array_reverse"]
- ["intval"]
- ["floatval"]
- ["strval"]
- ["ord"]
- ["chr"]
- ["print"]
- ["exit"]
- ["iconv_strlen"] ["strlen"]
- ["log"]
- ["ceil"]
- ["floor"]
- ["is_nan"]]]
-
- [2
- [["intdiv"]
- ["fmod"]
- ["number_format"]
- ["array_key_exists"]
- ["call_user_func_array"]
- ["array_slice"]
- ["array_push"]
- ["pack"]
- ["unpack"]
- ["iconv_strpos"] ["strpos"]
- ["pow"]
- ["max"]]]
-
- [3
- [["array_fill"]
- ["array_slice"]
- ["array_splice"]
- ["iconv"]
- ["iconv_strpos"] ["strpos"]
- ["iconv_substr"] ["substr"]]]
- )
-
- (def: #export (key_value key value)
- (-> Expression Expression Expression)
- (:abstraction (format (:representation key) " => " (:representation value))))
-
- (def: #export (array/* values)
- (-> (List Expression) Literal)
- (|> values
- (list\map ..code)
- (text.join_with ..input_separator)
- ..group
- (format "array")
- :abstraction))
-
- (def: #export (array_merge/+ required optionals)
- (-> Expression (List Expression) Computation)
- (..apply/* (list& required optionals) (..constant "array_merge")))
-
- (def: #export (array/** kvs)
- (-> (List [Expression Expression]) Literal)
- (|> kvs
- (list\map (function (_ [key value])
- (format (:representation key) " => " (:representation value))))
- (text.join_with ..input_separator)
- ..group
- (format "array")
- :abstraction))
-
- (def: #export (new constructor inputs)
- (-> Constant (List Expression) Computation)
- (|> (format "new " (:representation constructor) (arguments inputs))
- :abstraction))
-
- (def: #export (the field object)
- (-> Text Expression Computation)
- (|> (format (:representation object) "->" field)
- :abstraction))
-
- (def: #export (do method inputs object)
- (-> Text (List Expression) Expression Computation)
- (|> (format (:representation (..the method object))
- (..arguments inputs))
- :abstraction))
-
- (def: #export (nth idx array)
- (-> Expression Expression Access)
- (|> (format (:representation array) "[" (:representation idx) "]")
- :abstraction))
-
- (def: #export (global name)
- (-> Text Global)
- (|> (..var "GLOBALS") (..nth (..string name)) :transmutation))
-
- (def: #export (? test then else)
- (-> Expression Expression Expression Computation)
- (|> (format (..group (:representation test)) " ? "
- (..group (:representation then)) " : "
- (..group (:representation else)))
- ..group
- :abstraction))
-
- (template [<name> <op>]
- [(def: #export (<name> parameter subject)
- (-> Expression Expression Computation)
- (|> (format (:representation subject) " " <op> " " (:representation parameter))
- ..group
- :abstraction))]
-
- [or "||"]
- [and "&&"]
- [== "=="]
- [=== "==="]
- [< "<"]
- [<= "<="]
- [> ">"]
- [>= ">="]
- [+ "+"]
- [- "-"]
- [* "*"]
- [/ "/"]
- [% "%"]
- [bit_or "|"]
- [bit_and "&"]
- [bit_xor "^"]
- [bit_shl "<<"]
- [bit_shr ">>"]
- [concat "."]
- )
-
- (template [<unary> <name>]
- [(def: #export <name>
- (-> Computation Computation)
- (|>> :representation (format <unary>) :abstraction))]
-
- ["!" not]
- ["~" bit_not]
- ["-" negate]
- )
-
- (def: #export (set var value)
- (-> Location Expression Computation)
- (|> (format (:representation var) " = " (:representation value))
- ..group
- :abstraction))
-
- (def: #export (set! var value)
- (-> Location Expression Statement)
- (:abstraction (format (:representation var) " = " (:representation value) ";")))
-
- (def: #export (set? var)
- (-> Var Computation)
- (..apply/1 [var] (..constant "isset")))
-
- (template [<name> <modifier>]
- [(def: #export <name>
- (-> Var Statement)
- (|>> :representation (format <modifier> " ") (text.suffix ..statement_suffix) :abstraction))]
-
- [define_global "global"]
- )
-
- (template [<name> <modifier> <location>]
- [(def: #export (<name> location value)
- (-> <location> Expression Statement)
- (:abstraction (format <modifier> " " (:representation location)
- " = " (:representation value)
- ..statement_suffix)))]
-
- [define_static "static" Var]
- [define_constant "const" Constant]
- )
-
- (def: #export (if test then! else!)
- (-> Expression Statement Statement Statement)
- (:abstraction
- (format "if" (..group (:representation test)) " "
- (..block (:representation then!))
- " else "
- (..block (:representation else!)))))
-
- (def: #export (when test then!)
- (-> Expression Statement Statement)
- (:abstraction
- (format "if" (..group (:representation test)) " "
- (..block (:representation then!)))))
-
- (def: #export (then pre! post!)
- (-> Statement Statement Statement)
- (:abstraction
- (format (:representation pre!)
- text.new_line
- (:representation post!))))
-
- (def: #export (while test body!)
- (-> Expression Statement Statement)
- (:abstraction
- (format "while" (..group (:representation test)) " "
- (..block (:representation body!)))))
-
- (def: #export (do_while test body!)
- (-> Expression Statement Statement)
- (:abstraction
- (format "do " (..block (:representation body!))
- " while" (..group (:representation test))
- ..statement_suffix)))
-
- (def: #export (for_each array value body!)
- (-> Expression Var Statement Statement)
- (:abstraction
- (format "foreach(" (:representation array)
- " as " (:representation value)
- ") " (..block (:representation body!)))))
-
- (type: #export Except
- {#class Constant
- #exception Var
- #handler Statement})
-
- (def: (catch except)
- (-> Except Text)
- (let [declaration (format (:representation (get@ #class except))
- " " (:representation (get@ #exception except)))]
- (format "catch" (..group declaration) " "
- (..block (:representation (get@ #handler except))))))
-
- (def: #export (try body! excepts)
- (-> Statement (List Except) Statement)
- (:abstraction
- (format "try " (..block (:representation body!))
- text.new_line
- (|> excepts
- (list\map catch)
- (text.join_with text.new_line)))))
-
- (template [<name> <keyword>]
- [(def: #export <name>
- (-> Expression Statement)
- (|>> :representation (format <keyword> " ") (text.suffix ..statement_suffix) :abstraction))]
-
- [throw "throw"]
- [return "return"]
- [echo "echo"]
- )
-
- (def: #export (define name value)
- (-> Constant Expression Expression)
- (..apply/2 (..constant "define")
- [(|> name :representation ..string)
- value]))
-
- (def: #export (define_function name arguments body!)
- (-> Constant (List Argument) Statement Statement)
- (:abstraction
- (format "function " (:representation name)
- (..parameters arguments)
- " "
- (..block (:representation body!)))))
-
- (template [<name> <keyword>]
- [(def: #export <name>
- Statement
- (|> <keyword>
- (text.suffix ..statement_suffix)
- :abstraction))]
-
- [break "break"]
- [continue "continue"]
- )
-
- (def: #export splat
- (-> Expression Expression)
- (|>> :representation (format "...") :abstraction))
- )
-
-(def: #export (cond clauses else!)
- (-> (List [Expression Statement]) Statement Statement)
- (list\fold (function (_ [test then!] next!)
- (..if test then! next!))
- else!
- (list.reverse clauses)))
-
-(def: #export command_line_arguments
- Var
- (..var "argv"))
diff --git a/stdlib/source/lux/target/python.lux b/stdlib/source/lux/target/python.lux
deleted file mode 100644
index c4e03914f..000000000
--- a/stdlib/source/lux/target/python.lux
+++ /dev/null
@@ -1,500 +0,0 @@
-(.module:
- [lux (#- Location Code not or and list if cond int comment exec try)
- ["@" target]
- ["." ffi]
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]
- ["." enum]]
- [control
- [pipe (#+ new> case> cond>)]
- [parser
- ["<.>" code]]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [macro
- [syntax (#+ syntax:)]
- ["." template]
- ["." code]]
- [math
- [number
- ["n" nat]
- ["f" frac]]]
- [type
- abstract]])
-
-(def: expression
- (-> Text Text)
- (text.enclose ["(" ")"]))
-
-(for {@.old (as_is (ffi.import: java/lang/CharSequence)
- (ffi.import: java/lang/String
- ["#::."
- (replace [java/lang/CharSequence java/lang/CharSequence] java/lang/String)]))}
- (as_is))
-
-(def: nest
- (-> Text Text)
- (.let [nested_new_line (format text.new_line text.tab)]
- (for {@.old (|>> (format text.new_line)
- (:as java/lang/String)
- (java/lang/String::replace (:as java/lang/CharSequence text.new_line)
- (:as java/lang/CharSequence nested_new_line)))}
- (|>> (format text.new_line)
- (text.replace_all text.new_line nested_new_line)))))
-
-(abstract: #export (Code brand)
- Text
-
- (implementation: #export equivalence
- (All [brand] (Equivalence (Code brand)))
-
- (def: (= reference subject)
- (\ text.equivalence = (:representation reference) (:representation subject))))
-
- (implementation: #export hash
- (All [brand] (Hash (Code brand)))
-
- (def: &equivalence ..equivalence)
- (def: hash (|>> :representation (\ text.hash hash))))
-
- (def: #export manual
- (-> Text Code)
- (|>> :abstraction))
-
- (def: #export code
- (-> (Code Any) Text)
- (|>> :representation))
-
- (template [<type> <super>]
- [(with_expansions [<brand> (template.identifier [<type> "'"])]
- (`` (abstract: #export (<brand> brand) Any))
- (`` (type: #export (<type> brand)
- (<super> (<brand> brand)))))]
-
- [Expression Code]
- [Computation Expression]
- [Location Computation]
- [Var Location]
- [Statement Code]
- )
-
- (template [<type> <super>]
- [(with_expansions [<brand> (template.identifier [<type> "'"])]
- (`` (abstract: #export <brand> Any))
- (`` (type: #export <type> (<super> <brand>))))]
-
- [Literal Computation]
- [Access Location]
- [Loop Statement]
- [Label Code]
- )
-
- (template [<var> <brand>]
- [(abstract: #export <brand> Any)
-
- (type: #export <var> (Var <brand>))]
-
- [SVar Single]
- [PVar Poly]
- [KVar Keyword]
- )
-
- (def: #export var
- (-> Text SVar)
- (|>> :abstraction))
-
- (template [<name> <brand> <prefix>]
- [(def: #export <name>
- (-> SVar (Var <brand>))
- (|>> :representation (format <prefix>) :abstraction))]
-
- [poly Poly "*"]
- [keyword Keyword "**"]
- )
-
- (def: #export none
- Literal
- (:abstraction "None"))
-
- (def: #export bool
- (-> Bit Literal)
- (|>> (case> #0 "False"
- #1 "True")
- :abstraction))
-
- (def: #export int
- (-> Int Literal)
- (|>> %.int :abstraction))
-
- (def: #export (long value)
- (-> Int Literal)
- (:abstraction (format (%.int value) "L")))
-
- (def: #export float
- (-> Frac Literal)
- (`` (|>> (cond> (~~ (template [<test> <python>]
- [[<test>]
- [(new> (format "float(" text.double_quote <python> text.double_quote ")") [])]]
-
- [(f.= f.positive_infinity) "inf"]
- [(f.= f.negative_infinity) "-inf"]
- [f.not_a_number? "nan"]
- ))
-
- ## else
- [%.frac])
- :abstraction)))
-
- (def: sanitize
- (-> Text Text)
- (`` (|>> (~~ (template [<find> <replace>]
- [(text.replace_all <find> <replace>)]
-
- ["\" "\\"]
- [text.tab "\t"]
- [text.vertical_tab "\v"]
- [text.null "\0"]
- [text.back_space "\b"]
- [text.form_feed "\f"]
- [text.new_line "\n"]
- [text.carriage_return "\r"]
- [text.double_quote (format "\" text.double_quote)]
- ))
- )))
-
- (def: #export string
- (-> Text Literal)
- (|>> ..sanitize
- (text.enclose [text.double_quote text.double_quote])
- :abstraction))
-
- (def: #export unicode
- (-> Text Literal)
- (|>> ..string
- :representation
- (format "u")
- :abstraction))
-
- (def: (composite_literal left_delimiter right_delimiter entry_serializer)
- (All [a]
- (-> Text Text (-> a Text)
- (-> (List a) Literal)))
- (function (_ entries)
- (<| :abstraction
- ## ..expression
- (format left_delimiter
- (|> entries
- (list\map entry_serializer)
- (text.join_with ", "))
- right_delimiter))))
-
- (template [<name> <pre> <post>]
- [(def: #export <name>
- (-> (List (Expression Any)) Literal)
- (composite_literal <pre> <post> ..code))]
-
- [tuple "(" ")"]
- [list "[" "]"]
- )
-
- (def: #export (slice from to list)
- (-> (Expression Any) (Expression Any) (Expression Any) Access)
- (<| :abstraction
- ## ..expression
- (format (:representation list) "[" (:representation from) ":" (:representation to) "]")))
-
- (def: #export (slice_from from list)
- (-> (Expression Any) (Expression Any) Access)
- (<| :abstraction
- ## ..expression
- (format (:representation list) "[" (:representation from) ":]")))
-
- (def: #export dict
- (-> (List [(Expression Any) (Expression Any)]) (Computation Any))
- (composite_literal "{" "}" (.function (_ [k v]) (format (:representation k) " : " (:representation v)))))
-
- (def: #export (apply/* func args)
- (-> (Expression Any) (List (Expression Any)) (Computation Any))
- (<| :abstraction
- ## ..expression
- (format (:representation func) "(" (text.join_with ", " (list\map ..code args)) ")")))
-
- (template [<name> <brand> <prefix>]
- [(def: (<name> var)
- (-> (Expression Any) Text)
- (format <prefix> (:representation var)))]
-
- [splat_poly Poly "*"]
- [splat_keyword Keyword "**"]
- )
-
- (template [<name> <splat>]
- [(def: #export (<name> args extra func)
- (-> (List (Expression Any)) (Expression Any) (Expression Any) (Computation Any))
- (<| :abstraction
- ## ..expression
- (format (:representation func)
- (format "(" (|> args
- (list\map (function (_ arg) (format (:representation arg) ", ")))
- (text.join_with ""))
- (<splat> extra) ")"))))]
-
- [apply_poly splat_poly]
- [apply_keyword splat_keyword]
- )
-
- (def: #export (the name object)
- (-> Text (Expression Any) (Computation Any))
- (:abstraction (format (:representation object) "." name)))
-
- (def: #export (do method args object)
- (-> Text (List (Expression Any)) (Expression Any) (Computation Any))
- (..apply/* (..the method object) args))
-
- (template [<name> <apply>]
- [(def: #export (<name> args extra method)
- (-> (List (Expression Any)) (Expression Any) Text
- (-> (Expression Any) (Computation Any)))
- (|>> (..the method) (<apply> args extra)))]
-
- [do_poly apply_poly]
- [do_keyword apply_keyword]
- )
-
- (def: #export (nth idx array)
- (-> (Expression Any) (Expression Any) Location)
- (:abstraction (format (:representation array) "[" (:representation idx) "]")))
-
- (def: #export (? test then else)
- (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any))
- (<| :abstraction
- ..expression
- (format (:representation then) " if " (:representation test) " else " (:representation else))))
-
- (template [<name> <op>]
- [(def: #export (<name> param subject)
- (-> (Expression Any) (Expression Any) (Computation Any))
- (<| :abstraction
- ..expression
- (format (:representation subject) " " <op> " " (:representation param))))]
-
- [is "is"]
- [= "=="]
- [< "<"]
- [<= "<="]
- [> ">"]
- [>= ">="]
- [+ "+"]
- [- "-"]
- [* "*"]
- [/ "/"]
- [// "//"]
- [% "%"]
- [** "**"]
- [bit_or "|"]
- [bit_and "&"]
- [bit_xor "^"]
- [bit_shl "<<"]
- [bit_shr ">>"]
-
- [or "or"]
- [and "and"]
- )
-
- (template [<name> <unary>]
- [(def: #export (<name> subject)
- (-> (Expression Any) (Computation Any))
- (<| :abstraction
- ## ..expression
- (format <unary> " " (:representation subject))))]
-
- [not "not"]
- [negate "-"]
- )
-
- (def: #export (lambda arguments body)
- (-> (List (Var Any)) (Expression Any) (Computation Any))
- (<| :abstraction
- ..expression
- (format "lambda " (|> arguments (list\map ..code) (text.join_with ", ")) ": "
- (:representation body))))
-
- (def: #export (set vars value)
- (-> (List (Location Any)) (Expression Any) (Statement Any))
- (:abstraction
- (format (|> vars (list\map ..code) (text.join_with ", "))
- " = "
- (:representation value))))
-
- (def: #export (delete where)
- (-> (Location Any) (Statement Any))
- (:abstraction (format "del " (:representation where))))
-
- (def: #export (if test then! else!)
- (-> (Expression Any) (Statement Any) (Statement Any) (Statement Any))
- (:abstraction
- (format "if " (:representation test) ":"
- (..nest (:representation then!))
- text.new_line "else:"
- (..nest (:representation else!)))))
-
- (def: #export (when test then!)
- (-> (Expression Any) (Statement Any) (Statement Any))
- (:abstraction
- (format "if " (:representation test) ":"
- (..nest (:representation then!)))))
-
- (def: #export (then pre! post!)
- (-> (Statement Any) (Statement Any) (Statement Any))
- (:abstraction
- (format (:representation pre!)
- text.new_line
- (:representation post!))))
-
- (template [<keyword> <0>]
- [(def: #export <0>
- (Statement Any)
- (:abstraction <keyword>))]
-
- ["break" break]
- ["continue" continue]
- )
-
- (def: #export (while test body! else!)
- (-> (Expression Any) (Statement Any) (Maybe (Statement Any)) Loop)
- (:abstraction
- (format "while " (:representation test) ":"
- (..nest (:representation body!))
- (case else!
- (#.Some else!)
- (format text.new_line "else:"
- (..nest (:representation else!)))
-
- #.None
- ""))))
-
- (def: #export (for_in var inputs body!)
- (-> SVar (Expression Any) (Statement Any) Loop)
- (:abstraction
- (format "for " (:representation var) " in " (:representation inputs) ":"
- (..nest (:representation body!)))))
-
- (def: #export statement
- (-> (Expression Any) (Statement Any))
- (|>> :transmutation))
-
- (def: #export pass
- (Statement Any)
- (:abstraction "pass"))
-
- (type: #export Except
- {#classes (List SVar)
- #exception SVar
- #handler (Statement Any)})
-
- (def: #export (try body! excepts)
- (-> (Statement Any) (List Except) (Statement Any))
- (:abstraction
- (format "try:"
- (..nest (:representation body!))
- (|> excepts
- (list\map (function (_ [classes exception catch!])
- (format text.new_line "except (" (text.join_with ", " (list\map ..code classes))
- ") as " (:representation exception) ":"
- (..nest (:representation catch!)))))
- (text.join_with "")))))
-
- (template [<name> <keyword> <pre>]
- [(def: #export (<name> value)
- (-> (Expression Any) (Statement Any))
- (:abstraction
- (format <keyword> (<pre> (:representation value)))))]
-
- [raise "raise " |>]
- [return "return " |>]
- [print "print" ..expression]
- )
-
- (def: #export (exec code globals)
- (-> (Expression Any) (Maybe (Expression Any)) (Statement Any))
- (let [extra (case globals
- (#.Some globals)
- (.list globals)
-
- #.None
- (.list))]
- (:abstraction
- (format "exec" (:representation (..tuple (list& code extra)))))))
-
- (def: #export (def name args body)
- (-> SVar (List (Ex [k] (Var k))) (Statement Any) (Statement Any))
- (:abstraction
- (format "def " (:representation name)
- "(" (|> args (list\map ..code) (text.join_with ", ")) "):"
- (..nest (:representation body)))))
-
- (def: #export (import module_name)
- (-> Text (Statement Any))
- (:abstraction (format "import " module_name)))
-
- (def: #export (comment commentary on)
- (All [brand] (-> Text (Code brand) (Code brand)))
- (:abstraction (format "# " (..sanitize commentary) text.new_line
- (:representation on))))
- )
-
-(def: #export (cond clauses else!)
- (-> (List [(Expression Any) (Statement Any)]) (Statement Any) (Statement Any))
- (list\fold (.function (_ [test then!] next!)
- (..if test then! next!))
- else!
- (list.reverse clauses)))
-
-(syntax: (arity_inputs {arity <code>.nat})
- (wrap (case arity
- 0 (.list)
- _ (|> (dec arity)
- (enum.range n.enum 0)
- (list\map (|>> %.nat code.local_identifier))))))
-
-(syntax: (arity_types {arity <code>.nat})
- (wrap (list.repeat arity (` (Expression Any)))))
-
-(template [<arity> <function>+]
- [(with_expansions [<apply> (template.identifier ["apply/" <arity>])
- <inputs> (arity_inputs <arity>)
- <types> (arity_types <arity>)
- <definitions> (template.splice <function>+)]
- (def: #export (<apply> function <inputs>)
- (-> (Expression Any) <types> (Computation Any))
- (..apply/* function (.list <inputs>)))
-
- (template [<function>]
- [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>]))
- (<apply> (..var <function>))))]
-
- <definitions>))]
-
- [1
- [["str"]
- ["ord"]
- ["float"]
- ["int"]
- ["len"]
- ["chr"]
- ["unichr"]
- ["unicode"]
- ["repr"]
- ["__import__"]
- ["Exception"]]]
-
- [2
- []]
-
- [3
- []]
- )
diff --git a/stdlib/source/lux/target/r.lux b/stdlib/source/lux/target/r.lux
deleted file mode 100644
index 40fb28da7..000000000
--- a/stdlib/source/lux/target/r.lux
+++ /dev/null
@@ -1,385 +0,0 @@
-(.module:
- [lux (#- Code or and list if function cond not int)
- [control
- [pipe (#+ case> cond> new>)]
- ["." function]
- [parser
- ["<.>" code]]]
- [data
- ["." maybe ("#\." functor)]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [macro
- [syntax (#+ syntax:)]
- ["." template]
- ["." code]]
- [math
- [number
- ["f" frac]]]
- [type
- abstract]])
-
-(abstract: #export (Code kind)
- Text
-
- {}
-
- (template [<type> <super>+]
- [(with_expansions [<kind> (template.identifier [<type> "'"])]
- (abstract: #export (<kind> kind) Any)
- (`` (type: #export <type> (|> Any <kind> (~~ (template.splice <super>+))))))]
-
- [Expression [Code]]
- )
-
- (template [<type> <super>+]
- [(with_expansions [<kind> (template.identifier [<type> "'"])]
- (abstract: #export (<kind> kind) Any)
- (`` (type: #export (<type> <brand>) (|> <brand> <kind> (~~ (template.splice <super>+))))))]
-
- [Var [Expression' Code]]
- )
-
- (template [<var> <kind>]
- [(abstract: #export <kind> Any)
- (type: #export <var> (Var <kind>))]
-
- [SVar Single]
- [PVar Poly]
- )
-
- (def: #export var
- (-> Text SVar)
- (|>> :abstraction))
-
- (def: #export var_args
- PVar
- (:abstraction "..."))
-
- (def: #export manual
- (-> Text Code)
- (|>> :abstraction))
-
- (def: #export code
- (-> (Code Any) Text)
- (|>> :representation))
-
- (def: (self_contained code)
- (-> Text Expression)
- (:abstraction
- (format "(" code ")")))
-
- (def: nested_new_line
- (format text.new_line text.tab))
-
- (def: nest
- (-> Text Text)
- (|>> (text.replace_all text.new_line ..nested_new_line)
- (format ..nested_new_line)))
-
- (def: (_block expression)
- (-> Text Text)
- (format "{" (nest expression) text.new_line "}"))
-
- (def: #export (block expression)
- (-> Expression Expression)
- (:abstraction
- (format "{"
- (..nest (:representation expression))
- text.new_line "}")))
-
- (template [<name> <r>]
- [(def: #export <name>
- Expression
- (:abstraction <r>))]
-
- [null "NULL"]
- [n/a "NA"]
- )
-
- (template [<name>]
- [(def: #export <name> Expression n/a)]
-
- [not_available]
- [not_applicable]
- [no_answer]
- )
-
- (def: #export bool
- (-> Bit Expression)
- (|>> (case> #0 "FALSE"
- #1 "TRUE")
- :abstraction))
-
- (def: #export int
- (-> Int Expression)
- (|>> %.int :abstraction))
-
- (def: #export float
- (-> Frac Expression)
- (|>> (cond> [(f.= f.positive_infinity)]
- [(new> "1.0/0.0" [])]
-
- [(f.= f.negative_infinity)]
- [(new> "-1.0/0.0" [])]
-
- [(f.= f.not_a_number)]
- [(new> "0.0/0.0" [])]
-
- ## else
- [%.frac])
- ..self_contained))
-
- (def: sanitize
- (-> Text Text)
- (`` (|>> (~~ (template [<find> <replace>]
- [(text.replace_all <find> <replace>)]
-
- ["\" "\\"]
- ["|" "\|"]
- [text.alarm "\a"]
- [text.back_space "\b"]
- [text.tab "\t"]
- [text.new_line "\n"]
- [text.carriage_return "\r"]
- [text.double_quote (format "\" text.double_quote)]
- ))
- )))
-
- (def: #export string
- (-> Text Expression)
- (|>> ..sanitize %.text :abstraction))
-
- (def: #export (slice from to list)
- (-> Expression Expression Expression Expression)
- (..self_contained
- (format (:representation list)
- "[" (:representation from) ":" (:representation to) "]")))
-
- (def: #export (slice_from from list)
- (-> Expression Expression Expression)
- (..self_contained
- (format (:representation list)
- "[-1" ":-" (:representation from) "]")))
-
- (def: #export (apply args func)
- (-> (List Expression) Expression Expression)
- (let [func (:representation func)
- spacing (|> " " (list.repeat (text.size func)) (text.join_with ""))]
- (:abstraction
- (format func "("
- (|> args
- (list\map ..code)
- (text.join_with (format "," text.new_line))
- ..nest)
- ")"))))
-
- (template [<name> <function>]
- [(def: #export (<name> members)
- (-> (List Expression) Expression)
- (..apply members (..var <function>)))]
-
- [vector "c"]
- [list "list"]
- )
-
- (def: #export named_list
- (-> (List [Text Expression]) Expression)
- (|>> (list\map (.function (_ [key value])
- (:abstraction (format key "=" (:representation value)))))
- ..list))
-
- (def: #export (apply_kw args kw_args func)
- (-> (List Expression) (List [Text Expression]) Expression Expression)
- (..self_contained
- (format (:representation func)
- (format "("
- (text.join_with "," (list\map ..code args)) ","
- (text.join_with "," (list\map (.function (_ [key val])
- (format key "=" (:representation val)))
- kw_args))
- ")"))))
-
- (syntax: (arity_inputs {arity <code>.nat})
- (wrap (case arity
- 0 (.list)
- _ (|> arity
- list.indices
- (list\map (|>> %.nat code.local_identifier))))))
-
- (syntax: (arity_types {arity <code>.nat})
- (wrap (list.repeat arity (` ..Expression))))
-
- (template [<arity> <function>+]
- [(with_expansions [<apply> (template.identifier ["apply/" <arity>])
- <inputs> (arity_inputs <arity>)
- <types> (arity_types <arity>)
- <definitions> (template.splice <function>+)]
- (def: #export (<apply> function [<inputs>])
- (-> Expression [<types>] Expression)
- (..apply (.list <inputs>) function))
-
- (template [<function>]
- [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>]))
- (-> [<types>] Expression)
- (<apply> (..var <function>))))]
-
- <definitions>))]
-
- [0
- [["commandArgs"]]]
- [1
- [["intToUtf8"]]]
- [2
- [["paste"]]]
- )
-
- (def: #export as::integer
- (-> Expression Expression)
- (..apply/1 (..var "as.integer")))
-
- (def: #export (nth idx list)
- (-> Expression Expression Expression)
- (..self_contained
- (format (:representation list) "[[" (:representation idx) "]]")))
-
- (def: #export (if test then else)
- (-> Expression Expression Expression Expression)
- (:abstraction
- (format "if(" (:representation test) ")"
- " " (.._block (:representation then))
- " else " (.._block (:representation else)))))
-
- (def: #export (when test then)
- (-> Expression Expression Expression)
- (:abstraction
- (format "if(" (:representation test) ") {"
- (.._block (:representation then))
- text.new_line "}")))
-
- (def: #export (cond clauses else)
- (-> (List [Expression Expression]) Expression Expression)
- (list\fold (.function (_ [test then] next)
- (if test then next))
- else
- (list.reverse clauses)))
-
- (template [<name> <op>]
- [(def: #export (<name> param subject)
- (-> Expression Expression Expression)
- (..self_contained
- (format (:representation subject)
- " " <op> " "
- (:representation param))))]
-
- [= "=="]
- [< "<"]
- [<= "<="]
- [> ">"]
- [>= ">="]
- [+ "+"]
- [- "-"]
- [* "*"]
- [/ "/"]
- [%% "%%"]
- [** "**"]
- [or "||"]
- [and "&&"]
- )
-
- (template [<name> <func>]
- [(def: #export (<name> param subject)
- (-> Expression Expression Expression)
- (..apply (.list subject param) (..var <func>)))]
-
- [bit_or "bitwOr"]
- [bit_and "bitwAnd"]
- [bit_xor "bitwXor"]
- [bit_shl "bitwShiftL"]
- [bit_ushr "bitwShiftR"]
- )
-
- (def: #export (bit_not subject)
- (-> Expression Expression)
- (..apply (.list subject) (..var "bitwNot")))
-
- (template [<name> <op>]
- [(def: #export <name>
- (-> Expression Expression)
- (|>> :representation (format <op>) ..self_contained))]
-
- [not "!"]
- [negate "-"]
- )
-
- (def: #export (length list)
- (-> Expression Expression)
- (..apply (.list list) (..var "length")))
-
- (def: #export (range from to)
- (-> Expression Expression Expression)
- (..self_contained
- (format (:representation from) ":" (:representation to))))
-
- (def: #export (function inputs body)
- (-> (List (Ex [k] (Var k))) Expression Expression)
- (let [args (|> inputs (list\map ..code) (text.join_with ", "))]
- (..self_contained
- (format "function(" args ") "
- (.._block (:representation body))))))
-
- (def: #export (try body warning error finally)
- (-> Expression (Maybe Expression) (Maybe Expression) (Maybe Expression) Expression)
- (let [optional (: (-> Text (Maybe Expression) (-> Text Text) Text)
- (.function (_ parameter value preparation)
- (|> value
- (maybe\map (|>> :representation preparation (format ", " parameter " = ")))
- (maybe.default ""))))]
- (..self_contained
- (format "tryCatch("
- (.._block (:representation body))
- (optional "warning" warning function.identity)
- (optional "error" error function.identity)
- (optional "finally" finally .._block)
- ")"))))
-
- (def: #export (while test body)
- (-> Expression Expression Expression)
- (..self_contained
- (format "while (" (:representation test) ") "
- (.._block (:representation body)))))
-
- (def: #export (for_in var inputs body)
- (-> SVar Expression Expression Expression)
- (..self_contained
- (format "for (" (:representation var) " in " (:representation inputs) ")"
- (.._block (:representation body)))))
-
- (template [<name> <keyword>]
- [(def: #export (<name> message)
- (-> Expression Expression)
- (..apply (.list message) (..var <keyword>)))]
-
- [stop "stop"]
- [print "print"]
- )
-
- (def: #export (set! var value)
- (-> SVar Expression Expression)
- (..self_contained
- (format (:representation var) " <- " (:representation value))))
-
- (def: #export (set_nth! idx value list)
- (-> Expression Expression SVar Expression)
- (..self_contained
- (format (:representation list) "[[" (:representation idx) "]] <- " (:representation value))))
-
- (def: #export (then pre post)
- (-> Expression Expression Expression)
- (:abstraction
- (format (:representation pre)
- text.new_line
- (:representation post))))
- )
diff --git a/stdlib/source/lux/target/ruby.lux b/stdlib/source/lux/target/ruby.lux
deleted file mode 100644
index e23c64fc0..000000000
--- a/stdlib/source/lux/target/ruby.lux
+++ /dev/null
@@ -1,472 +0,0 @@
-(.module:
- [lux (#- Location Code static int if cond function or and not comment)
- ["@" target]
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]
- ["." enum]]
- [control
- [pipe (#+ case> cond> new>)]
- [parser
- ["<.>" code]]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [macro
- [syntax (#+ syntax:)]
- ["." template]
- ["." code]]
- [math
- [number
- ["n" nat]
- ["f" frac]]]
- [type
- abstract]])
-
-(def: input_separator ", ")
-(def: statement_suffix ";")
-
-(def: nest
- (-> Text Text)
- (.let [nested_new_line (format text.new_line text.tab)]
- (|>> (format text.new_line)
- (text.replace_all text.new_line nested_new_line))))
-
-(abstract: #export (Code brand)
- Text
-
- (implementation: #export code_equivalence
- (All [brand] (Equivalence (Code brand)))
-
- (def: (= reference subject)
- (\ text.equivalence = (:representation reference) (:representation subject))))
-
- (implementation: #export code_hash
- (All [brand] (Hash (Code brand)))
-
- (def: &equivalence ..code_equivalence)
- (def: hash (|>> :representation (\ text.hash hash))))
-
- (def: #export manual
- (-> Text Code)
- (|>> :abstraction))
-
- (def: #export code
- (-> (Code Any) Text)
- (|>> :representation))
-
- (template [<type> <super>+]
- [(with_expansions [<brand> (template.identifier [<type> "'"])]
- (abstract: (<brand> brand) Any)
- (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))]
-
- [Expression [Code]]
- [Computation [Expression' Code]]
- [Location [Computation' Expression' Code]]
- [Var [Location' Computation' Expression' Code]]
- [LVar [Var' Location' Computation' Expression' Code]]
- [Statement [Code]]
- )
-
- (template [<type> <super>+]
- [(with_expansions [<brand> (template.identifier [<type> "'"])]
- (abstract: #export <brand> Any)
- (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))]
-
- [Literal [Computation' Expression' Code]]
- [Access [Location' Computation' Expression' Code]]
- [GVar [Var' Location' Computation' Expression' Code]]
- [IVar [Var' Location' Computation' Expression' Code]]
- [SVar [Var' Location' Computation' Expression' Code]]
- [LVar* [LVar' Var' Location' Computation' Expression' Code]]
- [LVar** [LVar' Var' Location' Computation' Expression' Code]]
- )
-
- (template [<var> <prefix> <constructor>]
- [(def: #export <constructor>
- (-> Text <var>)
- (|>> (format <prefix>) :abstraction))]
-
- [GVar "$" global]
- [IVar "@" instance]
- [SVar "@@" static]
- )
-
- (def: #export local
- (-> Text LVar)
- (|>> :abstraction))
-
- (template [<var> <prefix> <modifier> <unpacker>]
- [(template [<name> <input> <output>]
- [(def: #export <name>
- (-> <input> <output>)
- (|>> :representation (format <prefix>) :abstraction))]
-
- [<modifier> LVar <var>]
- [<unpacker> Expression Computation]
- )]
-
- [LVar* "*" variadic splat]
- [LVar** "**" variadic_kv double_splat]
- )
-
- (template [<ruby_name> <lux_name>]
- [(def: #export <lux_name>
- (..global <ruby_name>))]
-
- ["@" latest_error]
- ["_" last_string_read]
- ["." last_line_number_read]
- ["&" last_string_matched]
- ["~" last_regexp_match]
- ["=" case_insensitivity_flag]
- ["/" input_record_separator]
- ["\" output_record_separator]
- ["0" script_name]
- ["$" process_id]
- ["?" exit_status]
- )
-
- (template [<ruby_name> <lux_name>]
- [(def: #export <lux_name>
- (..local <ruby_name>))]
-
- ["ARGV" command_line_arguments]
- )
-
- (def: #export nil
- Literal
- (:abstraction "nil"))
-
- (def: #export bool
- (-> Bit Literal)
- (|>> (case> #0 "false"
- #1 "true")
- :abstraction))
-
- (def: sanitize
- (-> Text Text)
- (`` (|>> (~~ (template [<find> <replace>]
- [(text.replace_all <find> <replace>)]
-
- ["\" "\\"]
- [text.tab "\t"]
- [text.vertical_tab "\v"]
- [text.null "\0"]
- [text.back_space "\b"]
- [text.form_feed "\f"]
- [text.new_line "\n"]
- [text.carriage_return "\r"]
- [text.double_quote (format "\" text.double_quote)]
- ))
- )))
-
- (template [<format> <name> <type> <prep>]
- [(def: #export <name>
- (-> <type> Literal)
- (|>> <prep> <format> :abstraction))]
-
- [%.int int Int (<|)]
- [%.text string Text ..sanitize]
- [(<|) symbol Text (format ":")]
- )
-
- (def: #export float
- (-> Frac Literal)
- (|>> (cond> [(f.= f.positive_infinity)]
- [(new> "(+1.0/0.0)" [])]
-
- [(f.= f.negative_infinity)]
- [(new> "(-1.0/0.0)" [])]
-
- [(f.= f.not_a_number)]
- [(new> "(+0.0/-0.0)" [])]
-
- ## else
- [%.frac])
- :abstraction))
-
- (def: #export (array_range from to array)
- (-> Expression Expression Expression Computation)
- (|> (format (:representation from) ".." (:representation to))
- (text.enclose ["[" "]"])
- (format (:representation array))
- :abstraction))
-
- (def: #export array
- (-> (List Expression) Literal)
- (|>> (list\map (|>> :representation))
- (text.join_with ..input_separator)
- (text.enclose ["[" "]"])
- :abstraction))
-
- (def: #export hash
- (-> (List [Expression Expression]) Literal)
- (|>> (list\map (.function (_ [k v])
- (format (:representation k) " => " (:representation v))))
- (text.join_with ..input_separator)
- (text.enclose ["{" "}"])
- :abstraction))
-
- (def: #export (apply/* args func)
- (-> (List Expression) Expression Computation)
- (|> args
- (list\map (|>> :representation))
- (text.join_with ..input_separator)
- (text.enclose ["(" ")"])
- (format (:representation func))
- :abstraction))
-
- (def: #export (apply_lambda/* args lambda)
- (-> (List Expression) Expression Computation)
- (|> args
- (list\map (|>> :representation))
- (text.join_with ..input_separator)
- (text.enclose ["[" "]"])
- (format (:representation lambda))
- :abstraction))
-
- (def: #export (the field object)
- (-> Text Expression Access)
- (:abstraction (format (:representation object) "." field)))
-
- (def: #export (nth idx array)
- (-> Expression Expression Access)
- (|> (:representation idx)
- (text.enclose ["[" "]"])
- (format (:representation array))
- :abstraction))
-
- (def: #export (? test then else)
- (-> Expression Expression Expression Computation)
- (|> (format (:representation test) " ? "
- (:representation then) " : "
- (:representation else))
- (text.enclose ["(" ")"])
- :abstraction))
-
- (def: #export statement
- (-> Expression Statement)
- (|>> :representation
- (text.suffix ..statement_suffix)
- :abstraction))
-
- (def: #export (then pre! post!)
- (-> Statement Statement Statement)
- (:abstraction
- (format (:representation pre!)
- text.new_line
- (:representation post!))))
-
- (def: #export (set vars value)
- (-> (List Location) Expression Statement)
- (:abstraction
- (format (|> vars
- (list\map (|>> :representation))
- (text.join_with ..input_separator))
- " = " (:representation value) ..statement_suffix)))
-
- (def: (block content)
- (-> Text Text)
- (format content
- text.new_line "end" ..statement_suffix))
-
- (def: #export (if test then! else!)
- (-> Expression Statement Statement Statement)
- (<| :abstraction
- ..block
- (format "if " (:representation test)
- (..nest (:representation then!))
- text.new_line "else"
- (..nest (:representation else!)))))
-
- (template [<name> <block>]
- [(def: #export (<name> test then!)
- (-> Expression Statement Statement)
- (<| :abstraction
- ..block
- (format <block> " " (:representation test)
- (..nest (:representation then!)))))]
-
- [when "if"]
- [while "while"]
- )
-
- (def: #export (for_in var array iteration!)
- (-> LVar Expression Statement Statement)
- (<| :abstraction
- ..block
- (format "for " (:representation var)
- " in " (:representation array)
- " do "
- (..nest (:representation iteration!)))))
-
- (type: #export Rescue
- {#classes (List Text)
- #exception LVar
- #rescue Statement})
-
- (def: #export (begin body! rescues)
- (-> Statement (List Rescue) Statement)
- (<| :abstraction
- ..block
- (format "begin" (..nest (:representation body!))
- (|> rescues
- (list\map (.function (_ [classes exception rescue])
- (format text.new_line "rescue " (text.join_with ..input_separator classes)
- " => " (:representation exception)
- (..nest (:representation rescue)))))
- (text.join_with text.new_line)))))
-
- (def: #export (catch expectation body!)
- (-> Expression Statement Statement)
- (<| :abstraction
- ..block
- (format "catch(" (:representation expectation) ") do"
- (..nest (:representation body!)))))
-
- (def: #export (return value)
- (-> Expression Statement)
- (:abstraction (format "return " (:representation value) ..statement_suffix)))
-
- (def: #export (raise message)
- (-> Expression Computation)
- (:abstraction (format "raise " (:representation message))))
-
- (template [<name> <keyword>]
- [(def: #export <name>
- Statement
- (|> <keyword>
- (text.suffix ..statement_suffix)
- :abstraction))]
-
- [next "next"]
- [redo "redo"]
- [break "break"]
- )
-
- (def: #export (function name args body!)
- (-> LVar (List LVar) Statement Statement)
- (<| :abstraction
- ..block
- (format "def " (:representation name)
- (|> args
- (list\map (|>> :representation))
- (text.join_with ..input_separator)
- (text.enclose ["(" ")"]))
- (..nest (:representation body!)))))
-
- (def: #export (lambda name args body!)
- (-> (Maybe LVar) (List Var) Statement Literal)
- (let [proc (|> (format (|> args
- (list\map (|>> :representation))
- (text.join_with ..input_separator)
- (text.enclose' "|"))
- (..nest (:representation body!)))
- (text.enclose ["{" "}"])
- (format "lambda "))]
- (|> (case name
- #.None
- proc
-
- (#.Some name)
- (format (:representation name) " = " proc))
- (text.enclose ["(" ")"])
- :abstraction)))
-
- (template [<op> <name>]
- [(def: #export (<name> parameter subject)
- (-> Expression Expression Computation)
- (:abstraction (format "(" (:representation subject) " " <op> " " (:representation parameter) ")")))]
-
- ["==" =]
- [ "<" <]
- ["<=" <=]
- [ ">" >]
- [">=" >=]
-
- [ "+" +]
- [ "-" -]
- [ "*" *]
- [ "/" /]
- [ "%" %]
- ["**" pow]
-
- ["||" or]
- ["&&" and]
- [ "|" bit_or]
- [ "&" bit_and]
- [ "^" bit_xor]
-
- ["<<" bit_shl]
- [">>" bit_shr]
- )
-
- (template [<unary> <name>]
- [(def: #export (<name> subject)
- (-> Expression Computation)
- (:abstraction (format "(" <unary> (:representation subject) ")")))]
-
- ["!" not]
- ["-" negate]
- )
-
- (def: #export (comment commentary on)
- (All [brand] (-> Text (Code brand) (Code brand)))
- (:abstraction (format "# " (..sanitize commentary) text.new_line
- (:representation on))))
- )
-
-(def: #export (do method args object)
- (-> Text (List Expression) Expression Computation)
- (|> object (..the method) (..apply/* args)))
-
-(def: #export (cond clauses else!)
- (-> (List [Expression Statement]) Statement Statement)
- (list\fold (.function (_ [test then!] next!)
- (..if test then! next!))
- else!
- (list.reverse clauses)))
-
-(syntax: (arity_inputs {arity <code>.nat})
- (wrap (case arity
- 0 (.list)
- _ (|> (dec arity)
- (enum.range n.enum 0)
- (list\map (|>> %.nat code.local_identifier))))))
-
-(syntax: (arity_types {arity <code>.nat})
- (wrap (list.repeat arity (` ..Expression))))
-
-(template [<arity> <function>+]
- [(with_expansions [<apply> (template.identifier ["apply/" <arity>])
- <inputs> (arity_inputs <arity>)
- <types> (arity_types <arity>)
- <definitions> (template.splice <function>+)]
- (def: #export (<apply> function <inputs>)
- (-> Expression <types> Computation)
- (..apply/* (.list <inputs>) function))
-
- (template [<function>]
- [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>]))
- (<apply> (..local <function>))))]
-
- <definitions>))]
-
- [1
- [["print"]
- ["require"]]]
-
- [2
- [["print"]]]
-
- [3
- [["print"]]]
- )
-
-(def: #export throw/1
- (-> Expression Statement)
- (|>> (..apply/1 (..local "throw"))
- ..statement))
diff --git a/stdlib/source/lux/target/scheme.lux b/stdlib/source/lux/target/scheme.lux
deleted file mode 100644
index a34023c6a..000000000
--- a/stdlib/source/lux/target/scheme.lux
+++ /dev/null
@@ -1,379 +0,0 @@
-(.module:
- [lux (#- Code int or and if cond let)
- ["@" target]
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]]
- [control
- [pipe (#+ new> cond> case>)]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold monoid)]]]
- [macro
- ["." template]]
- [math
- [number
- ["n" nat]
- ["f" frac]]]
- [type
- abstract]])
-
-(def: nest
- (-> Text Text)
- (.let [nested_new_line (format text.new_line text.tab)]
- (text.replace_all text.new_line nested_new_line)))
-
-(abstract: #export (Code k)
- Text
-
- (implementation: #export equivalence
- (All [brand] (Equivalence (Code brand)))
-
- (def: (= reference subject)
- (\ text.equivalence = (:representation reference) (:representation subject))))
-
- (implementation: #export hash
- (All [brand] (Hash (Code brand)))
-
- (def: &equivalence ..equivalence)
- (def: hash (|>> :representation (\ text.hash hash))))
-
- (template [<type> <brand> <super>+]
- [(abstract: #export (<brand> brand) Any)
- (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+)))))]
-
- [Expression Expression' [Code]]
- )
-
- (template [<type> <brand> <super>+]
- [(abstract: #export <brand> Any)
- (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+)))))]
-
- [Var Var' [Expression' Code]]
- [Computation Computation' [Expression' Code]]
- )
-
- (type: #export Arguments
- {#mandatory (List Var)
- #rest (Maybe Var)})
-
- (def: #export manual
- (-> Text Code)
- (|>> :abstraction))
-
- (def: #export code
- (-> (Code Any) Text)
- (|>> :representation))
-
- (def: #export var
- (-> Text Var)
- (|>> :abstraction))
-
- (def: (arguments [mandatory rest])
- (-> Arguments (Code Any))
- (case rest
- (#.Some rest)
- (case mandatory
- #.Nil
- rest
-
- _
- (|> (format " . " (:representation rest))
- (format (|> mandatory
- (list\map ..code)
- (text.join_with " ")))
- (text.enclose ["(" ")"])
- :abstraction))
-
- #.None
- (|> mandatory
- (list\map ..code)
- (text.join_with " ")
- (text.enclose ["(" ")"])
- :abstraction)))
-
- (def: #export nil
- Computation
- (:abstraction "'()"))
-
- (def: #export bool
- (-> Bit Computation)
- (|>> (case> #0 "#f"
- #1 "#t")
- :abstraction))
-
- (def: #export int
- (-> Int Computation)
- (|>> %.int :abstraction))
-
- (def: #export float
- (-> Frac Computation)
- (|>> (cond> [(f.= f.positive_infinity)]
- [(new> "+inf.0" [])]
-
- [(f.= f.negative_infinity)]
- [(new> "-inf.0" [])]
-
- [f.not_a_number?]
- [(new> "+nan.0" [])]
-
- ## else
- [%.frac])
- :abstraction))
-
- (def: #export positive_infinity Computation (..float f.positive_infinity))
- (def: #export negative_infinity Computation (..float f.negative_infinity))
- (def: #export not_a_number Computation (..float f.not_a_number))
-
- (def: sanitize
- (-> Text Text)
- (`` (|>> (~~ (template [<find> <replace>]
- [(text.replace_all <find> <replace>)]
-
- ["\" "\\"]
- ["|" "\|"]
- [text.alarm "\a"]
- [text.back_space "\b"]
- [text.tab "\t"]
- [text.new_line "\n"]
- [text.carriage_return "\r"]
- [text.double_quote (format "\" text.double_quote)]
- ))
- )))
-
- (def: #export string
- (-> Text Computation)
- (|>> ..sanitize %.text :abstraction))
-
- (def: #export symbol
- (-> Text Computation)
- (|>> (format "'") :abstraction))
-
- (def: form
- (-> (List (Code Any)) Code)
- (.let [nested_new_line (format text.new_line text.tab)]
- (|>> (case> #.Nil
- (:abstraction "()")
-
- (#.Cons head tail)
- (|> tail
- (list\map (|>> :representation nest))
- (#.Cons (:representation head))
- (text.join_with nested_new_line)
- (text.enclose ["(" ")"])
- :abstraction)))))
-
- (def: #export (apply/* args func)
- (-> (List Expression) Expression Computation)
- (..form (#.Cons func args)))
-
- (template [<name> <function>]
- [(def: #export (<name> members)
- (-> (List Expression) Computation)
- (..apply/* members (..var <function>)))]
-
- [vector/* "vector"]
- [list/* "list"]
- )
-
- (def: #export apply/0
- (-> Expression Computation)
- (..apply/* (list)))
-
- (template [<lux_name> <scheme_name>]
- [(def: #export <lux_name>
- (apply/0 (..var <scheme_name>)))]
-
- [newline/0 "newline"]
- )
-
- (template [<apply> <arg>+ <type>+ <function>+]
- [(`` (def: #export (<apply> procedure)
- (-> Expression (~~ (template.splice <type>+)) Computation)
- (function (_ (~~ (template.splice <arg>+)))
- (..apply/* (list (~~ (template.splice <arg>+))) procedure))))
-
- (`` (template [<definition> <function>]
- [(def: #export <definition> (<apply> (..var <function>)))]
-
- (~~ (template.splice <function>+))))]
-
- [apply/1 [_0] [Expression]
- [[exact/1 "exact"]
- [integer->char/1 "integer->char"]
- [char->integer/1 "char->integer"]
- [number->string/1 "number->string"]
- [string->number/1 "string->number"]
- [floor/1 "floor"]
- [truncate/1 "truncate"]
- [string/1 "string"]
- [string?/1 "string?"]
- [length/1 "length"]
- [values/1 "values"]
- [null?/1 "null?"]
- [car/1 "car"]
- [cdr/1 "cdr"]
- [raise/1 "raise"]
- [error-object-message/1 "error-object-message"]
- [make-vector/1 "make-vector"]
- [vector-length/1 "vector-length"]
- [not/1 "not"]
- [string-hash/1 "string-hash"]
- [reverse/1 "reverse"]
- [display/1 "display"]
- [exit/1 "exit"]
- [string-length/1 "string-length"]
- [load-relative/1 "load-relative"]]]
-
- [apply/2 [_0 _1] [Expression Expression]
- [[append/2 "append"]
- [cons/2 "cons"]
- [make-vector/2 "make-vector"]
- ## [vector-ref/2 "vector-ref"]
- [list-tail/2 "list-tail"]
- [map/2 "map"]
- [string-ref/2 "string-ref"]
- [string-append/2 "string-append"]
- [make-string/2 "make-string"]]]
-
- [apply/3 [_0 _1 _2] [Expression Expression Expression]
- [[substring/3 "substring"]
- [vector-set!/3 "vector-set!"]
- [string-contains/3 "string-contains"]]]
-
- [apply/5 [_0 _1 _2 _3 _4] [Expression Expression Expression Expression Expression]
- [[vector-copy!/5 "vector-copy!"]]]
- )
-
- ## TODO: define "vector-ref/2" like a normal apply/2 function.
- ## "vector-ref/2" as an 'invoke' is problematic, since it only works
- ## in Kawa.
- ## However, the way Kawa defines "vector-ref" causes trouble,
- ## because it does a runtime type-check which throws an error when
- ## it checks against custom values/objects/classes made for
- ## JVM<->Scheme interop.
- ## There are 2 ways to deal with this:
- ## 0. To fork Kawa, and get rid of the type-check so the normal
- ## "vector-ref" can be used instead.
- ## 1. To carry on, and then, when it's time to compile the compiler
- ## itself into Scheme, switch from 'invoke' to normal 'vector-ref'.
- ## Either way, the 'invoke' needs to go away.
- (def: #export (vector-ref/2 vector index)
- (-> Expression Expression Computation)
- (..form (list (..var "invoke") vector (..symbol "getRaw") index)))
-
- (template [<lux_name> <scheme_name>]
- [(def: #export (<lux_name> param subject)
- (-> Expression Expression Computation)
- (..apply/2 (..var <scheme_name>) subject param))]
-
- [=/2 "="]
- [eq?/2 "eq?"]
- [eqv?/2 "eqv?"]
- [</2 "<"]
- [<=/2 "<="]
- [>/2 ">"]
- [>=/2 ">="]
- [string=?/2 "string=?"]
- [string<?/2 "string<?"]
- [+/2 "+"]
- [-/2 "-"]
- [//2 "/"]
- [*/2 "*"]
- [expt/2 "expt"]
- [remainder/2 "remainder"]
- [quotient/2 "quotient"]
- [mod/2 "mod"]
- [arithmetic-shift/2 "arithmetic-shift"]
- [bitwise-and/2 "bitwise-and"]
- [bitwise-ior/2 "bitwise-ior"]
- [bitwise-xor/2 "bitwise-xor"]
- )
-
- (template [<lux_name> <scheme_name>]
- [(def: #export <lux_name>
- (-> (List Expression) Computation)
- (|>> (list& (..var <scheme_name>)) ..form))]
-
- [or "or"]
- [and "and"]
- )
-
- (template [<lux_name> <scheme_name> <var> <pre>]
- [(def: #export (<lux_name> bindings body)
- (-> (List [<var> Expression]) Expression Computation)
- (..form (list (..var <scheme_name>)
- (|> bindings
- (list\map (function (_ [binding/name binding/value])
- (..form (list (|> binding/name <pre>)
- binding/value))))
- ..form)
- body)))]
-
- [let "let" Var (<|)]
- [let* "let*" Var (<|)]
- [letrec "letrec" Var (<|)]
- [let_values "let-values" Arguments ..arguments]
- [let*_values "let*-values" Arguments ..arguments]
- [letrec_values "letrec-values" Arguments ..arguments]
- )
-
- (def: #export (if test then else)
- (-> Expression Expression Expression Computation)
- (..form (list (..var "if") test then else)))
-
- (def: #export (when test then)
- (-> Expression Expression Computation)
- (..form (list (..var "when") test then)))
-
- (def: #export (lambda arguments body)
- (-> Arguments Expression Computation)
- (..form (list (..var "lambda")
- (..arguments arguments)
- body)))
-
- (def: #export (define_function name arguments body)
- (-> Var Arguments Expression Computation)
- (..form (list (..var "define")
- (|> arguments
- (update@ #mandatory (|>> (#.Cons name)))
- ..arguments)
- body)))
-
- (def: #export (define_constant name value)
- (-> Var Expression Computation)
- (..form (list (..var "define") name value)))
-
- (def: #export begin
- (-> (List Expression) Computation)
- (|>> (#.Cons (..var "begin")) ..form))
-
- (def: #export (set! name value)
- (-> Var Expression Computation)
- (..form (list (..var "set!") name value)))
-
- (def: #export (with_exception_handler handler body)
- (-> Expression Expression Computation)
- (..form (list (..var "with-exception-handler") handler body)))
-
- (def: #export (call_with_current_continuation body)
- (-> Expression Computation)
- (..form (list (..var "call-with-current-continuation") body)))
-
- (def: #export (guard variable clauses else body)
- (-> Var (List [Expression Expression]) (Maybe Expression) Expression Computation)
- (..form (list (..var "guard")
- (..form (|> (case else
- #.None
- (list)
-
- (#.Some else)
- (list (..form (list (..var "else") else))))
- (list\compose (list\map (function (_ [when then])
- (..form (list when then)))
- clauses))
- (list& variable)))
- body)))
- )
diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux
deleted file mode 100644
index f246e0df9..000000000
--- a/stdlib/source/lux/test.lux
+++ /dev/null
@@ -1,418 +0,0 @@
-(.module: {#.doc "Tools for unit & property-based/generative testing."}
- [lux (#- and for)
- ["." meta]
- ["." debug]
- [abstract
- ["." monad (#+ do)]]
- [control
- [pipe (#+ case>)]
- ["." try]
- ["." exception (#+ exception:)]
- ["." io]
- [concurrency
- ["." atom (#+ Atom)]
- ["." promise (#+ Promise) ("#\." monad)]]
- ["<>" parser
- ["<.>" code]]]
- [data
- ["." maybe]
- ["." product]
- ["." name]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." set (#+ Set)]
- ["." dictionary #_
- ["#" ordered (#+ Dictionary)]]]]
- [time
- ["." instant]
- ["." duration (#+ Duration)]]
- [math
- ["." random (#+ Random) ("#\." monad)]
- [number (#+ hex)
- ["n" nat]
- ["f" frac]]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]]
- [world
- ["." program]]])
-
-(type: #export Tally
- {#successes Nat
- #failures Nat
- #expected_coverage (Set Name)
- #actual_coverage (Set Name)})
-
-(def: (add_tally parameter subject)
- (-> Tally Tally Tally)
- {#successes (n.+ (get@ #successes parameter) (get@ #successes subject))
- #failures (n.+ (get@ #failures parameter) (get@ #failures subject))
- #expected_coverage (set.union (get@ #expected_coverage parameter)
- (get@ #expected_coverage subject))
- #actual_coverage (set.union (get@ #actual_coverage parameter)
- (get@ #actual_coverage subject))})
-
-(def: start
- Tally
- {#successes 0
- #failures 0
- #expected_coverage (set.new name.hash)
- #actual_coverage (set.new name.hash)})
-
-(template [<name> <category>]
- [(def: <name>
- Tally
- (update@ <category> .inc ..start))]
-
- [success #successes]
- [failure #failures]
- )
-
-(type: #export Assertion
- (Promise [Tally Text]))
-
-(type: #export Test
- (Random Assertion))
-
-(def: separator
- text.new_line)
-
-(def: #export (and' left right)
- {#.doc "Sequencing combinator."}
- (-> Assertion Assertion Assertion)
- (let [[read! write!] (: [(Promise [Tally Text])
- (promise.Resolver [Tally Text])]
- (promise.promise []))
- _ (|> left
- (promise.await (function (_ [l_tally l_documentation])
- (promise.await (function (_ [r_tally r_documentation])
- (write! [(add_tally l_tally r_tally)
- (format l_documentation ..separator r_documentation)]))
- right)))
- io.run)]
- read!))
-
-(def: #export (and left right)
- {#.doc "Sequencing combinator."}
- (-> Test Test Test)
- (do {! random.monad}
- [left left]
- (\ ! map (..and' left) right)))
-
-(def: context_prefix
- text.tab)
-
-(def: #export (context description)
- (-> Text Test Test)
- (random\map (promise\map (function (_ [tally documentation])
- [tally (|> documentation
- (text.split_all_with ..separator)
- (list\map (|>> (format context_prefix)))
- (text.join_with ..separator)
- (format description ..separator))]))))
-
-(def: failure_prefix "[Failure] ")
-(def: success_prefix "[Success] ")
-
-(def: #export fail
- (-> Text Test)
- (|>> (format ..failure_prefix)
- [..failure]
- promise\wrap
- random\wrap))
-
-(def: #export (assert message condition)
- {#.doc "Check that a condition is #1, and fail with the given message otherwise."}
- (-> Text Bit Assertion)
- (<| promise\wrap
- (if condition
- [..success (format ..success_prefix message)]
- [..failure (format ..failure_prefix message)])))
-
-(def: #export (test message condition)
- {#.doc "Check that a condition is #1, and fail with the given message otherwise."}
- (-> Text Bit Test)
- (random\wrap (..assert message condition)))
-
-(def: #export (lift message random)
- (-> Text (Random Bit) Test)
- (random\map (..assert message) random))
-
-(def: pcg32_magic_inc
- Nat
- (hex "FEDCBA9876543210"))
-
-(type: #export Seed
- {#.doc "The seed value used for random testing (if that feature is used)."}
- Nat)
-
-(def: #export (seed value test)
- (-> Seed Test Test)
- (function (_ prng)
- (let [[_ result] (random.run (random.pcg32 [..pcg32_magic_inc value])
- test)]
- [prng result])))
-
-(def: failed?
- (-> Tally Bit)
- (|>> (get@ #failures) (n.> 0)))
-
-(def: (times_failure seed documentation)
- (-> Seed Text Text)
- (format documentation ..separator ..separator
- "Failed with this seed: " (%.nat seed)))
-
-(exception: #export must_try_test_at_least_once)
-
-(def: #export (times amount test)
- (-> Nat Test Test)
- (case amount
- 0 (..fail (exception.construct ..must_try_test_at_least_once []))
- _ (do random.monad
- [seed random.nat]
- (function (recur prng)
- (let [[prng' instance] (random.run (random.pcg32 [..pcg32_magic_inc seed]) test)]
- [prng' (do {! promise.monad}
- [[tally documentation] instance]
- (if (..failed? tally)
- (wrap [tally (times_failure seed documentation)])
- (case amount
- 1 instance
- _ (|> test
- (times (dec amount))
- (random.run prng')
- product.right))))])))))
-
-(def: (description duration tally)
- (-> Duration Tally Text)
- (let [successes (get@ #successes tally)
- failures (get@ #failures tally)
- missing (set.difference (get@ #actual_coverage tally)
- (get@ #expected_coverage tally))
- unexpected (set.difference (get@ #expected_coverage tally)
- (get@ #actual_coverage tally))
- report (: (-> (Set Name) Text)
- (|>> set.to_list
- (list.sort (\ name.order <))
- (exception.enumerate %.name)))
- expected_definitions_to_cover (set.size (get@ #expected_coverage tally))
- unexpected_definitions_covered (set.size unexpected)
- actual_definitions_covered (n.- unexpected_definitions_covered
- (set.size (get@ #actual_coverage tally)))
- coverage (case expected_definitions_to_cover
- 0 "N/A"
- expected (let [missing_ratio (f./ (n.frac expected)
- (n.frac (set.size missing)))
- max_percent +100.0
- done_percent (|> +1.0
- (f.- missing_ratio)
- (f.* max_percent))]
- (if (f.= max_percent done_percent)
- "100%"
- (let [raw (|> done_percent
- %.frac
- (text.replace_once "+" ""))]
- (|> raw
- (text.clip 0 (if (f.>= +10.0 done_percent)
- 5 ## XX.XX
- 4 ## X.XX
- ))
- (maybe.default raw)
- (text.suffix "%"))))))]
- (exception.report
- ["Duration" (%.duration duration)]
- ["# Tests" (%.nat (n.+ successes failures))]
- ["# Successes" (%.nat successes)]
- ["# Failures" (%.nat failures)]
- ["# Expected definitions to cover" (%.nat expected_definitions_to_cover)]
- ["# Actual definitions covered" (%.nat actual_definitions_covered)]
- ["# Pending definitions to cover" (%.nat (n.- actual_definitions_covered
- expected_definitions_to_cover))]
- ["# Unexpected definitions covered" (%.nat unexpected_definitions_covered)]
- ["Coverage" coverage]
- ["Pending definitions to cover" (report missing)]
- ["Unexpected definitions covered" (report unexpected)])))
-
-(def: failure_exit_code +1)
-(def: success_exit_code +0)
-
-(def: #export (run! test)
- (-> Test (Promise Nothing))
- (do promise.monad
- [pre (promise.future instant.now)
- #let [seed (instant.to_millis pre)
- prng (random.pcg32 [..pcg32_magic_inc seed])]
- [tally documentation] (|> test (random.run prng) product.right)
- post (promise.future instant.now)
- #let [duration (instant.span pre post)
- _ (debug.log! (format documentation text.new_line text.new_line
- (..description duration tally)
- text.new_line))]]
- (promise.future (\ program.default exit
- (case (get@ #failures tally)
- 0 ..success_exit_code
- _ ..failure_exit_code)))))
-
-(def: (|cover'| coverage condition)
- (-> (List Name) Bit Assertion)
- (let [message (|> coverage
- (list\map %.name)
- (text.join_with " & "))
- coverage (set.from_list name.hash coverage)]
- (|> (..assert message condition)
- (promise\map (function (_ [tally documentation])
- [(update@ #actual_coverage (set.union coverage) tally)
- documentation])))))
-
-(def: (|cover| coverage condition)
- (-> (List Name) Bit Test)
- (|> (..|cover'| coverage condition)
- random\wrap))
-
-(def: (|for| coverage test)
- (-> (List Name) Test Test)
- (let [context (|> coverage
- (list\map %.name)
- (text.join_with " & "))
- coverage (set.from_list name.hash coverage)]
- (random\map (promise\map (function (_ [tally documentation])
- [(update@ #actual_coverage (set.union coverage) tally)
- documentation]))
- (..context context test))))
-
-(def: (name_code name)
- (-> Name Code)
- (code.tuple (list (code.text (name.module name))
- (code.text (name.short name)))))
-
-(syntax: (reference {name <code>.identifier})
- (do meta.monad
- [_ (meta.find_export name)]
- (wrap (list (name_code name)))))
-
-(def: coverage_separator
- Text
- (text.from_code 31))
-
-(def: encode_coverage
- (-> (List Text) Text)
- (list\fold (function (_ short aggregate)
- (case aggregate
- "" short
- _ (format aggregate ..coverage_separator short)))
- ""))
-
-(def: (decode_coverage module encoding)
- (-> Text Text (Set Name))
- (loop [remaining encoding
- output (set.from_list name.hash (list))]
- (case (text.split_with ..coverage_separator remaining)
- (#.Some [head tail])
- (recur tail (set.add [module head] output))
-
- #.None
- (set.add [module remaining] output))))
-
-(template [<macro> <function>]
- [(syntax: #export (<macro> {coverage (<code>.tuple (<>.many <code>.any))}
- condition)
- (let [coverage (list\map (function (_ definition)
- (` ((~! ..reference) (~ definition))))
- coverage)]
- (wrap (list (` ((~! <function>)
- (: (.List .Name)
- (.list (~+ coverage)))
- (~ condition)))))))]
-
- [cover' ..|cover'|]
- [cover ..|cover|]
- )
-
-(syntax: #export (for {coverage (<code>.tuple (<>.many <code>.any))}
- test)
- (let [coverage (list\map (function (_ definition)
- (` ((~! ..reference) (~ definition))))
- coverage)]
- (wrap (list (` ((~! ..|for|)
- (: (.List .Name)
- (.list (~+ coverage)))
- (~ test)))))))
-
-(def: (covering' module coverage test)
- (-> Text Text Test Test)
- (let [coverage (..decode_coverage module coverage)]
- (|> (..context module test)
- (random\map (promise\map (function (_ [tally documentation])
- [(update@ #expected_coverage (set.union coverage) tally)
- documentation]))))))
-
-(syntax: #export (covering {module <code>.identifier}
- test)
- (do meta.monad
- [#let [module (name.module module)]
- definitions (meta.definitions module)
- #let [coverage (|> definitions
- (list\fold (function (_ [short [exported? _]] aggregate)
- (if exported?
- (#.Cons short aggregate)
- aggregate))
- #.Nil)
- ..encode_coverage)]]
- (wrap (list (` ((~! ..covering')
- (~ (code.text module))
- (~ (code.text coverage))
- (~ test)))))))
-
-(exception: #export (error_during_execution {error Text})
- (exception.report
- ["Error" (%.text error)]))
-
-(def: #export (in_parallel tests)
- (-> (List Test) Test)
- (case (list.size tests)
- 0
- (random\wrap (promise\wrap [..start ""]))
-
- expected_tests
- (do random.monad
- [seed random.nat
- #let [prng (random.pcg32 [..pcg32_magic_inc seed])
- run! (: (-> Test Assertion)
- (|>> (random.run prng)
- product.right
- (function (_ _))
- "lux try"
- (case> (#try.Success output)
- output
-
- (#try.Failure error)
- (..assert (exception.construct ..error_during_execution [error]) false))
- io.io
- promise.future
- promise\join))
- state (: (Atom (Dictionary Nat [Tally Text]))
- (atom.atom (dictionary.new n.order)))
- [read! write!] (: [Assertion
- (promise.Resolver [Tally Text])]
- (promise.promise []))
- _ (io.run (monad.map io.monad
- (function (_ [index test])
- (promise.await (function (_ assertion)
- (do io.monad
- [[_ results] (atom.update (dictionary.put index assertion) state)]
- (if (n.= expected_tests (dictionary.size results))
- (let [assertions (|> results
- dictionary.entries
- (list\map product.right))]
- (write! [(|> assertions
- (list\map product.left)
- (list\fold ..add_tally ..start))
- (|> assertions
- (list\map product.right)
- (text.join_with ..separator))]))
- (wrap []))))
- (run! test)))
- (list.enumeration tests)))]]
- (wrap read!))))
diff --git a/stdlib/source/lux/time.lux b/stdlib/source/lux/time.lux
deleted file mode 100644
index 3a737f113..000000000
--- a/stdlib/source/lux/time.lux
+++ /dev/null
@@ -1,216 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]
- [enum (#+ Enum)]
- [codec (#+ Codec)]
- [monad (#+ Monad do)]]
- [control
- [pipe (#+ case>)]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<.>" text (#+ Parser)]]]
- [data
- ["." text ("#\." monoid)]]
- [math
- [number
- ["n" nat ("#\." decimal)]]]
- [type
- abstract]]
- [/
- ["." duration (#+ Duration)]])
-
-(template [<name> <singular> <plural>]
- [(def: #export <name>
- Nat
- (.nat (duration.query <singular> <plural>)))]
-
- [milli_seconds duration.milli_second duration.second]
- [seconds duration.second duration.minute]
- [minutes duration.minute duration.hour]
- [hours duration.hour duration.day]
- )
-
-(def: limit
- Nat
- (.nat (duration.to_millis duration.day)))
-
-(exception: #export (time_exceeds_a_day {time Nat})
- (exception.report
- ["Time (in milli-seconds)" (n\encode time)]
- ["Maximum (in milli-seconds)" (n\encode (dec limit))]))
-
-(def: separator ":")
-
-(def: parse_section
- (Parser Nat)
- (<>.codec n.decimal (<text>.exactly 2 <text>.decimal)))
-
-(def: parse_millis
- (Parser Nat)
- (<>.either (|> (<text>.at_most 3 <text>.decimal)
- (<>.codec n.decimal)
- (<>.after (<text>.this ".")))
- (\ <>.monad wrap 0)))
-
-(template [<maximum> <parser> <exception> <sub_parser>]
- [(exception: #export (<exception> {value Nat})
- (exception.report
- ["Value" (n\encode value)]
- ["Minimum" (n\encode 0)]
- ["Maximum" (n\encode (dec <maximum>))]))
-
- (def: <parser>
- (Parser Nat)
- (do <>.monad
- [value <sub_parser>]
- (if (n.< <maximum> value)
- (wrap value)
- (<>.lift (exception.throw <exception> [value])))))]
-
- [..hours parse_hour invalid_hour ..parse_section]
- [..minutes parse_minute invalid_minute ..parse_section]
- [..seconds parse_second invalid_second ..parse_section]
- )
-
-(abstract: #export Time
- Nat
-
- {#.doc "Time is defined as milliseconds since the start of the day (00:00:00.000)."}
-
- (def: #export midnight
- {#.doc "The instant corresponding to the start of the day: 00:00:00.000"}
- Time
- (:abstraction 0))
-
- (def: #export (from_millis milli_seconds)
- (-> Nat (Try Time))
- (if (n.< ..limit milli_seconds)
- (#try.Success (:abstraction milli_seconds))
- (exception.throw ..time_exceeds_a_day [milli_seconds])))
-
- (def: #export to_millis
- (-> Time Nat)
- (|>> :representation))
-
- (implementation: #export equivalence
- (Equivalence Time)
-
- (def: (= param subject)
- (n.= (:representation param) (:representation subject))))
-
- (implementation: #export order
- (Order Time)
-
- (def: &equivalence ..equivalence)
-
- (def: (< param subject)
- (n.< (:representation param) (:representation subject))))
-
- (`` (implementation: #export enum
- (Enum Time)
-
- (def: &order ..order)
-
- (def: succ
- (|>> :representation inc (n.% ..limit) :abstraction))
-
- (def: pred
- (|>> :representation
- (case> 0 ..limit
- millis millis)
- dec
- :abstraction))))
-
- (def: #export parser
- (Parser Time)
- (let [to_millis (: (-> Duration Nat)
- (|>> duration.to_millis .nat))
- hour (to_millis duration.hour)
- minute (to_millis duration.minute)
- second (to_millis duration.second)
- millis (to_millis duration.milli_second)]
- (do {! <>.monad}
- [utc_hour ..parse_hour
- _ (<text>.this ..separator)
- utc_minute ..parse_minute
- _ (<text>.this ..separator)
- utc_second ..parse_second
- utc_millis ..parse_millis]
- (wrap (:abstraction
- ($_ n.+
- (n.* utc_hour hour)
- (n.* utc_minute minute)
- (n.* utc_second second)
- (n.* utc_millis millis)))))))
- )
-
-(def: (pad value)
- (-> Nat Text)
- (if (n.< 10 value)
- (text\compose "0" (n\encode value))
- (n\encode value)))
-
-(def: (adjust_negative space duration)
- (-> Duration Duration Duration)
- (if (duration.negative? duration)
- (duration.merge space duration)
- duration))
-
-(def: (encode_millis millis)
- (-> Nat Text)
- (cond (n.= 0 millis) ""
- (n.< 10 millis) ($_ text\compose ".00" (n\encode millis))
- (n.< 100 millis) ($_ text\compose ".0" (n\encode millis))
- ## (n.< 1,000 millis)
- ($_ text\compose "." (n\encode millis))))
-
-(type: #export Clock
- {#hour Nat
- #minute Nat
- #second Nat
- #milli_second Nat})
-
-(def: #export (clock time)
- (-> Time Clock)
- (let [time (|> time ..to_millis .int duration.from_millis)
- [hours time] [(duration.query duration.hour time) (duration.frame duration.hour time)]
- [minutes time] [(duration.query duration.minute time) (duration.frame duration.minute time)]
- [seconds millis] [(duration.query duration.second time) (duration.frame duration.second time)]]
- {#hour (.nat hours)
- #minute (.nat minutes)
- #second (.nat seconds)
- #milli_second (|> millis
- (..adjust_negative duration.second)
- duration.to_millis
- .nat)}))
-
-(def: #export (time clock)
- (-> Clock (Try Time))
- (|> ($_ duration.merge
- (duration.up (get@ #hour clock) duration.hour)
- (duration.up (get@ #minute clock) duration.minute)
- (duration.up (get@ #second clock) duration.second)
- (duration.from_millis (.int (get@ #milli_second clock))))
- duration.to_millis
- .nat
- ..from_millis))
-
-(def: (encode time)
- (-> Time Text)
- (let [(^slots [#hour #minute #second #milli_second]) (..clock time)]
- ($_ text\compose
- (..pad hour)
- ..separator (..pad minute)
- ..separator (..pad second)
- (..encode_millis milli_second))))
-
-(implementation: #export codec
- {#.doc (doc "Based on ISO 8601."
- "For example: 21:14:51.827")}
- (Codec Text Time)
-
- (def: encode ..encode)
- (def: decode (<text>.run ..parser)))
diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux
deleted file mode 100644
index b8b483cca..000000000
--- a/stdlib/source/lux/time/date.lux
+++ /dev/null
@@ -1,348 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]
- [enum (#+ Enum)]
- [codec (#+ Codec)]
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<text>" text (#+ Parser)]]]
- [data
- ["." maybe]
- ["." text ("#\." monoid)]
- [collection
- ["." list ("#\." fold)]
- ["." dictionary (#+ Dictionary)]]]
- [math
- [number
- ["n" nat ("#\." decimal)]
- ["i" int]]]
- [type
- abstract]]
- ["." // #_
- ["#." year (#+ Year)]
- ["#." month (#+ Month)]])
-
-(def: month_by_number
- (Dictionary Nat Month)
- (list\fold (function (_ month mapping)
- (dictionary.put (//month.number month) month mapping))
- (dictionary.new n.hash)
- //month.year))
-
-(def: minimum_day
- 1)
-
-(def: (month_days year month)
- (-> Year Month Nat)
- (if (//year.leap? year)
- (//month.leap_year_days month)
- (//month.days month)))
-
-(def: (day_is_within_limits? year month day)
- (-> Year Month Nat Bit)
- (and (n.>= ..minimum_day day)
- (n.<= (..month_days year month) day)))
-
-(exception: #export (invalid_day {year Year} {month Month} {day Nat})
- (exception.report
- ["Value" (n\encode day)]
- ["Minimum" (n\encode ..minimum_day)]
- ["Maximum" (n\encode (..month_days year month))]
- ["Year" (\ //year.codec encode year)]
- ["Month" (n\encode (//month.number month))]))
-
-(def: (pad value)
- (-> Nat Text)
- (let [digits (n\encode value)]
- (if (n.< 10 value)
- (text\compose "0" digits)
- digits)))
-
-(def: separator
- "-")
-
-(abstract: #export Date
- {#year Year
- #month Month
- #day Nat}
-
- (def: #export (date year month day)
- (-> Year Month Nat (Try Date))
- (if (..day_is_within_limits? year month day)
- (#try.Success
- (:abstraction
- {#year year
- #month month
- #day day}))
- (exception.throw ..invalid_day [year month day])))
-
- (def: #export epoch
- Date
- (try.assume (..date //year.epoch
- #//month.January
- ..minimum_day)))
-
- (template [<name> <type> <field>]
- [(def: #export <name>
- (-> Date <type>)
- (|>> :representation (get@ <field>)))]
-
- [year Year #year]
- [month Month #month]
- [day_of_month Nat #day]
- )
-
- (implementation: #export equivalence
- (Equivalence Date)
-
- (def: (= reference sample)
- (let [reference (:representation reference)
- sample (:representation sample)]
- (and (\ //year.equivalence =
- (get@ #year reference)
- (get@ #year sample))
- (\ //month.equivalence =
- (get@ #month reference)
- (get@ #month sample))
- (n.= (get@ #day reference)
- (get@ #day sample))))))
-
- (implementation: #export order
- (Order Date)
-
- (def: &equivalence ..equivalence)
-
- (def: (< reference sample)
- (let [reference (:representation reference)
- sample (:representation sample)]
- (or (\ //year.order <
- (get@ #year reference)
- (get@ #year sample))
- (and (\ //year.equivalence =
- (get@ #year reference)
- (get@ #year sample))
- (or (\ //month.order <
- (get@ #month reference)
- (get@ #month sample))
- (and (\ //month.order =
- (get@ #month reference)
- (get@ #month sample))
- (n.< (get@ #day reference)
- (get@ #day sample)))))))))
- )
-
-(def: parse_section
- (Parser Nat)
- (<>.codec n.decimal (<text>.exactly 2 <text>.decimal)))
-
-(def: parse_millis
- (Parser Nat)
- (<>.either (|> (<text>.at_most 3 <text>.decimal)
- (<>.codec n.decimal)
- (<>.after (<text>.this ".")))
- (\ <>.monad wrap 0)))
-
-(template [<minimum> <maximum> <parser> <exception>]
- [(exception: #export (<exception> {value Nat})
- (exception.report
- ["Value" (n\encode value)]
- ["Minimum" (n\encode <minimum>)]
- ["Maximum" (n\encode <maximum>)]))
-
- (def: <parser>
- (Parser Nat)
- (do <>.monad
- [value ..parse_section]
- (if (and (n.>= <minimum> value)
- (n.<= <maximum> value))
- (wrap value)
- (<>.lift (exception.throw <exception> [value])))))]
-
- [1 12 parse_month invalid_month]
- )
-
-(def: #export parser
- (Parser Date)
- (do <>.monad
- [utc_year //year.parser
- _ (<text>.this ..separator)
- utc_month ..parse_month
- _ (<text>.this ..separator)
- #let [month (maybe.assume (dictionary.get utc_month ..month_by_number))]
- utc_day ..parse_section]
- (<>.lift (..date utc_year month utc_day))))
-
-(def: (encode value)
- (-> Date Text)
- ($_ text\compose
- (\ //year.codec encode (..year value))
- ..separator (..pad (|> value ..month //month.number))
- ..separator (..pad (..day_of_month value))))
-
-(implementation: #export codec
- {#.doc (doc "Based on ISO 8601."
- "For example: 2017-01-15")}
- (Codec Text Date)
-
- (def: encode ..encode)
- (def: decode (<text>.run ..parser)))
-
-(def: days_per_leap
- (|> //year.days
- (n.* 4)
- (n.+ 1)))
-
-(def: days_per_century
- (let [leaps_per_century (n./ //year.leap
- //year.century)]
- (|> //year.century
- (n.* //year.days)
- (n.+ leaps_per_century)
- (n.- 1))))
-
-(def: days_per_era
- (let [centuries_per_era (n./ //year.century
- //year.era)]
- (|> centuries_per_era
- (n.* ..days_per_century)
- (n.+ 1))))
-
-(def: days_since_epoch
- (let [years::70 70
- leaps::70 (n./ //year.leap
- years::70)
- days::70 (|> years::70
- (n.* //year.days)
- (n.+ leaps::70))
- ## The epoch is being calculated from March 1st, instead of January 1st.
- january_&_february (n.+ (//month.days #//month.January)
- (//month.days #//month.February))]
- (|> 0
- ## 1600/01/01
- (n.+ (n.* 4 days_per_era))
- ## 1900/01/01
- (n.+ (n.* 3 days_per_century))
- ## 1970/01/01
- (n.+ days::70)
- ## 1970/03/01
- (n.- january_&_february))))
-
-(def: first_month_of_civil_year 3)
-
-(with_expansions [<pull> +3
- <push> +9]
- (def: (internal_month civil_month)
- (-> Nat Int)
- (if (n.< ..first_month_of_civil_year civil_month)
- (i.+ <push> (.int civil_month))
- (i.- <pull> (.int civil_month))))
-
- (def: (civil_month internal_month)
- (-> Int Nat)
- (.nat (if (i.< +10 internal_month)
- (i.+ <pull> internal_month)
- (i.- <push> internal_month)))))
-
-(with_expansions [<up> +153
- <translation> +2
- <down> +5]
- (def: day_of_year_from_month
- (-> Nat Int)
- (|>> ..internal_month
- (i.* <up>)
- (i.+ <translation>)
- (i./ <down>)))
-
- (def: month_from_day_of_year
- (-> Int Nat)
- (|>> (i.* <down>)
- (i.+ <translation>)
- (i./ <up>)
- ..civil_month)))
-
-(def: last_era_leap_day
- (.int (dec ..days_per_leap)))
-
-(def: last_era_day
- (.int (dec ..days_per_era)))
-
-(def: (civil_year utc_month utc_year)
- (-> Nat Year Int)
- (let [## Coercing, because the year is already in external form.
- utc_year (:as Int utc_year)]
- (if (n.< ..first_month_of_civil_year utc_month)
- (dec utc_year)
- utc_year)))
-
-## http://howardhinnant.github.io/date_algorithms.html
-(def: #export (to_days date)
- (-> Date Int)
- (let [utc_month (|> date ..month //month.number)
- civil_year (..civil_year utc_month (..year date))
- era (|> (if (i.< +0 civil_year)
- (i.- (.int (dec //year.era))
- civil_year)
- civil_year)
- (i./ (.int //year.era)))
- year_of_era (i.- (i.* (.int //year.era)
- era)
- civil_year)
- day_of_year (|> utc_month
- ..day_of_year_from_month
- (i.+ (.int (dec (..day_of_month date)))))
- day_of_era (|> day_of_year
- (i.+ (i.* (.int //year.days) year_of_era))
- (i.+ (i./ (.int //year.leap) year_of_era))
- (i.- (i./ (.int //year.century) year_of_era)))]
- (|> (i.* (.int ..days_per_era) era)
- (i.+ day_of_era)
- (i.- (.int ..days_since_epoch)))))
-
-## http://howardhinnant.github.io/date_algorithms.html
-(def: #export (from_days days)
- (-> Int Date)
- (let [days (i.+ (.int ..days_since_epoch) days)
- era (|> (if (i.< +0 days)
- (i.- ..last_era_day days)
- days)
- (i./ (.int ..days_per_era)))
- day_of_era (i.- (i.* (.int ..days_per_era) era) days)
- year_of_era (|> day_of_era
- (i.- (i./ ..last_era_leap_day day_of_era))
- (i.+ (i./ (.int ..days_per_century) day_of_era))
- (i.- (i./ ..last_era_day day_of_era))
- (i./ (.int //year.days)))
- year (i.+ (i.* (.int //year.era) era)
- year_of_era)
- day_of_year (|> day_of_era
- (i.- (i.* (.int //year.days) year_of_era))
- (i.- (i./ (.int //year.leap) year_of_era))
- (i.+ (i./ (.int //year.century) year_of_era)))
- month (..month_from_day_of_year day_of_year)
- day (|> day_of_year
- (i.- (..day_of_year_from_month month))
- (i.+ +1)
- .nat)
- year (if (n.< ..first_month_of_civil_year month)
- (inc year)
- year)]
- ## Coercing, because the year is already in internal form.
- (try.assume (..date (:as Year year)
- (maybe.assume (dictionary.get month ..month_by_number))
- day))))
-
-(implementation: #export enum
- (Enum Date)
-
- (def: &order ..order)
-
- (def: succ
- (|>> ..to_days inc ..from_days))
-
- (def: pred
- (|>> ..to_days dec ..from_days)))
diff --git a/stdlib/source/lux/time/day.lux b/stdlib/source/lux/time/day.lux
deleted file mode 100644
index 57c0fae13..000000000
--- a/stdlib/source/lux/time/day.lux
+++ /dev/null
@@ -1,120 +0,0 @@
-(.module:
- [lux (#- nat)
- [abstract
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]
- [enum (#+ Enum)]
- [codec (#+ Codec)]]
- [control
- ["." try]
- ["." exception (#+ exception:)]]
- [data
- ["." text]]
- [macro
- ["." template]]
- [math
- [number
- ["n" nat]]]])
-
-(type: #export Day
- #Sunday
- #Monday
- #Tuesday
- #Wednesday
- #Thursday
- #Friday
- #Saturday)
-
-(implementation: #export equivalence
- (Equivalence Day)
-
- (def: (= reference sample)
- (case [reference sample]
- (^template [<tag>]
- [[<tag> <tag>]
- #1])
- ([#Sunday]
- [#Monday]
- [#Tuesday]
- [#Wednesday]
- [#Thursday]
- [#Friday]
- [#Saturday])
-
- _
- #0)))
-
-(def: (nat day)
- (-> Day Nat)
- (case day
- #Sunday 0
- #Monday 1
- #Tuesday 2
- #Wednesday 3
- #Thursday 4
- #Friday 5
- #Saturday 6))
-
-(implementation: #export order
- (Order Day)
-
- (def: &equivalence ..equivalence)
-
- (def: (< reference sample)
- (n.< (..nat reference) (..nat sample))))
-
-(implementation: #export enum
- (Enum Day)
-
- (def: &order ..order)
-
- (def: (succ day)
- (case day
- #Sunday #Monday
- #Monday #Tuesday
- #Tuesday #Wednesday
- #Wednesday #Thursday
- #Thursday #Friday
- #Friday #Saturday
- #Saturday #Sunday))
-
- (def: (pred day)
- (case day
- #Monday #Sunday
- #Tuesday #Monday
- #Wednesday #Tuesday
- #Thursday #Wednesday
- #Friday #Thursday
- #Saturday #Friday
- #Sunday #Saturday)))
-
-(exception: #export (not_a_day_of_the_week {value Text})
- (exception.report
- ["Value" (text.format value)]))
-
-(implementation: #export codec
- (Codec Text Day)
-
- (def: (encode value)
- (case value
- (^template [<tag>]
- [<tag> (template.text [<tag>])])
- ([#..Monday]
- [#..Tuesday]
- [#..Wednesday]
- [#..Thursday]
- [#..Friday]
- [#..Saturday]
- [#..Sunday])))
- (def: (decode value)
- (case value
- (^template [<tag>]
- [(^ (template.text [<tag>])) (#try.Success <tag>)])
- ([#..Monday]
- [#..Tuesday]
- [#..Wednesday]
- [#..Thursday]
- [#..Friday]
- [#..Saturday]
- [#..Sunday])
- _ (exception.throw ..not_a_day_of_the_week [value]))))
diff --git a/stdlib/source/lux/time/duration.lux b/stdlib/source/lux/time/duration.lux
deleted file mode 100644
index f1fcd932c..000000000
--- a/stdlib/source/lux/time/duration.lux
+++ /dev/null
@@ -1,202 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]
- [enum (#+ Enum)]
- [codec (#+ Codec)]
- [monoid (#+ Monoid)]
- [monad (#+ do)]]
- [control
- ["." try]
- ["<>" parser
- ["<t>" text (#+ Parser)]]]
- [data
- ["." text ("#\." monoid)]]
- [math
- [number
- ["i" int]
- ["." nat ("#\." decimal)]]]
- [type
- abstract]]
- ["." // #_
- ["#." year]])
-
-(abstract: #export Duration
- Int
-
- {#.doc "Durations have a resolution of milli-seconds."}
-
- (def: #export from_millis
- (-> Int Duration)
- (|>> :abstraction))
-
- (def: #export to_millis
- (-> Duration Int)
- (|>> :representation))
-
- (template [<op> <name>]
- [(def: #export (<name> param subject)
- (-> Duration Duration Duration)
- (:abstraction (<op> (:representation param) (:representation subject))))]
-
- [i.+ merge]
- [i.% frame]
- )
-
- (template [<op> <name>]
- [(def: #export (<name> scalar)
- (-> Nat Duration Duration)
- (|>> :representation (<op> (.int scalar)) :abstraction))]
-
- [i.* up]
- [i./ down]
- )
-
- (def: #export inverse
- (-> Duration Duration)
- (|>> :representation (i.* -1) :abstraction))
-
- (def: #export (query param subject)
- (-> Duration Duration Int)
- (i./ (:representation param) (:representation subject)))
-
- (implementation: #export equivalence
- (Equivalence Duration)
-
- (def: (= param subject)
- (i.= (:representation param) (:representation subject))))
-
- (implementation: #export order
- (Order Duration)
-
- (def: &equivalence ..equivalence)
- (def: (< param subject)
- (i.< (:representation param) (:representation subject))))
-
- (template [<op> <name>]
- [(def: #export <name>
- (-> Duration Bit)
- (|>> :representation (<op> +0)))]
-
- [i.> positive?]
- [i.< negative?]
- [i.= neutral?]
- )
- )
-
-(def: #export empty
- (..from_millis +0))
-
-(def: #export milli_second
- (..from_millis +1))
-
-(template [<name> <scale> <base>]
- [(def: #export <name>
- (..up <scale> <base>))]
-
- [second 1,000 milli_second]
- [minute 60 second]
- [hour 60 minute]
- [day 24 hour]
-
- [week 7 day]
- [normal_year //year.days day]
- )
-
-(def: #export leap_year
- (..merge ..day ..normal_year))
-
-(implementation: #export monoid
- (Monoid Duration)
-
- (def: identity ..empty)
- (def: compose ..merge))
-
-(template [<value> <definition>]
- [(def: <definition> <value>)]
-
- ["D" day_suffix]
- ["h" hour_suffix]
- ["m" minute_suffix]
- ["s" second_suffix]
- ["ms" milli_second_suffix]
-
- ["+" positive_sign]
- ["-" negative_sign]
- )
-
-(def: (encode duration)
- (if (\ ..equivalence = ..empty duration)
- ($_ text\compose
- ..positive_sign
- (nat\encode 0)
- ..milli_second_suffix)
- (let [signed? (negative? duration)
- [days time_left] [(query day duration) (frame day duration)]
- days (if signed?
- (i.abs days)
- days)
- time_left (if signed?
- (..inverse time_left)
- time_left)
- [hours time_left] [(query hour time_left) (frame hour time_left)]
- [minutes time_left] [(query minute time_left) (frame minute time_left)]
- [seconds time_left] [(query second time_left) (frame second time_left)]
- millis (to_millis time_left)]
- ($_ text\compose
- (if signed? ..negative_sign ..positive_sign)
- (if (i.= +0 days) "" (text\compose (nat\encode (.nat days)) ..day_suffix))
- (if (i.= +0 hours) "" (text\compose (nat\encode (.nat hours)) ..hour_suffix))
- (if (i.= +0 minutes) "" (text\compose (nat\encode (.nat minutes)) ..minute_suffix))
- (if (i.= +0 seconds) "" (text\compose (nat\encode (.nat seconds)) ..second_suffix))
- (if (i.= +0 millis) "" (text\compose (nat\encode (.nat millis)) ..milli_second_suffix))
- ))))
-
-(def: parser
- (Parser Duration)
- (let [section (: (-> Text Text (Parser Nat))
- (function (_ suffix false_suffix)
- (|> (<t>.many <t>.decimal)
- (<>.codec nat.decimal)
- (<>.before (case false_suffix
- "" (<t>.this suffix)
- _ (<>.after (<>.not (<t>.this false_suffix))
- (<t>.this suffix))))
- (<>.default 0))))]
- (do <>.monad
- [sign (<>.or (<t>.this ..negative_sign)
- (<t>.this ..positive_sign))
- days (section ..day_suffix "")
- hours (section hour_suffix "")
- minutes (section ..minute_suffix ..milli_second_suffix)
- seconds (section ..second_suffix "")
- millis (section ..milli_second_suffix "")
- #let [span (|> ..empty
- (..merge (..up days ..day))
- (..merge (..up hours ..hour))
- (..merge (..up minutes ..minute))
- (..merge (..up seconds ..second))
- (..merge (..up millis ..milli_second)))]]
- (wrap (case sign
- (#.Left _) (..inverse span)
- (#.Right _) span)))))
-
-(implementation: #export codec
- (Codec Text Duration)
-
- (def: encode ..encode)
- (def: decode (<t>.run ..parser)))
-
-(def: #export (difference from to)
- (-> Duration Duration Duration)
- (|> from ..inverse (..merge to)))
-
-(implementation: #export enum
- (Enum Duration)
-
- (def: &order ..order)
- (def: succ
- (..merge ..milli_second))
- (def: pred
- (..merge (..inverse ..milli_second))))
diff --git a/stdlib/source/lux/time/instant.lux b/stdlib/source/lux/time/instant.lux
deleted file mode 100644
index 05f54b30b..000000000
--- a/stdlib/source/lux/time/instant.lux
+++ /dev/null
@@ -1,234 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- [abstract
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]
- [enum (#+ Enum)]
- [codec (#+ Codec)]
- [monad (#+ Monad do)]]
- [control
- [io (#+ IO io)]
- ["." try]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<.>" text (#+ Parser)]]]
- [data
- ["." maybe]
- ["." text ("#\." monoid)]
- [collection
- ["." row]]]
- [math
- [number
- ["i" int]
- ["f" frac]]]
- [type
- abstract]]
- ["." // (#+ Time)
- ["." duration (#+ Duration)]
- ["." year (#+ Year)]
- ["." month (#+ Month)]
- ["." day (#+ Day)]
- ["." date (#+ Date)]])
-
-(abstract: #export Instant
- Int
-
- {#.doc "Instant is defined as milliseconds since the epoch."}
-
- (def: #export from_millis
- (-> Int Instant)
- (|>> :abstraction))
-
- (def: #export to_millis
- (-> Instant Int)
- (|>> :representation))
-
- (def: #export (span from to)
- (-> Instant Instant Duration)
- (duration.from_millis (i.- (:representation from) (:representation to))))
-
- (def: #export (shift duration instant)
- (-> Duration Instant Instant)
- (:abstraction (i.+ (duration.to_millis duration) (:representation instant))))
-
- (def: #export (relative instant)
- (-> Instant Duration)
- (|> instant :representation duration.from_millis))
-
- (def: #export (absolute offset)
- (-> Duration Instant)
- (|> offset duration.to_millis :abstraction))
-
- (implementation: #export equivalence
- (Equivalence Instant)
-
- (def: (= param subject)
- (\ i.equivalence = (:representation param) (:representation subject))))
-
- (implementation: #export order
- (Order Instant)
-
- (def: &equivalence ..equivalence)
- (def: (< param subject)
- (\ i.order < (:representation param) (:representation subject))))
-
- (`` (implementation: #export enum
- (Enum Instant)
-
- (def: &order ..order)
- (~~ (template [<name>]
- [(def: <name>
- (|>> :representation (\ i.enum <name>) :abstraction))]
-
- [succ] [pred]
- ))))
- )
-
-(def: #export epoch
- {#.doc "The instant corresponding to 1970-01-01T00:00:00Z"}
- Instant
- (..from_millis +0))
-
-(def: millis_per_day
- (duration.query duration.milli_second duration.day))
-
-(def: (split_date_time instant)
- (-> Instant [Date Duration])
- (let [offset (..to_millis instant)
- bce? (i.< +0 offset)
- [days day_time] (if bce?
- (let [[days millis] (i./% ..millis_per_day offset)]
- (case millis
- +0 [days millis]
- _ [(dec days) (i.+ ..millis_per_day millis)]))
- (i./% ..millis_per_day offset))]
- [(date.from_days days)
- (duration.from_millis day_time)]))
-
-(template [<value> <definition>]
- [(def: <definition> Text <value>)]
-
- ["T" date_suffix]
- ["Z" time_suffix]
- )
-
-(def: (clock_time duration)
- (-> Duration Time)
- (let [time (if (\ duration.order < duration.empty duration)
- (duration.merge duration.day duration)
- duration)]
- (|> time duration.to_millis .nat //.from_millis try.assume)))
-
-(def: (encode instant)
- (-> Instant Text)
- (let [[date time] (..split_date_time instant)
- time (..clock_time time)]
- ($_ text\compose
- (\ date.codec encode date) ..date_suffix
- (\ //.codec encode time) ..time_suffix)))
-
-(def: parser
- (Parser Instant)
- (do {! <>.monad}
- [days (\ ! map date.to_days date.parser)
- _ (<text>.this ..date_suffix)
- time (\ ! map //.to_millis //.parser)
- _ (<text>.this ..time_suffix)]
- (wrap (|> (if (i.< +0 days)
- (|> duration.day
- (duration.up (.nat (i.* -1 days)))
- duration.inverse)
- (duration.up (.nat days) duration.day))
- (duration.merge (duration.up time duration.milli_second))
- ..absolute))))
-
-(implementation: #export codec
- {#.doc (doc "Based on ISO 8601."
- "For example: 2017-01-15T21:14:51.827Z")}
- (Codec Text Instant)
-
- (def: encode ..encode)
- (def: decode (<text>.run ..parser)))
-
-(def: #export now
- (IO Instant)
- (io (..from_millis (for {@.old ("jvm invokestatic:java.lang.System:currentTimeMillis:")
- @.jvm (|> ("jvm member invoke static" [] "java.lang.System" "currentTimeMillis" [])
- ("jvm object cast")
- (: (primitive "java.lang.Long"))
- (:as Int))
- @.js (let [date ("js object new" ("js constant" "Date") [])]
- (|> ("js object do" "getTime" date [])
- (:as Frac)
- "lux f64 i64"))
- @.python (let [time ("python import" "time")]
- (|> ("python object do" "time" time)
- (:as Frac)
- (f.* +1,000.0)
- "lux f64 i64"))
- @.lua (|> ("lua constant" "os.time")
- "lua apply"
- (:as Int)
- (i.* +1,000))
- @.ruby (let [% ("ruby constant" "Time")
- % ("ruby object do" "now" %)]
- (|> ("ruby object do" "to_f" %)
- (:as Frac)
- (f.* +1,000.0)
- "lux f64 i64"))
- @.php (|> ("php constant" "time")
- "php apply"
- (:as Int)
- (i.* +1,000))
- @.scheme (|> ("scheme constant" "current-second")
- (:as Int)
- (i.* +1,000)
- ("scheme apply" ("scheme constant" "exact"))
- ("scheme apply" ("scheme constant" "truncate")))
- @.common_lisp (|> ("common_lisp constant" "get-universal-time")
- "common_lisp apply"
- (:as Int)
- (i.* +1,000))
- }))))
-
-(template [<field> <type> <post_processing>]
- [(def: #export (<field> instant)
- (-> Instant <type>)
- (let [[date time] (..split_date_time instant)]
- (|> <field> <post_processing>)))]
-
- [date Date (|>)]
- [time Time ..clock_time]
- )
-
-(def: #export (day_of_week instant)
- (-> Instant Day)
- (let [offset (..relative instant)
- days (duration.query duration.day offset)
- day_time (duration.frame duration.day offset)
- days (if (and (duration.negative? offset)
- (not (duration.neutral? day_time)))
- (dec days)
- days)
- ## 1970/01/01 was a Thursday
- y1970m0d0 +4]
- (case (|> y1970m0d0
- (i.+ days) (i.% +7)
- ## This is done to turn negative days into positive days.
- (i.+ +7) (i.% +7))
- +0 #day.Sunday
- +1 #day.Monday
- +2 #day.Tuesday
- +3 #day.Wednesday
- +4 #day.Thursday
- +5 #day.Friday
- +6 #day.Saturday
- _ (undefined))))
-
-(def: #export (from_date_time date time)
- (-> Date Time Instant)
- (|> (date.to_days date)
- (i.* (duration.to_millis duration.day))
- (i.+ (.int (//.to_millis time)))
- ..from_millis))
diff --git a/stdlib/source/lux/time/month.lux b/stdlib/source/lux/time/month.lux
deleted file mode 100644
index 6848f4869..000000000
--- a/stdlib/source/lux/time/month.lux
+++ /dev/null
@@ -1,224 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]
- [order (#+ Order)]
- [enum (#+ Enum)]
- [codec (#+ Codec)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." text]]
- [macro
- ["." template]]
- [math
- [number
- ["n" nat]]]])
-
-(type: #export Month
- #January
- #February
- #March
- #April
- #May
- #June
- #July
- #August
- #September
- #October
- #November
- #December)
-
-(implementation: #export equivalence
- (Equivalence Month)
-
- (def: (= reference sample)
- (case [reference sample]
- (^template [<tag>]
- [[<tag> <tag>]
- true])
- ([#January]
- [#February]
- [#March]
- [#April]
- [#May]
- [#June]
- [#July]
- [#August]
- [#September]
- [#October]
- [#November]
- [#December])
-
- _
- false)))
-
-(with_expansions [<pairs> (as_is [01 #January]
- [02 #February]
- [03 #March]
- [04 #April]
- [05 #May]
- [06 #June]
- [07 #July]
- [08 #August]
- [09 #September]
- [10 #October]
- [11 #November]
- [12 #December])]
- (def: #export (number month)
- (-> Month Nat)
- (case month
- (^template [<number> <month>]
- [<month> <number>])
- (<pairs>)))
-
- (exception: #export (invalid_month {number Nat})
- (exception.report
- ["Number" (\ n.decimal encode number)]
- ["Valid range" ($_ "lux text concat"
- (\ n.decimal encode (..number #January))
- " ~ "
- (\ n.decimal encode (..number #December)))]))
-
- (def: #export (by_number number)
- (-> Nat (Try Month))
- (case number
- (^template [<number> <month>]
- [<number> (#try.Success <month>)])
- (<pairs>)
- _ (exception.throw ..invalid_month [number])))
- )
-
-(implementation: #export hash
- (Hash Month)
-
- (def: &equivalence ..equivalence)
- (def: hash ..number))
-
-(implementation: #export order
- (Order Month)
-
- (def: &equivalence ..equivalence)
-
- (def: (< reference sample)
- (n.< (..number reference) (..number sample))))
-
-(implementation: #export enum
- (Enum Month)
-
- (def: &order ..order)
-
- (def: (succ month)
- (case month
- #January #February
- #February #March
- #March #April
- #April #May
- #May #June
- #June #July
- #July #August
- #August #September
- #September #October
- #October #November
- #November #December
- #December #January))
-
- (def: (pred month)
- (case month
- #February #January
- #March #February
- #April #March
- #May #April
- #June #May
- #July #June
- #August #July
- #September #August
- #October #September
- #November #October
- #December #November
- #January #December)))
-
-(def: #export (days month)
- (-> Month Nat)
- (case month
- (^template [<days> <month>]
- [<month> <days>])
- ([31 #January]
- [28 #February]
- [31 #March]
-
- [30 #April]
- [31 #May]
- [30 #June]
-
- [31 #July]
- [31 #August]
- [30 #September]
-
- [31 #October]
- [30 #November]
- [31 #December])))
-
-(def: #export (leap_year_days month)
- (-> Month Nat)
- (case month
- #February (inc (..days month))
- _ (..days month)))
-
-(def: #export year
- (List Month)
- (list #January
- #February
- #March
- #April
- #May
- #June
- #July
- #August
- #September
- #October
- #November
- #December))
-
-(exception: #export (not_a_month_of_the_year {value Text})
- (exception.report
- ["Value" (text.format value)]))
-
-(implementation: #export codec
- (Codec Text Month)
-
- (def: (encode value)
- (case value
- (^template [<tag>]
- [<tag> (template.text [<tag>])])
- ([#..January]
- [#..February]
- [#..March]
- [#..April]
- [#..May]
- [#..June]
- [#..July]
- [#..August]
- [#..September]
- [#..October]
- [#..November]
- [#..December])))
- (def: (decode value)
- (case value
- (^template [<tag>]
- [(^ (template.text [<tag>])) (#try.Success <tag>)])
- ([#..January]
- [#..February]
- [#..March]
- [#..April]
- [#..May]
- [#..June]
- [#..July]
- [#..August]
- [#..September]
- [#..October]
- [#..November]
- [#..December])
- _ (exception.throw ..not_a_month_of_the_year [value]))))
diff --git a/stdlib/source/lux/time/year.lux b/stdlib/source/lux/time/year.lux
deleted file mode 100644
index 633045510..000000000
--- a/stdlib/source/lux/time/year.lux
+++ /dev/null
@@ -1,141 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]
- [codec (#+ Codec)]
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<t>" text (#+ Parser)]]]
- [data
- ["." text ("#\." monoid)]]
- [math
- [number
- ["n" nat ("#\." decimal)]
- ["i" int ("#\." decimal)]]]
- [type
- abstract]])
-
-(def: (internal year)
- (-> Int Int)
- (if (i.< +0 year)
- (inc year)
- year))
-
-(def: (external year)
- (-> Int Int)
- (if (i.> +0 year)
- year
- (dec year)))
-
-(exception: #export there-is-no-year-0)
-
-(abstract: #export Year
- Int
-
- (def: #export (year value)
- (-> Int (Try Year))
- (case value
- +0 (exception.throw ..there-is-no-year-0 [])
- _ (#try.Success (:abstraction (..internal value)))))
-
- (def: #export value
- (-> Year Int)
- (|>> :representation ..external))
-
- (def: #export epoch
- Year
- (:abstraction +1970))
- )
-
-(def: #export days
- 365)
-
-(type: #export Period
- Nat)
-
-(template [<period> <name>]
- [(def: #export <name>
- Period
- <period>)]
-
- [004 leap]
- [100 century]
- [400 era]
- )
-
-(def: (divisible? factor input)
- (-> Int Int Bit)
- (|> input (i.% factor) (i.= +0)))
-
-## https://en.wikipedia.org/wiki/Leap_year#Algorithm
-(def: #export (leap? year)
- (-> Year Bit)
- (let [year (|> year ..value ..internal)]
- (and (..divisible? (.int ..leap) year)
- (or (not (..divisible? (.int ..century) year))
- (..divisible? (.int ..era) year)))))
-
-(def: (with-year-0-leap year days)
- (let [after-year-0? (i.> +0 year)]
- (if after-year-0?
- (i.+ +1 days)
- days)))
-
-(def: #export (leaps year)
- (-> Year Int)
- (let [year (|> year ..value ..internal)
- limit (if (i.> +0 year)
- (dec year)
- (inc year))]
- (`` (|> +0
- (~~ (template [<polarity> <years>]
- [(<polarity> (i./ (.int <years>) limit))]
-
- [i.+ ..leap]
- [i.- ..century]
- [i.+ ..era]
- ))
- (..with-year-0-leap year)))))
-
-(def: (encode year)
- (-> Year Text)
- (let [year (..value year)]
- (if (i.< +0 year)
- (i\encode year)
- (n\encode (.nat year)))))
-
-(def: #export parser
- (Parser Year)
- (do {! <>.monad}
- [sign (<>.or (<t>.this "-") (wrap []))
- digits (<t>.many <t>.decimal)
- raw-year (<>.codec i.decimal (wrap (text\compose "+" digits)))]
- (<>.lift (..year (case sign
- (#.Left _) (i.* -1 raw-year)
- (#.Right _) raw-year)))))
-
-(implementation: #export codec
- {#.doc (doc "Based on ISO 8601."
- "For example: 2017")}
- (Codec Text Year)
-
- (def: encode ..encode)
- (def: decode (<t>.run ..parser)))
-
-(implementation: #export equivalence
- (Equivalence Year)
-
- (def: (= reference subject)
- (i.= (..value reference) (..value subject))))
-
-(implementation: #export order
- (Order Year)
-
- (def: &equivalence ..equivalence)
-
- (def: (< reference subject)
- (i.< (..value reference) (..value subject))))
diff --git a/stdlib/source/lux/tool/compiler.lux b/stdlib/source/lux/tool/compiler.lux
deleted file mode 100644
index eda74d121..000000000
--- a/stdlib/source/lux/tool/compiler.lux
+++ /dev/null
@@ -1,46 +0,0 @@
-(.module:
- [lux (#- Module Code)
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- [binary (#+ Binary)]
- ["." text]
- [collection
- ["." row (#+ Row)]]]
- [world
- ["." file (#+ Path)]]]
- [/
- [meta
- ["." archive (#+ Output Archive)
- [key (#+ Key)]
- [descriptor (#+ Descriptor Module)]
- [document (#+ Document)]]]])
-
-(type: #export Code
- Text)
-
-(type: #export Parameter
- Text)
-
-(type: #export Input
- {#module Module
- #file Path
- #hash Nat
- #code Code})
-
-(type: #export (Compilation s d o)
- {#dependencies (List Module)
- #process (-> s Archive
- (Try [s (Either (Compilation s d o)
- [Descriptor (Document d) Output])]))})
-
-(type: #export (Compiler s d o)
- (-> Input (Compilation s d o)))
-
-(type: #export (Instancer s d o)
- (-> (Key d) (List Parameter) (Compiler s d o)))
-
-(exception: #export (cannot_compile {module Module})
- (exception.report
- ["Module" module]))
diff --git a/stdlib/source/lux/tool/compiler/arity.lux b/stdlib/source/lux/tool/compiler/arity.lux
deleted file mode 100644
index 72140b6c6..000000000
--- a/stdlib/source/lux/tool/compiler/arity.lux
+++ /dev/null
@@ -1,15 +0,0 @@
-(.module:
- [lux #*
- [math
- [number
- ["n" nat]]]])
-
-(type: #export Arity Nat)
-
-(template [<comparison> <name>]
- [(def: #export <name> (-> Arity Bit) (<comparison> 1))]
-
- [n.< nullary?]
- [n.= unary?]
- [n.> multiary?]
- )
diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux
deleted file mode 100644
index 2803398e0..000000000
--- a/stdlib/source/lux/tool/compiler/default/init.lux
+++ /dev/null
@@ -1,286 +0,0 @@
-(.module:
- [lux (#- Module)
- ["@" target (#+ Target)]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- [binary (#+ Binary)]
- ["." product]
- ["." text ("#\." hash)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]
- ["." dictionary]
- ["." set]
- ["." row ("#\." functor)]]]
- ["." meta]
- [world
- ["." file]]]
- ["." // #_
- ["/#" // (#+ Instancer)
- ["#." phase]
- [language
- [lux
- [program (#+ Program)]
- ["#." version]
- ["#." syntax (#+ Aliases)]
- ["#." synthesis]
- ["#." directive (#+ Requirements)]
- ["#." generation]
- ["#." analysis
- [macro (#+ Expander)]
- ["#/." evaluation]]
- [phase
- [".P" synthesis]
- [".P" directive]
- [".P" analysis
- ["." module]]
- ["." extension (#+ Extender)
- [".E" analysis]
- [".E" synthesis]
- [directive
- [".D" lux]]]]]]
- [meta
- ["." archive (#+ Archive)
- ["." descriptor (#+ Module)]
- ["." artifact]
- ["." document]]]]])
-
-(def: #export (state target module expander host_analysis host generate generation_bundle)
- (All [anchor expression directive]
- (-> Target
- Module
- Expander
- ///analysis.Bundle
- (///generation.Host expression directive)
- (///generation.Phase anchor expression directive)
- (///generation.Bundle anchor expression directive)
- (///directive.State+ anchor expression directive)))
- (let [synthesis_state [synthesisE.bundle ///synthesis.init]
- generation_state [generation_bundle (///generation.state host module)]
- eval (///analysis/evaluation.evaluator expander synthesis_state generation_state generate)
- analysis_state [(analysisE.bundle eval host_analysis)
- (///analysis.state (///analysis.info ///version.version target))]]
- [extension.empty
- {#///directive.analysis {#///directive.state analysis_state
- #///directive.phase (analysisP.phase expander)}
- #///directive.synthesis {#///directive.state synthesis_state
- #///directive.phase synthesisP.phase}
- #///directive.generation {#///directive.state generation_state
- #///directive.phase generate}}]))
-
-(def: #export (with_default_directives expander host_analysis program anchorT,expressionT,directiveT extender)
- (All [anchor expression directive]
- (-> Expander
- ///analysis.Bundle
- (Program expression directive)
- [Type Type Type]
- Extender
- (-> (///directive.State+ anchor expression directive)
- (///directive.State+ anchor expression directive))))
- (function (_ [directive_extensions sub_state])
- [(dictionary.merge directive_extensions
- (luxD.bundle expander host_analysis program anchorT,expressionT,directiveT extender))
- sub_state]))
-
-(type: Reader
- (-> Source (Either [Source Text] [Source Code])))
-
-(def: (reader current_module aliases [location offset source_code])
- (-> Module Aliases Source (///analysis.Operation Reader))
- (function (_ [bundle state])
- (#try.Success [[bundle state]
- (///syntax.parse current_module aliases ("lux text size" source_code))])))
-
-(def: (read source reader)
- (-> Source Reader (///analysis.Operation [Source Code]))
- (function (_ [bundle compiler])
- (case (reader source)
- (#.Left [source' error])
- (#try.Failure error)
-
- (#.Right [source' output])
- (let [[location _] output]
- (#try.Success [[bundle (|> compiler
- (set@ #.source source')
- (set@ #.location location))]
- [source' output]])))))
-
-(type: (Operation a)
- (All [anchor expression directive]
- (///directive.Operation anchor expression directive a)))
-
-(type: (Payload directive)
- [(///generation.Buffer directive)
- artifact.Registry])
-
-(def: (begin dependencies hash input)
- (-> (List Module) Nat ///.Input
- (All [anchor expression directive]
- (///directive.Operation anchor expression directive
- [Source (Payload directive)])))
- (do ///phase.monad
- [#let [module (get@ #///.module input)]
- _ (///directive.set_current_module module)]
- (///directive.lift_analysis
- (do {! ///phase.monad}
- [_ (module.create hash module)
- _ (monad.map ! module.import dependencies)
- #let [source (///analysis.source (get@ #///.module input) (get@ #///.code input))]
- _ (///analysis.set_source_code source)]
- (wrap [source [///generation.empty_buffer
- artifact.empty]])))))
-
-(def: (end module)
- (-> Module
- (All [anchor expression directive]
- (///directive.Operation anchor expression directive [.Module (Payload directive)])))
- (do ///phase.monad
- [_ (///directive.lift_analysis
- (module.set_compiled module))
- analysis_module (<| (: (Operation .Module))
- ///directive.lift_analysis
- extension.lift
- meta.current_module)
- final_buffer (///directive.lift_generation
- ///generation.buffer)
- final_registry (///directive.lift_generation
- ///generation.get_registry)]
- (wrap [analysis_module [final_buffer
- final_registry]])))
-
-## TODO: Inline ASAP
-(def: (get_current_payload _)
- (All [directive]
- (-> (Payload directive)
- (All [anchor expression]
- (///directive.Operation anchor expression directive
- (Payload directive)))))
- (do ///phase.monad
- [buffer (///directive.lift_generation
- ///generation.buffer)
- registry (///directive.lift_generation
- ///generation.get_registry)]
- (wrap [buffer registry])))
-
-## TODO: Inline ASAP
-(def: (process_directive archive expander pre_payoad code)
- (All [directive]
- (-> Archive Expander (Payload directive) Code
- (All [anchor expression]
- (///directive.Operation anchor expression directive
- [Requirements (Payload directive)]))))
- (do ///phase.monad
- [#let [[pre_buffer pre_registry] pre_payoad]
- _ (///directive.lift_generation
- (///generation.set_buffer pre_buffer))
- _ (///directive.lift_generation
- (///generation.set_registry pre_registry))
- requirements (let [execute! (directiveP.phase expander)]
- (execute! archive code))
- post_payload (..get_current_payload pre_payoad)]
- (wrap [requirements post_payload])))
-
-(def: (iteration archive expander reader source pre_payload)
- (All [directive]
- (-> Archive Expander Reader Source (Payload directive)
- (All [anchor expression]
- (///directive.Operation anchor expression directive
- [Source Requirements (Payload directive)]))))
- (do ///phase.monad
- [[source code] (///directive.lift_analysis
- (..read source reader))
- [requirements post_payload] (process_directive archive expander pre_payload code)]
- (wrap [source requirements post_payload])))
-
-(def: (iterate archive expander module source pre_payload aliases)
- (All [directive]
- (-> Archive Expander Module Source (Payload directive) Aliases
- (All [anchor expression]
- (///directive.Operation anchor expression directive
- (Maybe [Source Requirements (Payload directive)])))))
- (do ///phase.monad
- [reader (///directive.lift_analysis
- (..reader module aliases source))]
- (function (_ state)
- (case (///phase.run' state (..iteration archive expander reader source pre_payload))
- (#try.Success [state source&requirements&buffer])
- (#try.Success [state (#.Some source&requirements&buffer)])
-
- (#try.Failure error)
- (if (exception.match? ///syntax.end_of_file error)
- (#try.Success [state #.None])
- (exception.with ///.cannot_compile module (#try.Failure error)))))))
-
-(def: (default_dependencies prelude input)
- (-> Module ///.Input (List Module))
- (list& archive.runtime_module
- (if (text\= prelude (get@ #///.module input))
- (list)
- (list prelude))))
-
-(def: module_aliases
- (-> .Module Aliases)
- (|>> (get@ #.module_aliases) (dictionary.from_list text.hash)))
-
-(def: #export (compiler expander prelude write_directive)
- (All [anchor expression directive]
- (-> Expander Module (-> directive Binary)
- (Instancer (///directive.State+ anchor expression directive) .Module)))
- (let [execute! (directiveP.phase expander)]
- (function (_ key parameters input)
- (let [dependencies (default_dependencies prelude input)]
- {#///.dependencies dependencies
- #///.process (function (_ state archive)
- (do {! try.monad}
- [#let [hash (text\hash (get@ #///.code input))]
- [state [source buffer]] (<| (///phase.run' state)
- (..begin dependencies hash input))
- #let [module (get@ #///.module input)]]
- (loop [iteration (<| (///phase.run' state)
- (..iterate archive expander module source buffer ///syntax.no_aliases))]
- (do !
- [[state ?source&requirements&temporary_payload] iteration]
- (case ?source&requirements&temporary_payload
- #.None
- (do !
- [[state [analysis_module [final_buffer final_registry]]] (///phase.run' state (..end module))
- #let [descriptor {#descriptor.hash hash
- #descriptor.name module
- #descriptor.file (get@ #///.file input)
- #descriptor.references (set.from_list text.hash dependencies)
- #descriptor.state #.Compiled
- #descriptor.registry final_registry}]]
- (wrap [state
- (#.Right [descriptor
- (document.write key analysis_module)
- (row\map (function (_ [artifact_id directive])
- [artifact_id (write_directive directive)])
- final_buffer)])]))
-
- (#.Some [source requirements temporary_payload])
- (let [[temporary_buffer temporary_registry] temporary_payload]
- (wrap [state
- (#.Left {#///.dependencies (|> requirements
- (get@ #///directive.imports)
- (list\map product.left))
- #///.process (function (_ state archive)
- (recur (<| (///phase.run' state)
- (do {! ///phase.monad}
- [analysis_module (<| (: (Operation .Module))
- ///directive.lift_analysis
- extension.lift
- meta.current_module)
- _ (///directive.lift_generation
- (///generation.set_buffer temporary_buffer))
- _ (///directive.lift_generation
- (///generation.set_registry temporary_registry))
- _ (|> requirements
- (get@ #///directive.referrals)
- (monad.map ! (execute! archive)))
- temporary_payload (..get_current_payload temporary_payload)]
- (..iterate archive expander module source temporary_payload (..module_aliases analysis_module))))))})]))
- )))))}))))
diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
deleted file mode 100644
index 605f1d1e2..000000000
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ /dev/null
@@ -1,601 +0,0 @@
-(.module:
- [lux (#- Module)
- [type (#+ :share)]
- ["." debug]
- ["@" target]
- [abstract
- ["." monad (#+ Monad do)]]
- [control
- ["." function]
- ["." try (#+ Try) ("#\." functor)]
- ["." exception (#+ exception:)]
- [concurrency
- ["." promise (#+ Promise Resolver) ("#\." monad)]
- ["." stm (#+ Var STM)]]]
- [data
- ["." binary (#+ Binary)]
- ["." bit]
- ["." product]
- ["." maybe]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." dictionary (#+ Dictionary)]
- ["." row (#+ Row) ("#\." fold)]
- ["." set (#+ Set)]
- ["." list ("#\." monoid functor fold)]]
- [format
- ["_" binary (#+ Writer)]]]
- [world
- ["." file (#+ Path)]]]
- ["." // #_
- ["#." init]
- ["/#" //
- ["#." phase (#+ Phase)]
- [language
- [lux
- [program (#+ Program)]
- ["$" /]
- ["#." version]
- ["." syntax]
- ["#." analysis
- [macro (#+ Expander)]]
- ["#." synthesis]
- ["#." generation (#+ Buffer)]
- ["#." directive]
- [phase
- ["." extension (#+ Extender)]
- [analysis
- ["." module]]]]]
- [meta
- ["." archive (#+ Output Archive)
- ["." artifact (#+ Registry)]
- ["." descriptor (#+ Descriptor Module)]
- ["." document (#+ Document)]]
- [io (#+ Context)
- ["." context]
- ["ioW" archive]]]]]
- [program
- [compositor
- ["." cli (#+ Compilation Library)]
- ["." static (#+ Static)]
- ["." import (#+ Import)]]])
-
-(with_expansions [<type_vars> (as_is anchor expression directive)
- <Operation> (as_is ///generation.Operation <type_vars>)]
- (type: #export Phase_Wrapper
- (All [s i o] (-> (Phase s i o) Any)))
-
- (type: #export (Platform <type_vars>)
- {#&file_system (file.System Promise)
- #host (///generation.Host expression directive)
- #phase (///generation.Phase <type_vars>)
- #runtime (<Operation> [Registry Output])
- #phase_wrapper (-> Archive (<Operation> Phase_Wrapper))
- #write (-> directive Binary)})
-
- ## TODO: Get rid of this
- (type: (Action a)
- (Promise (Try a)))
-
- ## TODO: Get rid of this
- (def: monad
- (:as (Monad Action)
- (try.with promise.monad)))
-
- (with_expansions [<Platform> (as_is (Platform <type_vars>))
- <State+> (as_is (///directive.State+ <type_vars>))
- <Bundle> (as_is (///generation.Bundle <type_vars>))]
-
- (def: writer
- (Writer [Descriptor (Document .Module)])
- (_.and descriptor.writer
- (document.writer $.writer)))
-
- (def: (cache_module static platform module_id [descriptor document output])
- (All [<type_vars>]
- (-> Static <Platform> archive.ID [Descriptor (Document Any) Output]
- (Promise (Try Any))))
- (let [system (get@ #&file_system platform)
- write_artifact! (: (-> [artifact.ID Binary] (Action Any))
- (function (_ [artifact_id content])
- (ioW.write system static module_id artifact_id content)))]
- (do {! ..monad}
- [_ (ioW.prepare system static module_id)
- _ (for {@.python (|> output
- row.to_list
- (list.chunk 128)
- (monad.map ! (monad.map ! write_artifact!))
- (: (Action (List (List Any)))))}
- (|> output
- row.to_list
- (monad.map ..monad write_artifact!)
- (: (Action (List Any)))))
- document (\ promise.monad wrap
- (document.check $.key document))]
- (ioW.cache system static module_id
- (_.run ..writer [descriptor document])))))
-
- ## TODO: Inline ASAP
- (def: initialize_buffer!
- (All [<type_vars>]
- (///generation.Operation <type_vars> Any))
- (///generation.set_buffer ///generation.empty_buffer))
-
- ## TODO: Inline ASAP
- (def: (compile_runtime! platform)
- (All [<type_vars>]
- (-> <Platform> (///generation.Operation <type_vars> [Registry Output])))
- (do ///phase.monad
- [_ ..initialize_buffer!]
- (get@ #runtime platform)))
-
- (def: (runtime_descriptor registry)
- (-> Registry Descriptor)
- {#descriptor.hash 0
- #descriptor.name archive.runtime_module
- #descriptor.file ""
- #descriptor.references (set.new text.hash)
- #descriptor.state #.Compiled
- #descriptor.registry registry})
-
- (def: runtime_document
- (Document .Module)
- (document.write $.key (module.new 0)))
-
- (def: (process_runtime archive platform)
- (All [<type_vars>]
- (-> Archive <Platform>
- (///directive.Operation <type_vars>
- [Archive [Descriptor (Document .Module) Output]])))
- (do ///phase.monad
- [[registry payload] (///directive.lift_generation
- (..compile_runtime! platform))
- #let [[descriptor document] [(..runtime_descriptor registry) ..runtime_document]]
- archive (///phase.lift (if (archive.reserved? archive archive.runtime_module)
- (archive.add archive.runtime_module [descriptor document payload] archive)
- (do try.monad
- [[_ archive] (archive.reserve archive.runtime_module archive)]
- (archive.add archive.runtime_module [descriptor document payload] archive))))]
- (wrap [archive [descriptor document payload]])))
-
- (def: (initialize_state extender
- [analysers
- synthesizers
- generators
- directives]
- analysis_state
- state)
- (All [<type_vars>]
- (-> Extender
- [(Dictionary Text ///analysis.Handler)
- (Dictionary Text ///synthesis.Handler)
- (Dictionary Text (///generation.Handler <type_vars>))
- (Dictionary Text (///directive.Handler <type_vars>))]
- .Lux
- <State+>
- (Try <State+>)))
- (|> (:share [<type_vars>]
- <State+>
- state
-
- (///directive.Operation <type_vars> Any)
- (do ///phase.monad
- [_ (///directive.lift_analysis
- (///analysis.install analysis_state))
- _ (///directive.lift_analysis
- (extension.with extender analysers))
- _ (///directive.lift_synthesis
- (extension.with extender synthesizers))
- _ (///directive.lift_generation
- (extension.with extender (:assume generators)))
- _ (extension.with extender (:assume directives))]
- (wrap [])))
- (///phase.run' state)
- (\ try.monad map product.left)))
-
- (def: (phase_wrapper archive platform state)
- (All [<type_vars>]
- (-> Archive <Platform> <State+> (Try [<State+> Phase_Wrapper])))
- (let [phase_wrapper (get@ #phase_wrapper platform)]
- (|> archive
- phase_wrapper
- ///directive.lift_generation
- (///phase.run' state))))
-
- (def: (complete_extensions host_directive_bundle phase_wrapper [analysers synthesizers generators directives])
- (All [<type_vars>]
- (-> (-> Phase_Wrapper (///directive.Bundle <type_vars>))
- Phase_Wrapper
- [(Dictionary Text ///analysis.Handler)
- (Dictionary Text ///synthesis.Handler)
- (Dictionary Text (///generation.Handler <type_vars>))
- (Dictionary Text (///directive.Handler <type_vars>))]
- [(Dictionary Text ///analysis.Handler)
- (Dictionary Text ///synthesis.Handler)
- (Dictionary Text (///generation.Handler <type_vars>))
- (Dictionary Text (///directive.Handler <type_vars>))]))
- [analysers
- synthesizers
- generators
- (dictionary.merge directives (host_directive_bundle phase_wrapper))])
-
- (def: #export (initialize static module expander host_analysis platform generation_bundle host_directive_bundle program anchorT,expressionT,directiveT extender
- import compilation_sources)
- (All [<type_vars>]
- (-> Static
- Module
- Expander
- ///analysis.Bundle
- <Platform>
- <Bundle>
- (-> Phase_Wrapper (///directive.Bundle <type_vars>))
- (Program expression directive)
- [Type Type Type] (-> Phase_Wrapper Extender)
- Import (List Context)
- (Promise (Try [<State+> Archive]))))
- (do {! (try.with promise.monad)}
- [#let [state (//init.state (get@ #static.host static)
- module
- expander
- host_analysis
- (get@ #host platform)
- (get@ #phase platform)
- generation_bundle)]
- _ (ioW.enable (get@ #&file_system platform) static)
- [archive analysis_state bundles] (ioW.thaw (get@ #host platform) (get@ #&file_system platform) static import compilation_sources)
- #let [with_missing_extensions
- (: (All [<type_vars>]
- (-> <Platform> (Program expression directive) <State+> (Promise (Try <State+>))))
- (function (_ platform program state)
- (promise\wrap
- (do try.monad
- [[state phase_wrapper] (..phase_wrapper archive platform state)]
- (|> state
- (initialize_state (extender phase_wrapper)
- (:assume (..complete_extensions host_directive_bundle phase_wrapper (:assume bundles)))
- analysis_state)
- (try\map (//init.with_default_directives expander host_analysis program anchorT,expressionT,directiveT (extender phase_wrapper))))))))]]
- (if (archive.archived? archive archive.runtime_module)
- (do !
- [state (with_missing_extensions platform program state)]
- (wrap [state archive]))
- (do !
- [[state [archive payload]] (|> (..process_runtime archive platform)
- (///phase.run' state)
- promise\wrap)
- _ (..cache_module static platform 0 payload)
-
- state (with_missing_extensions platform program state)]
- (wrap [state archive])))))
-
- (def: compilation_log_separator
- (format text.new_line text.tab))
-
- (def: (module_compilation_log module)
- (All [<type_vars>]
- (-> Module <State+> Text))
- (|>> (get@ [#extension.state
- #///directive.generation
- #///directive.state
- #extension.state
- #///generation.log])
- (row\fold (function (_ right left)
- (format left ..compilation_log_separator right))
- module)))
-
- (def: with_reset_log
- (All [<type_vars>]
- (-> <State+> <State+>))
- (set@ [#extension.state
- #///directive.generation
- #///directive.state
- #extension.state
- #///generation.log]
- row.empty))
-
- (def: empty
- (Set Module)
- (set.new text.hash))
-
- (type: Mapping
- (Dictionary Module (Set Module)))
-
- (type: Dependence
- {#depends_on Mapping
- #depended_by Mapping})
-
- (def: independence
- Dependence
- (let [empty (dictionary.new text.hash)]
- {#depends_on empty
- #depended_by empty}))
-
- (def: (depend module import dependence)
- (-> Module Module Dependence Dependence)
- (let [transitive_dependency (: (-> (-> Dependence Mapping) Module (Set Module))
- (function (_ lens module)
- (|> dependence
- lens
- (dictionary.get module)
- (maybe.default ..empty))))
- transitive_depends_on (transitive_dependency (get@ #depends_on) import)
- transitive_depended_by (transitive_dependency (get@ #depended_by) module)
- update_dependence (: (-> [Module (Set Module)] [Module (Set Module)]
- (-> Mapping Mapping))
- (function (_ [source forward] [target backward])
- (function (_ mapping)
- (let [with_dependence+transitives
- (|> mapping
- (dictionary.upsert source ..empty (set.add target))
- (dictionary.update source (set.union forward)))]
- (list\fold (function (_ previous)
- (dictionary.upsert previous ..empty (set.add target)))
- with_dependence+transitives
- (set.to_list backward))))))]
- (|> dependence
- (update@ #depends_on
- (update_dependence
- [module transitive_depends_on]
- [import transitive_depended_by]))
- (update@ #depended_by
- ((function.flip update_dependence)
- [module transitive_depends_on]
- [import transitive_depended_by])))))
-
- (def: (circular_dependency? module import dependence)
- (-> Module Module Dependence Bit)
- (let [dependence? (: (-> Module (-> Dependence Mapping) Module Bit)
- (function (_ from relationship to)
- (let [targets (|> dependence
- relationship
- (dictionary.get from)
- (maybe.default ..empty))]
- (set.member? targets to))))]
- (or (dependence? import (get@ #depends_on) module)
- (dependence? module (get@ #depended_by) import))))
-
- (exception: #export (module_cannot_import_itself {module Module})
- (exception.report
- ["Module" (%.text module)]))
-
- (exception: #export (cannot_import_circular_dependency {importer Module}
- {importee Module})
- (exception.report
- ["Importer" (%.text importer)]
- ["importee" (%.text importee)]))
-
- (def: (verify_dependencies importer importee dependence)
- (-> Module Module Dependence (Try Any))
- (cond (text\= importer importee)
- (exception.throw ..module_cannot_import_itself [importer])
-
- (..circular_dependency? importer importee dependence)
- (exception.throw ..cannot_import_circular_dependency [importer importee])
-
- ## else
- (#try.Success [])))
-
- (with_expansions [<Context> (as_is [Archive <State+>])
- <Result> (as_is (Try <Context>))
- <Return> (as_is (Promise <Result>))
- <Signal> (as_is (Resolver <Result>))
- <Pending> (as_is [<Return> <Signal>])
- <Importer> (as_is (-> Module Module <Return>))
- <Compiler> (as_is (-> Module <Importer> archive.ID <Context> Module <Return>))]
- (def: (parallel initial)
- (All [<type_vars>]
- (-> <Context>
- (-> <Compiler> <Importer>)))
- (let [current (stm.var initial)
- pending (:share [<type_vars>]
- <Context>
- initial
-
- (Var (Dictionary Module <Pending>))
- (:assume (stm.var (dictionary.new text.hash))))
- dependence (: (Var Dependence)
- (stm.var ..independence))]
- (function (_ compile)
- (function (import! importer module)
- (do {! promise.monad}
- [[return signal] (:share [<type_vars>]
- <Context>
- initial
-
- (Promise [<Return> (Maybe [<Context>
- archive.ID
- <Signal>])])
- (:assume
- (stm.commit
- (do {! stm.monad}
- [dependence (if (text\= archive.runtime_module importer)
- (stm.read dependence)
- (do !
- [[_ dependence] (stm.update (..depend importer module) dependence)]
- (wrap dependence)))]
- (case (..verify_dependencies importer module dependence)
- (#try.Failure error)
- (wrap [(promise.resolved (#try.Failure error))
- #.None])
-
- (#try.Success _)
- (do !
- [[archive state] (stm.read current)]
- (if (archive.archived? archive module)
- (wrap [(promise\wrap (#try.Success [archive state]))
- #.None])
- (do !
- [@pending (stm.read pending)]
- (case (dictionary.get module @pending)
- (#.Some [return signal])
- (wrap [return
- #.None])
-
- #.None
- (case (if (archive.reserved? archive module)
- (do try.monad
- [module_id (archive.id module archive)]
- (wrap [module_id archive]))
- (archive.reserve module archive))
- (#try.Success [module_id archive])
- (do !
- [_ (stm.write [archive state] current)
- #let [[return signal] (:share [<type_vars>]
- <Context>
- initial
-
- <Pending>
- (promise.promise []))]
- _ (stm.update (dictionary.put module [return signal]) pending)]
- (wrap [return
- (#.Some [[archive state]
- module_id
- signal])]))
-
- (#try.Failure error)
- (wrap [(promise\wrap (#try.Failure error))
- #.None])))))))))))
- _ (case signal
- #.None
- (wrap [])
-
- (#.Some [context module_id resolver])
- (do !
- [result (compile importer import! module_id context module)
- result (case result
- (#try.Failure error)
- (wrap result)
-
- (#try.Success [resulting_archive resulting_state])
- (stm.commit (do stm.monad
- [[_ [merged_archive _]] (stm.update (function (_ [archive state])
- [(archive.merge resulting_archive archive)
- state])
- current)]
- (wrap (#try.Success [merged_archive resulting_state])))))
- _ (promise.future (resolver result))]
- (wrap [])))]
- return)))))
-
- ## TODO: Find a better way, as this only works for the Lux compiler.
- (def: (updated_state archive state)
- (All [<type_vars>]
- (-> Archive <State+> (Try <State+>)))
- (do {! try.monad}
- [modules (monad.map ! (function (_ module)
- (do !
- [[descriptor document output] (archive.find module archive)
- lux_module (document.read $.key document)]
- (wrap [module lux_module])))
- (archive.archived archive))
- #let [additions (|> modules
- (list\map product.left)
- (set.from_list text.hash))]]
- (wrap (update@ [#extension.state
- #///directive.analysis
- #///directive.state
- #extension.state]
- (function (_ analysis_state)
- (|> analysis_state
- (:as .Lux)
- (update@ #.modules (function (_ current)
- (list\compose (list.filter (|>> product.left
- (set.member? additions)
- not)
- current)
- modules)))
- :assume))
- state))))
-
- (def: (set_current_module module state)
- (All [<type_vars>]
- (-> Module <State+> <State+>))
- (|> (///directive.set_current_module module)
- (///phase.run' state)
- try.assume
- product.left))
-
- (def: #export (compile import static expander platform compilation context)
- (All [<type_vars>]
- (-> Import Static Expander <Platform> Compilation <Context> <Return>))
- (let [[compilation_sources compilation_libraries compilation_target compilation_module] compilation
- base_compiler (:share [<type_vars>]
- <Context>
- context
-
- (///.Compiler <State+> .Module Any)
- (:assume
- ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list))))
- compiler (..parallel
- context
- (function (_ importer import! module_id [archive state] module)
- (do {! (try.with promise.monad)}
- [#let [state (..set_current_module module state)]
- input (context.read (get@ #&file_system platform)
- importer
- import
- compilation_sources
- (get@ #static.host_module_extension static)
- module)]
- (loop [[archive state] [archive state]
- compilation (base_compiler (:as ///.Input input))
- all_dependencies (: (List Module)
- (list))]
- (let [new_dependencies (get@ #///.dependencies compilation)
- all_dependencies (list\compose new_dependencies all_dependencies)
- continue! (:share [<type_vars>]
- <Platform>
- platform
-
- (-> <Context> (///.Compilation <State+> .Module Any) (List Module)
- (Action [Archive <State+>]))
- (:assume
- recur))]
- (do !
- [[archive state] (case new_dependencies
- #.Nil
- (wrap [archive state])
-
- (#.Cons _)
- (do !
- [archive,document+ (|> new_dependencies
- (list\map (import! module))
- (monad.seq ..monad))
- #let [archive (|> archive,document+
- (list\map product.left)
- (list\fold archive.merge archive))]]
- (wrap [archive (try.assume
- (..updated_state archive state))])))]
- (case ((get@ #///.process compilation)
- ## TODO: The "///directive.set_current_module" below shouldn't be necessary. Remove it ASAP.
- ## TODO: The context shouldn't need to be re-set either.
- (|> (///directive.set_current_module module)
- (///phase.run' state)
- try.assume
- product.left)
- archive)
- (#try.Success [state more|done])
- (case more|done
- (#.Left more)
- (continue! [archive state] more all_dependencies)
-
- (#.Right [descriptor document output])
- (do !
- [#let [_ (debug.log! (..module_compilation_log module state))
- descriptor (set@ #descriptor.references (set.from_list text.hash all_dependencies) descriptor)]
- _ (..cache_module static platform module_id [descriptor document output])]
- (case (archive.add module [descriptor document output] archive)
- (#try.Success archive)
- (wrap [archive
- (..with_reset_log state)])
-
- (#try.Failure error)
- (promise\wrap (#try.Failure error)))))
-
- (#try.Failure error)
- (do !
- [_ (ioW.freeze (get@ #&file_system platform) static archive)]
- (promise\wrap (#try.Failure error))))))))))]
- (compiler archive.runtime_module compilation_module)))
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux.lux b/stdlib/source/lux/tool/compiler/language/lux.lux
deleted file mode 100644
index 1d507b52f..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux.lux
+++ /dev/null
@@ -1,106 +0,0 @@
-(.module:
- [lux #*
- [control
- ["<>" parser
- ["<b>" binary (#+ Parser)]]]
- [data
- [format
- ["_" binary (#+ Writer)]]]]
- ["." / #_
- ["#." version]
- [phase
- [analysis
- ["." module]]]
- [///
- [meta
- [archive
- ["." signature]
- ["." key (#+ Key)]]]]])
-
-## TODO: Remove #module_hash, #imports & #module_state ASAP.
-## TODO: Not just from this parser, but from the lux.Module type.
-(def: #export writer
- (Writer .Module)
- (let [definition (: (Writer Definition)
- ($_ _.and _.bit _.type _.code _.any))
- name (: (Writer Name)
- (_.and _.text _.text))
- alias (: (Writer Alias)
- (_.and _.text _.text))
- global (: (Writer Global)
- (_.or alias
- definition))
- tag (: (Writer [Nat (List Name) Bit Type])
- ($_ _.and
- _.nat
- (_.list name)
- _.bit
- _.type))
- type (: (Writer [(List Name) Bit Type])
- ($_ _.and
- (_.list name)
- _.bit
- _.type))]
- ($_ _.and
- ## #module_hash
- _.nat
- ## #module_aliases
- (_.list alias)
- ## #definitions
- (_.list (_.and _.text global))
- ## #imports
- (_.list _.text)
- ## #tags
- (_.list (_.and _.text tag))
- ## #types
- (_.list (_.and _.text type))
- ## #module_annotations
- (_.maybe _.code)
- ## #module_state
- _.any)))
-
-(def: #export parser
- (Parser .Module)
- (let [definition (: (Parser Definition)
- ($_ <>.and <b>.bit <b>.type <b>.code <b>.any))
- name (: (Parser Name)
- (<>.and <b>.text <b>.text))
- alias (: (Parser Alias)
- (<>.and <b>.text <b>.text))
- global (: (Parser Global)
- (<b>.or alias
- definition))
- tag (: (Parser [Nat (List Name) Bit Type])
- ($_ <>.and
- <b>.nat
- (<b>.list name)
- <b>.bit
- <b>.type))
- type (: (Parser [(List Name) Bit Type])
- ($_ <>.and
- (<b>.list name)
- <b>.bit
- <b>.type))]
- ($_ <>.and
- ## #module_hash
- <b>.nat
- ## #module_aliases
- (<b>.list alias)
- ## #definitions
- (<b>.list (<>.and <b>.text global))
- ## #imports
- (<b>.list <b>.text)
- ## #tags
- (<b>.list (<>.and <b>.text tag))
- ## #types
- (<b>.list (<>.and <b>.text type))
- ## #module_annotations
- (<b>.maybe <b>.code)
- ## #module_state
- (\ <>.monad wrap #.Cached))))
-
-(def: #export key
- (Key .Module)
- (key.key {#signature.name (name_of ..compiler)
- #signature.version /version.version}
- (module.new 0)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux
deleted file mode 100644
index bbbe43b27..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux
+++ /dev/null
@@ -1,555 +0,0 @@
-(.module:
- [lux (#- nat int rev)
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]
- [monad (#+ do)]]
- [control
- ["." function]
- ["." try]
- ["." exception (#+ Exception)]]
- [data
- ["." product]
- ["." maybe]
- ["." bit ("#\." equivalence)]
- ["." text ("#\." equivalence)
- ["%" format (#+ Format format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [math
- [number
- ["n" nat]
- ["i" int]
- ["r" rev]
- ["f" frac]]]
- [meta
- ["." location]]]
- [//
- [phase
- ["." extension (#+ Extension)]]
- [///
- [arity (#+ Arity)]
- [version (#+ Version)]
- ["." phase]
- ["." reference (#+ Reference)
- ["." variable (#+ Register Variable)]]]])
-
-(type: #export #rec Primitive
- #Unit
- (#Bit Bit)
- (#Nat Nat)
- (#Int Int)
- (#Rev Rev)
- (#Frac Frac)
- (#Text Text))
-
-(type: #export Tag
- Nat)
-
-(type: #export (Variant a)
- {#lefts Nat
- #right? Bit
- #value a})
-
-(def: #export (tag lefts right?)
- (-> Nat Bit Nat)
- (if right?
- (inc lefts)
- lefts))
-
-(def: (lefts tag right?)
- (-> Nat Bit Nat)
- (if right?
- (dec tag)
- tag))
-
-(def: #export (choice options pick)
- (-> Nat Nat [Nat Bit])
- (let [right? (n.= (dec options) pick)]
- [(..lefts pick right?)
- right?]))
-
-(type: #export (Tuple a)
- (List a))
-
-(type: #export (Composite a)
- (#Variant (Variant a))
- (#Tuple (Tuple a)))
-
-(type: #export #rec Pattern
- (#Simple Primitive)
- (#Complex (Composite Pattern))
- (#Bind Register))
-
-(type: #export (Branch' e)
- {#when Pattern
- #then e})
-
-(type: #export (Match' e)
- [(Branch' e) (List (Branch' e))])
-
-(type: #export (Environment a)
- (List a))
-
-(type: #export #rec Analysis
- (#Primitive Primitive)
- (#Structure (Composite Analysis))
- (#Reference Reference)
- (#Case Analysis (Match' Analysis))
- (#Function (Environment Analysis) Analysis)
- (#Apply Analysis Analysis)
- (#Extension (Extension Analysis)))
-
-(type: #export Branch
- (Branch' Analysis))
-
-(type: #export Match
- (Match' Analysis))
-
-(implementation: primitive_equivalence
- (Equivalence Primitive)
-
- (def: (= reference sample)
- (case [reference sample]
- [#Unit #Unit]
- true
-
- (^template [<tag> <=>]
- [[(<tag> reference) (<tag> sample)]
- (<=> reference sample)])
- ([#Bit bit\=]
- [#Nat n.=]
- [#Int i.=]
- [#Rev r.=]
- [#Frac f.=]
- [#Text text\=])
-
- _
- false)))
-
-(implementation: #export (composite_equivalence (^open "/\."))
- (All [a] (-> (Equivalence a) (Equivalence (Composite a))))
-
- (def: (= reference sample)
- (case [reference sample]
- [(#Variant [reference_lefts reference_right? reference_value])
- (#Variant [sample_lefts sample_right? sample_value])]
- (and (n.= reference_lefts sample_lefts)
- (bit\= reference_right? sample_right?)
- (/\= reference_value sample_value))
-
- [(#Tuple reference) (#Tuple sample)]
- (\ (list.equivalence /\=) = reference sample)
-
- _
- false)))
-
-(implementation: #export (composite_hash super)
- (All [a] (-> (Hash a) (Hash (Composite a))))
-
- (def: &equivalence
- (..composite_equivalence (\ super &equivalence)))
-
- (def: (hash value)
- (case value
- (#Variant [lefts right? value])
- ($_ n.* 2
- (\ n.hash hash lefts)
- (\ bit.hash hash right?)
- (\ super hash value))
-
- (#Tuple members)
- ($_ n.* 3
- (\ (list.hash super) hash members))
- )))
-
-(implementation: pattern_equivalence
- (Equivalence Pattern)
-
- (def: (= reference sample)
- (case [reference sample]
- [(#Simple reference) (#Simple sample)]
- (\ primitive_equivalence = reference sample)
-
- [(#Complex reference) (#Complex sample)]
- (\ (composite_equivalence =) = reference sample)
-
- [(#Bind reference) (#Bind sample)]
- (n.= reference sample)
-
- _
- false)))
-
-(implementation: (branch_equivalence equivalence)
- (-> (Equivalence Analysis) (Equivalence Branch))
-
- (def: (= [reference_pattern reference_body] [sample_pattern sample_body])
- (and (\ pattern_equivalence = reference_pattern sample_pattern)
- (\ equivalence = reference_body sample_body))))
-
-(implementation: #export equivalence
- (Equivalence Analysis)
-
- (def: (= reference sample)
- (case [reference sample]
- [(#Primitive reference) (#Primitive sample)]
- (\ primitive_equivalence = reference sample)
-
- [(#Structure reference) (#Structure sample)]
- (\ (composite_equivalence =) = reference sample)
-
- [(#Reference reference) (#Reference sample)]
- (\ reference.equivalence = reference sample)
-
- [(#Case [reference_analysis reference_match])
- (#Case [sample_analysis sample_match])]
- (and (= reference_analysis sample_analysis)
- (\ (list.equivalence (branch_equivalence =)) = (#.Cons reference_match) (#.Cons sample_match)))
-
- [(#Function [reference_environment reference_analysis])
- (#Function [sample_environment sample_analysis])]
- (and (= reference_analysis sample_analysis)
- (\ (list.equivalence =) = reference_environment sample_environment))
-
- [(#Apply [reference_input reference_abstraction])
- (#Apply [sample_input sample_abstraction])]
- (and (= reference_input sample_input)
- (= reference_abstraction sample_abstraction))
-
- [(#Extension reference) (#Extension sample)]
- (\ (extension.equivalence =) = reference sample)
-
- _
- false)))
-
-(template [<name> <tag>]
- [(template: #export (<name> content)
- (<tag> content))]
-
- [control/case #..Case]
- )
-
-(template: #export (unit)
- (#..Primitive #..Unit))
-
-(template [<name> <tag>]
- [(template: #export (<name> value)
- (#..Primitive (<tag> value)))]
-
- [bit #..Bit]
- [nat #..Nat]
- [int #..Int]
- [rev #..Rev]
- [frac #..Frac]
- [text #..Text]
- )
-
-(type: #export (Abstraction c)
- [(Environment c) Arity c])
-
-(type: #export (Application c)
- [c (List c)])
-
-(def: (last? size tag)
- (-> Nat Tag Bit)
- (n.= (dec size) tag))
-
-(template: #export (no_op value)
- (|> 1 #variable.Local #reference.Variable #..Reference
- (#..Function (list))
- (#..Apply value)))
-
-(def: #export (apply [abstraction inputs])
- (-> (Application Analysis) Analysis)
- (list\fold (function (_ input abstraction')
- (#Apply input abstraction'))
- abstraction
- inputs))
-
-(def: #export (application analysis)
- (-> Analysis (Application Analysis))
- (loop [abstraction analysis
- inputs (list)]
- (case abstraction
- (#Apply input next)
- (recur next (#.Cons input inputs))
-
- _
- [abstraction inputs])))
-
-(template [<name> <tag>]
- [(template: #export (<name> content)
- (.<| #..Reference
- <tag>
- content))]
-
- [variable #reference.Variable]
- [constant #reference.Constant]
-
- [variable/local reference.local]
- [variable/foreign reference.foreign]
- )
-
-(template [<name> <tag>]
- [(template: #export (<name> content)
- (.<| #..Complex
- <tag>
- content))]
-
- [pattern/variant #..Variant]
- [pattern/tuple #..Tuple]
- )
-
-(template [<name> <tag>]
- [(template: #export (<name> content)
- (.<| #..Structure
- <tag>
- content))]
-
- [variant #..Variant]
- [tuple #..Tuple]
- )
-
-(template: #export (pattern/unit)
- (#..Simple #..Unit))
-
-(template [<name> <tag>]
- [(template: #export (<name> content)
- (#..Simple (<tag> content)))]
-
- [pattern/bit #..Bit]
- [pattern/nat #..Nat]
- [pattern/int #..Int]
- [pattern/rev #..Rev]
- [pattern/frac #..Frac]
- [pattern/text #..Text]
- )
-
-(template: #export (pattern/bind register)
- (#..Bind register))
-
-(def: #export (%analysis analysis)
- (Format Analysis)
- (case analysis
- (#Primitive primitive)
- (case primitive
- #Unit
- "[]"
-
- (^template [<tag> <format>]
- [(<tag> value)
- (<format> value)])
- ([#Bit %.bit]
- [#Nat %.nat]
- [#Int %.int]
- [#Rev %.rev]
- [#Frac %.frac]
- [#Text %.text]))
-
- (#Structure structure)
- (case structure
- (#Variant [lefts right? value])
- (format "(" (%.nat lefts) " " (%.bit right?) " " (%analysis value) ")")
-
- (#Tuple members)
- (|> members
- (list\map %analysis)
- (text.join_with " ")
- (text.enclose ["[" "]"])))
-
- (#Reference reference)
- (reference.format reference)
-
- (#Case analysis match)
- "{?}"
-
- (#Function environment body)
- (|> (%analysis body)
- (format " ")
- (format (|> environment
- (list\map %analysis)
- (text.join_with " ")
- (text.enclose ["[" "]"])))
- (text.enclose ["(" ")"]))
-
- (#Apply _)
- (|> analysis
- ..application
- #.Cons
- (list\map %analysis)
- (text.join_with " ")
- (text.enclose ["(" ")"]))
-
- (#Extension name parameters)
- (|> parameters
- (list\map %analysis)
- (text.join_with " ")
- (format (%.text name) " ")
- (text.enclose ["(" ")"]))))
-
-(template [<special> <general>]
- [(type: #export <special>
- (<general> .Lux Code Analysis))]
-
- [State+ extension.State]
- [Operation extension.Operation]
- [Phase extension.Phase]
- [Handler extension.Handler]
- [Bundle extension.Bundle]
- )
-
-(def: #export (with_source_code source action)
- (All [a] (-> Source (Operation a) (Operation a)))
- (function (_ [bundle state])
- (let [old_source (get@ #.source state)]
- (case (action [bundle (set@ #.source source state)])
- (#try.Success [[bundle' state'] output])
- (#try.Success [[bundle' (set@ #.source old_source state')]
- output])
-
- (#try.Failure error)
- (#try.Failure error)))))
-
-(def: fresh_bindings
- (All [k v] (Bindings k v))
- {#.counter 0
- #.mappings (list)})
-
-(def: fresh_scope
- Scope
- {#.name (list)
- #.inner 0
- #.locals fresh_bindings
- #.captured fresh_bindings})
-
-(def: #export (with_scope action)
- (All [a] (-> (Operation a) (Operation [Scope a])))
- (function (_ [bundle state])
- (case (action [bundle (update@ #.scopes (|>> (#.Cons fresh_scope)) state)])
- (#try.Success [[bundle' state'] output])
- (case (get@ #.scopes state')
- (#.Cons head tail)
- (#try.Success [[bundle' (set@ #.scopes tail state')]
- [head output]])
-
- #.Nil
- (#try.Failure "Impossible error: Drained scopes!"))
-
- (#try.Failure error)
- (#try.Failure error))))
-
-(def: #export (with_current_module name)
- (All [a] (-> Text (Operation a) (Operation a)))
- (extension.localized (get@ #.current_module)
- (set@ #.current_module)
- (function.constant (#.Some name))))
-
-(def: #export (with_location location action)
- (All [a] (-> Location (Operation a) (Operation a)))
- (if (text\= "" (product.left location))
- action
- (function (_ [bundle state])
- (let [old_location (get@ #.location state)]
- (case (action [bundle (set@ #.location location state)])
- (#try.Success [[bundle' state'] output])
- (#try.Success [[bundle' (set@ #.location old_location state')]
- output])
-
- (#try.Failure error)
- (#try.Failure error))))))
-
-(def: (locate_error location error)
- (-> Location Text Text)
- (format (%.location location) text.new_line
- error))
-
-(def: #export (fail error)
- (-> Text Operation)
- (function (_ [bundle state])
- (#try.Failure (locate_error (get@ #.location state) error))))
-
-(def: #export (throw exception parameters)
- (All [e] (-> (Exception e) e Operation))
- (..fail (exception.construct exception parameters)))
-
-(def: #export (assert exception parameters condition)
- (All [e] (-> (Exception e) e Bit (Operation Any)))
- (if condition
- (\ phase.monad wrap [])
- (..throw exception parameters)))
-
-(def: #export (fail' error)
- (-> Text (phase.Operation Lux))
- (function (_ state)
- (#try.Failure (locate_error (get@ #.location state) error))))
-
-(def: #export (throw' exception parameters)
- (All [e] (-> (Exception e) e (phase.Operation Lux)))
- (..fail' (exception.construct exception parameters)))
-
-(def: #export (with_stack exception message action)
- (All [e o] (-> (Exception e) e (Operation o) (Operation o)))
- (function (_ bundle,state)
- (case (exception.with exception message
- (action bundle,state))
- (#try.Success output)
- (#try.Success output)
-
- (#try.Failure error)
- (let [[bundle state] bundle,state]
- (#try.Failure (locate_error (get@ #.location state) error))))))
-
-(def: #export (install state)
- (-> .Lux (Operation Any))
- (function (_ [bundle _])
- (#try.Success [[bundle state]
- []])))
-
-(template [<name> <type> <field> <value>]
- [(def: #export (<name> value)
- (-> <type> (Operation Any))
- (extension.update (set@ <field> <value>)))]
-
- [set_source_code Source #.source value]
- [set_current_module Text #.current_module (#.Some value)]
- [set_location Location #.location value]
- )
-
-(def: #export (location file)
- (-> Text Location)
- [file 1 0])
-
-(def: #export (source file code)
- (-> Text Text Source)
- [(location file) 0 code])
-
-(def: dummy_source
- Source
- [location.dummy 0 ""])
-
-(def: type_context
- Type_Context
- {#.ex_counter 0
- #.var_counter 0
- #.var_bindings (list)})
-
-(def: #export (info version host)
- (-> Version Text Info)
- {#.target host
- #.version (%.nat version)
- #.mode #.Build})
-
-(def: #export (state info)
- (-> Info Lux)
- {#.info info
- #.source ..dummy_source
- #.location location.dummy
- #.current_module #.None
- #.modules (list)
- #.scopes (list)
- #.type_context ..type_context
- #.expected #.None
- #.seed 0
- #.scope_type_vars (list)
- #.extensions []
- #.host []})
diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux
deleted file mode 100644
index 521c88a23..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux
+++ /dev/null
@@ -1,56 +0,0 @@
-(.module:
- [lux (#- Module)
- ["." meta]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]]
- [math
- [number
- ["n" nat]]]]
- [// (#+ Operation)
- [macro (#+ Expander)]
- [//
- [phase
- [".P" extension]
- [".P" synthesis]
- [".P" analysis
- ["." type]]
- [//
- ["." synthesis]
- ["." generation (#+ Context)]
- [///
- ["." phase]
- [meta
- [archive (#+ Archive)
- [descriptor (#+ Module)]]]]]]]])
-
-(type: #export Eval
- (-> Archive Nat Type Code (Operation Any)))
-
-(def: (context [module_id artifact_id])
- (-> Context Context)
- ## TODO: Find a better way that doesn't rely on clever tricks.
- [(n.- module_id 0) artifact_id])
-
-(def: #export (evaluator expander synthesis_state generation_state generate)
- (All [anchor expression artifact]
- (-> Expander
- synthesis.State+
- (generation.State+ anchor expression artifact)
- (generation.Phase anchor expression artifact)
- Eval))
- (let [analyze (analysisP.phase expander)]
- (function (eval archive count type exprC)
- (do phase.monad
- [exprA (type.with_type type
- (analyze archive exprC))
- module (extensionP.lift
- meta.current_module_name)]
- (phase.lift (do try.monad
- [exprS (|> exprA (synthesisP.phase archive) (phase.run synthesis_state))]
- (phase.run generation_state
- (do phase.monad
- [exprO (generate archive exprS)
- module_id (generation.module_id module archive)]
- (generation.evaluate! (..context [module_id count]) exprO)))))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis/macro.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis/macro.lux
deleted file mode 100644
index 9a84c0259..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/analysis/macro.lux
+++ /dev/null
@@ -1,51 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." text
- ["%" format (#+ format)]]]
- ["." meta]]
- [/////
- ["." phase]])
-
-(exception: #export (expansion_failed {macro Name} {inputs (List Code)} {error Text})
- (exception.report
- ["Macro" (%.name macro)]
- ["Inputs" (exception.enumerate %.code inputs)]
- ["Error" error]))
-
-(exception: #export (must_have_single_expansion {macro Name} {inputs (List Code)} {outputs (List Code)})
- (exception.report
- ["Macro" (%.name macro)]
- ["Inputs" (exception.enumerate %.code inputs)]
- ["Outputs" (exception.enumerate %.code outputs)]))
-
-(type: #export Expander
- (-> Macro (List Code) Lux (Try (Try [Lux (List Code)]))))
-
-(def: #export (expand expander name macro inputs)
- (-> Expander Name Macro (List Code) (Meta (List Code)))
- (function (_ state)
- (do try.monad
- [output (expander macro inputs state)]
- (case output
- (#try.Success output)
- (#try.Success output)
-
- (#try.Failure error)
- ((meta.fail (exception.construct ..expansion_failed [name inputs error])) state)))))
-
-(def: #export (expand_one expander name macro inputs)
- (-> Expander Name Macro (List Code) (Meta Code))
- (do meta.monad
- [expansion (expand expander name macro inputs)]
- (case expansion
- (^ (list single))
- (wrap single)
-
- _
- (meta.fail (exception.construct ..must_have_single_expansion [name inputs expansion])))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/directive.lux b/stdlib/source/lux/tool/compiler/language/lux/directive.lux
deleted file mode 100644
index 896a9a1cb..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/directive.lux
+++ /dev/null
@@ -1,82 +0,0 @@
-(.module:
- [lux (#- Module)
- [abstract
- [monad (#+ do)]]
- [data
- [collection
- ["." list ("#\." monoid)]]]]
- [//
- ["." analysis]
- ["." synthesis]
- ["." generation]
- [phase
- ["." extension]]
- [///
- ["." phase]
- [meta
- [archive
- [descriptor (#+ Module)]]]]])
-
-(type: #export (Component state phase)
- {#state state
- #phase phase})
-
-(type: #export (State anchor expression directive)
- {#analysis (Component analysis.State+
- analysis.Phase)
- #synthesis (Component synthesis.State+
- synthesis.Phase)
- #generation (Component (generation.State+ anchor expression directive)
- (generation.Phase anchor expression directive))})
-
-(type: #export Import
- {#module Module
- #alias Text})
-
-(type: #export Requirements
- {#imports (List Import)
- #referrals (List Code)})
-
-(def: #export no_requirements
- Requirements
- {#imports (list)
- #referrals (list)})
-
-(def: #export (merge_requirements left right)
- (-> Requirements Requirements Requirements)
- {#imports (list\compose (get@ #imports left) (get@ #imports right))
- #referrals (list\compose (get@ #referrals left) (get@ #referrals right))})
-
-(template [<special> <general>]
- [(type: #export (<special> anchor expression directive)
- (<general> (..State anchor expression directive) Code Requirements))]
-
- [State+ extension.State]
- [Operation extension.Operation]
- [Phase extension.Phase]
- [Handler extension.Handler]
- [Bundle extension.Bundle]
- )
-
-(template [<name> <component> <operation>]
- [(def: #export <name>
- (All [anchor expression directive output]
- (-> (<operation> output)
- (Operation anchor expression directive output)))
- (|>> (phase.sub [(get@ [<component> #..state])
- (set@ [<component> #..state])])
- extension.lift))]
-
- [lift_analysis #..analysis analysis.Operation]
- [lift_synthesis #..synthesis synthesis.Operation]
- [lift_generation #..generation (generation.Operation anchor expression directive)]
- )
-
-(def: #export (set_current_module module)
- (All [anchor expression directive]
- (-> Module (Operation anchor expression directive Any)))
- (do phase.monad
- [_ (..lift_analysis
- (analysis.set_current_module module))]
- (..lift_generation
- (generation.enter_module module))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/lux/tool/compiler/language/lux/generation.lux
deleted file mode 100644
index 372ed2c17..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/generation.lux
+++ /dev/null
@@ -1,335 +0,0 @@
-(.module:
- [lux (#- Module)
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." function]]
- [data
- [binary (#+ Binary)]
- ["." product]
- ["." name]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." row (#+ Row)]
- ["." list ("#\." functor)]]]
- [math
- [number
- ["n" nat]]]]
- [//
- [synthesis (#+ Synthesis)]
- [phase
- ["." extension]]
- [///
- ["." phase]
- [meta
- ["." archive (#+ Archive)
- ["." descriptor (#+ Module)]
- ["." artifact]]]]])
-
-(type: #export Context
- [archive.ID artifact.ID])
-
-(type: #export (Buffer directive)
- (Row [artifact.ID directive]))
-
-(exception: #export (cannot_interpret {error Text})
- (exception.report
- ["Error" error]))
-
-(template [<name>]
- [(exception: #export (<name> {artifact_id artifact.ID})
- (exception.report
- ["Artifact ID" (%.nat artifact_id)]))]
-
- [cannot_overwrite_output]
- [no_buffer_for_saving_code]
- )
-
-(interface: #export (Host expression directive)
- (: (-> Context expression (Try Any))
- evaluate!)
- (: (-> directive (Try Any))
- execute!)
- (: (-> Context expression (Try [Text Any directive]))
- define!)
-
- (: (-> Context Binary directive)
- ingest)
- (: (-> Context directive (Try Any))
- re_learn)
- (: (-> Context directive (Try Any))
- re_load))
-
-(type: #export (State anchor expression directive)
- {#module Module
- #anchor (Maybe anchor)
- #host (Host expression directive)
- #buffer (Maybe (Buffer directive))
- #registry artifact.Registry
- #counter Nat
- #context (Maybe artifact.ID)
- #log (Row Text)})
-
-(template [<special> <general>]
- [(type: #export (<special> anchor expression directive)
- (<general> (State anchor expression directive) Synthesis expression))]
-
- [State+ extension.State]
- [Operation extension.Operation]
- [Phase extension.Phase]
- [Handler extension.Handler]
- [Bundle extension.Bundle]
- [Extender extension.Extender]
- )
-
-(def: #export (state host module)
- (All [anchor expression directive]
- (-> (Host expression directive)
- Module
- (..State anchor expression directive)))
- {#module module
- #anchor #.None
- #host host
- #buffer #.None
- #registry artifact.empty
- #counter 0
- #context #.None
- #log row.empty})
-
-(def: #export empty_buffer Buffer row.empty)
-
-(template [<tag>
- <with_declaration> <with_type> <with_value>
- <set> <get> <get_type> <exception>]
- [(exception: #export <exception>)
-
- (def: #export <with_declaration>
- (All [anchor expression directive output] <with_type>)
- (function (_ body)
- (function (_ [bundle state])
- (case (body [bundle (set@ <tag> (#.Some <with_value>) state)])
- (#try.Success [[bundle' state'] output])
- (#try.Success [[bundle' (set@ <tag> (get@ <tag> state) state')]
- output])
-
- (#try.Failure error)
- (#try.Failure error)))))
-
- (def: #export <get>
- (All [anchor expression directive]
- (Operation anchor expression directive <get_type>))
- (function (_ (^@ stateE [bundle state]))
- (case (get@ <tag> state)
- (#.Some output)
- (#try.Success [stateE output])
-
- #.None
- (exception.throw <exception> []))))
-
- (def: #export (<set> value)
- (All [anchor expression directive]
- (-> <get_type> (Operation anchor expression directive Any)))
- (function (_ [bundle state])
- (#try.Success [[bundle (set@ <tag> (#.Some value) state)]
- []])))]
-
- [#anchor
- (with_anchor anchor)
- (-> anchor (Operation anchor expression directive output)
- (Operation anchor expression directive output))
- anchor
- set_anchor anchor anchor no_anchor]
-
- [#buffer
- with_buffer
- (-> (Operation anchor expression directive output)
- (Operation anchor expression directive output))
- ..empty_buffer
- set_buffer buffer (Buffer directive) no_active_buffer]
- )
-
-(def: #export get_registry
- (All [anchor expression directive]
- (Operation anchor expression directive artifact.Registry))
- (function (_ (^@ stateE [bundle state]))
- (#try.Success [stateE (get@ #registry state)])))
-
-(def: #export (set_registry value)
- (All [anchor expression directive]
- (-> artifact.Registry (Operation anchor expression directive Any)))
- (function (_ [bundle state])
- (#try.Success [[bundle (set@ #registry value state)]
- []])))
-
-(def: #export next
- (All [anchor expression directive]
- (Operation anchor expression directive Nat))
- (do phase.monad
- [count (extension.read (get@ #counter))
- _ (extension.update (update@ #counter inc))]
- (wrap count)))
-
-(def: #export (gensym prefix)
- (All [anchor expression directive]
- (-> Text (Operation anchor expression directive Text)))
- (\ phase.monad map (|>> %.nat (format prefix)) ..next))
-
-(def: #export (enter_module module)
- (All [anchor expression directive]
- (-> Module (Operation anchor expression directive Any)))
- (extension.update (set@ #module module)))
-
-(def: #export module
- (All [anchor expression directive]
- (Operation anchor expression directive Module))
- (extension.read (get@ #module)))
-
-(def: #export (evaluate! label code)
- (All [anchor expression directive]
- (-> Context expression (Operation anchor expression directive Any)))
- (function (_ (^@ state+ [bundle state]))
- (case (\ (get@ #host state) evaluate! label code)
- (#try.Success output)
- (#try.Success [state+ output])
-
- (#try.Failure error)
- (exception.throw ..cannot_interpret error))))
-
-(def: #export (execute! code)
- (All [anchor expression directive]
- (-> directive (Operation anchor expression directive Any)))
- (function (_ (^@ state+ [bundle state]))
- (case (\ (get@ #host state) execute! code)
- (#try.Success output)
- (#try.Success [state+ output])
-
- (#try.Failure error)
- (exception.throw ..cannot_interpret error))))
-
-(def: #export (define! context code)
- (All [anchor expression directive]
- (-> Context expression (Operation anchor expression directive [Text Any directive])))
- (function (_ (^@ stateE [bundle state]))
- (case (\ (get@ #host state) define! context code)
- (#try.Success output)
- (#try.Success [stateE output])
-
- (#try.Failure error)
- (exception.throw ..cannot_interpret error))))
-
-(def: #export (save! artifact_id code)
- (All [anchor expression directive]
- (-> artifact.ID directive (Operation anchor expression directive Any)))
- (do {! phase.monad}
- [?buffer (extension.read (get@ #buffer))]
- (case ?buffer
- (#.Some buffer)
- ## TODO: Optimize by no longer checking for overwrites...
- (if (row.any? (|>> product.left (n.= artifact_id)) buffer)
- (phase.throw ..cannot_overwrite_output [artifact_id])
- (extension.update (set@ #buffer (#.Some (row.add [artifact_id code] buffer)))))
-
- #.None
- (phase.throw ..no_buffer_for_saving_code [artifact_id]))))
-
-(template [<name> <artifact>]
- [(def: #export (<name> name)
- (All [anchor expression directive]
- (-> Text (Operation anchor expression directive artifact.ID)))
- (function (_ (^@ stateE [bundle state]))
- (let [[id registry'] (<artifact> name (get@ #registry state))]
- (#try.Success [[bundle (set@ #registry registry' state)]
- id]))))]
-
- [learn artifact.definition]
- [learn_analyser artifact.analyser]
- [learn_synthesizer artifact.synthesizer]
- [learn_generator artifact.generator]
- [learn_directive artifact.directive]
- )
-
-(exception: #export (unknown_definition {name Name}
- {known_definitions (List Text)})
- (exception.report
- ["Definition" (name.short name)]
- ["Module" (name.module name)]
- ["Known Definitions" (exception.enumerate function.identity known_definitions)]))
-
-(def: #export (remember archive name)
- (All [anchor expression directive]
- (-> Archive Name (Operation anchor expression directive Context)))
- (function (_ (^@ stateE [bundle state]))
- (let [[_module _name] name]
- (do try.monad
- [module_id (archive.id _module archive)
- registry (if (text\= (get@ #module state) _module)
- (#try.Success (get@ #registry state))
- (do try.monad
- [[descriptor document] (archive.find _module archive)]
- (#try.Success (get@ #descriptor.registry descriptor))))]
- (case (artifact.remember _name registry)
- #.None
- (exception.throw ..unknown_definition [name (artifact.definitions registry)])
-
- (#.Some id)
- (#try.Success [stateE [module_id id]]))))))
-
-(exception: #export no_context)
-
-(def: #export (module_id module archive)
- (All [anchor expression directive]
- (-> Module Archive (Operation anchor expression directive archive.ID)))
- (function (_ (^@ stateE [bundle state]))
- (do try.monad
- [module_id (archive.id module archive)]
- (wrap [stateE module_id]))))
-
-(def: #export (context archive)
- (All [anchor expression directive]
- (-> Archive (Operation anchor expression directive Context)))
- (function (_ (^@ stateE [bundle state]))
- (case (get@ #context state)
- #.None
- (exception.throw ..no_context [])
-
- (#.Some id)
- (do try.monad
- [module_id (archive.id (get@ #module state) archive)]
- (wrap [stateE [module_id id]])))))
-
-(def: #export (with_context id body)
- (All [anchor expression directive a]
- (-> artifact.ID
- (Operation anchor expression directive a)
- (Operation anchor expression directive a)))
- (function (_ [bundle state])
- (do try.monad
- [[[bundle' state'] output] (body [bundle (set@ #context (#.Some id) state)])]
- (wrap [[bundle' (set@ #context (get@ #context state) state')]
- output]))))
-
-(def: #export (with_new_context archive body)
- (All [anchor expression directive a]
- (-> Archive (Operation anchor expression directive a)
- (Operation anchor expression directive [Context a])))
- (function (_ (^@ stateE [bundle state]))
- (let [[id registry'] (artifact.resource (get@ #registry state))]
- (do try.monad
- [[[bundle' state'] output] (body [bundle (|> state
- (set@ #registry registry')
- (set@ #context (#.Some id)))])
- module_id (archive.id (get@ #module state) archive)]
- (wrap [[bundle' (set@ #context (get@ #context state) state')]
- [[module_id id]
- output]])))))
-
-(def: #export (log! message)
- (All [anchor expression directive a]
- (-> Text (Operation anchor expression directive Any)))
- (function (_ [bundle state])
- (#try.Success [[bundle
- (update@ #log (row.add message) state)]
- []])))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux
deleted file mode 100644
index 9e0748422..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux
+++ /dev/null
@@ -1,143 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." exception (#+ exception:)]]
- [data
- [text
- ["%" format (#+ format)]]]
- ["." meta
- ["." location]]]
- ["." / #_
- ["#." type]
- ["#." primitive]
- ["#." structure]
- ["#." reference]
- ["#." case]
- ["#." function]
- ["/#" // #_
- ["#." extension]
- ["/#" // #_
- ["/" analysis (#+ Analysis Operation Phase)
- ["#." macro (#+ Expander)]]
- [///
- ["//" phase]
- ["." reference]
- [meta
- [archive (#+ Archive)]]]]]])
-
-(exception: #export (unrecognized_syntax {code Code})
- (exception.report ["Code" (%.code code)]))
-
-## TODO: Had to split the 'compile' function due to compilation issues
-## with old-luxc. Must re-combine all the code ASAP
-
-(type: (Fix a)
- (-> a a))
-
-(def: (compile|primitive else code')
- (Fix (-> (Code' (Ann Location)) (Operation Analysis)))
- (case code'
- (^template [<tag> <analyser>]
- [(<tag> value)
- (<analyser> value)])
- ([#.Bit /primitive.bit]
- [#.Nat /primitive.nat]
- [#.Int /primitive.int]
- [#.Rev /primitive.rev]
- [#.Frac /primitive.frac]
- [#.Text /primitive.text])
-
- _
- (else code')))
-
-(def: (compile|structure archive compile else code')
- (-> Archive Phase (Fix (-> (Code' (Ann Location)) (Operation Analysis))))
- (case code'
- (^ (#.Form (list& [_ (#.Tag tag)]
- values)))
- (case values
- (#.Cons value #.Nil)
- (/structure.tagged_sum compile tag archive value)
-
- _
- (/structure.tagged_sum compile tag archive (` [(~+ values)])))
-
- (^ (#.Form (list& [_ (#.Nat lefts)] [_ (#.Bit right?)]
- values)))
- (case values
- (#.Cons value #.Nil)
- (/structure.sum compile lefts right? archive value)
-
- _
- (/structure.sum compile lefts right? archive (` [(~+ values)])))
-
- (#.Tag tag)
- (/structure.tagged_sum compile tag archive (' []))
-
- (^ (#.Tuple (list)))
- /primitive.unit
-
- (^ (#.Tuple (list singleton)))
- (compile archive singleton)
-
- (^ (#.Tuple elems))
- (/structure.product archive compile elems)
-
- (^ (#.Record pairs))
- (/structure.record archive compile pairs)
-
- _
- (else code')))
-
-(def: (compile|others expander archive compile code')
- (-> Expander Archive Phase (-> (Code' (Ann Location)) (Operation Analysis)))
- (case code'
- (#.Identifier reference)
- (/reference.reference reference)
-
- (^ (#.Form (list [_ (#.Record branches)] input)))
- (/case.case compile branches archive input)
-
- (^ (#.Form (list& [_ (#.Text extension_name)] extension_args)))
- (//extension.apply archive compile [extension_name extension_args])
-
- (^ (#.Form (list [_ (#.Tuple (list [_ (#.Identifier ["" function_name])]
- [_ (#.Identifier ["" arg_name])]))]
- body)))
- (/function.function compile function_name arg_name archive body)
-
- (^ (#.Form (list& functionC argsC+)))
- (do {! //.monad}
- [[functionT functionA] (/type.with_inference
- (compile archive functionC))]
- (case functionA
- (#/.Reference (#reference.Constant def_name))
- (do !
- [?macro (//extension.lift (meta.find_macro def_name))]
- (case ?macro
- (#.Some macro)
- (do !
- [expansion (//extension.lift (/macro.expand_one expander def_name macro argsC+))]
- (compile archive expansion))
-
- _
- (/function.apply compile argsC+ functionT functionA archive functionC)))
-
- _
- (/function.apply compile argsC+ functionT functionA archive functionC)))
-
- _
- (//.throw ..unrecognized_syntax [location.dummy code'])))
-
-(def: #export (phase expander)
- (-> Expander Phase)
- (function (compile archive code)
- (let [[location code'] code]
- ## The location must be set in the state for the sake
- ## of having useful error messages.
- (/.with_location location
- (compile|primitive (compile|structure archive compile
- (compile|others expander archive compile))
- code')))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux
deleted file mode 100644
index 41fad7934..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux
+++ /dev/null
@@ -1,324 +0,0 @@
-(.module:
- [lux (#- case)
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try]
- ["." exception (#+ exception:)]]
- [data
- ["." product]
- ["." maybe]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." fold monoid functor)]]]
- [math
- [number
- ["n" nat]]]
- [macro
- ["." code]]
- ["." type
- ["." check]]]
- ["." / #_
- ["#." coverage (#+ Coverage)]
- ["/#" // #_
- ["#." scope]
- ["#." type]
- ["#." structure]
- ["/#" // #_
- ["#." extension]
- [//
- ["/" analysis (#+ Pattern Analysis Operation Phase)]
- [///
- ["#" phase]]]]]])
-
-(exception: #export (cannot_match_with_pattern {type Type} {pattern Code})
- (exception.report
- ["Type" (%.type type)]
- ["Pattern" (%.code pattern)]))
-
-(exception: #export (sum_has_no_case {case Nat} {type Type})
- (exception.report
- ["Case" (%.nat case)]
- ["Type" (%.type type)]))
-
-(exception: #export (not_a_pattern {code Code})
- (exception.report ["Code" (%.code code)]))
-
-(exception: #export (cannot_simplify_for_pattern_matching {type Type})
- (exception.report ["Type" (%.type type)]))
-
-(exception: #export (non_exhaustive_pattern_matching {input Code} {branches (List [Code Code])} {coverage Coverage})
- (exception.report
- ["Input" (%.code input)]
- ["Branches" (%.code (code.record branches))]
- ["Coverage" (/coverage.%coverage coverage)]))
-
-(exception: #export (cannot_have_empty_branches {message Text})
- message)
-
-(def: (re_quantify envs baseT)
- (-> (List (List Type)) Type Type)
- (.case envs
- #.Nil
- baseT
-
- (#.Cons head tail)
- (re_quantify tail (#.UnivQ head baseT))))
-
-## Type-checking on the input value is done during the analysis of a
-## "case" expression, to ensure that the patterns being used make
-## sense for the type of the input value.
-## Sometimes, that input value is complex, by depending on
-## type-variables or quantifications.
-## This function makes it easier for "case" analysis to properly
-## type-check the input with respect to the patterns.
-(def: (simplify_case caseT)
- (-> Type (Operation Type))
- (loop [envs (: (List (List Type))
- (list))
- caseT caseT]
- (.case caseT
- (#.Var id)
- (do ///.monad
- [?caseT' (//type.with_env
- (check.read id))]
- (.case ?caseT'
- (#.Some caseT')
- (recur envs caseT')
-
- _
- (/.throw ..cannot_simplify_for_pattern_matching caseT)))
-
- (#.Named name unnamedT)
- (recur envs unnamedT)
-
- (#.UnivQ env unquantifiedT)
- (recur (#.Cons env envs) unquantifiedT)
-
- (#.ExQ _)
- (do ///.monad
- [[var_id varT] (//type.with_env
- check.var)]
- (recur envs (maybe.assume (type.apply (list varT) caseT))))
-
- (#.Apply inputT funcT)
- (.case funcT
- (#.Var funcT_id)
- (do ///.monad
- [funcT' (//type.with_env
- (do check.monad
- [?funct' (check.read funcT_id)]
- (.case ?funct'
- (#.Some funct')
- (wrap funct')
-
- _
- (check.throw ..cannot_simplify_for_pattern_matching caseT))))]
- (recur envs (#.Apply inputT funcT')))
-
- _
- (.case (type.apply (list inputT) funcT)
- (#.Some outputT)
- (recur envs outputT)
-
- #.None
- (/.throw ..cannot_simplify_for_pattern_matching caseT)))
-
- (#.Product _)
- (|> caseT
- type.flatten_tuple
- (list\map (re_quantify envs))
- type.tuple
- (\ ///.monad wrap))
-
- _
- (\ ///.monad wrap (re_quantify envs caseT)))))
-
-(def: (analyse_primitive type inputT location output next)
- (All [a] (-> Type Type Location Pattern (Operation a) (Operation [Pattern a])))
- (/.with_location location
- (do ///.monad
- [_ (//type.with_env
- (check.check inputT type))
- outputA next]
- (wrap [output outputA]))))
-
-## This function handles several concerns at once, but it must be that
-## way because those concerns are interleaved when doing
-## pattern-matching and they cannot be separated.
-## The pattern is analysed in order to get a general feel for what is
-## expected of the input value. This, in turn, informs the
-## type-checking of the input.
-## A kind of "continuation" value is passed around which signifies
-## what needs to be done _after_ analysing a pattern.
-## In general, this is done to analyse the "body" expression
-## associated to a particular pattern _in the context of_ said
-## pattern.
-## The reason why *context* is important is because patterns may bind
-## values to local variables, which may in turn be referenced in the
-## body expressions.
-## That is why the body must be analysed in the context of the
-## pattern, and not separately.
-(def: (analyse_pattern num_tags inputT pattern next)
- (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a])))
- (.case pattern
- [location (#.Identifier ["" name])]
- (/.with_location location
- (do ///.monad
- [outputA (//scope.with_local [name inputT]
- next)
- idx //scope.next_local]
- (wrap [(#/.Bind idx) outputA])))
-
- (^template [<type> <input> <output>]
- [[location <input>]
- (analyse_primitive <type> inputT location (#/.Simple <output>) next)])
- ([Bit (#.Bit pattern_value) (#/.Bit pattern_value)]
- [Nat (#.Nat pattern_value) (#/.Nat pattern_value)]
- [Int (#.Int pattern_value) (#/.Int pattern_value)]
- [Rev (#.Rev pattern_value) (#/.Rev pattern_value)]
- [Frac (#.Frac pattern_value) (#/.Frac pattern_value)]
- [Text (#.Text pattern_value) (#/.Text pattern_value)]
- [Any (#.Tuple #.Nil) #/.Unit])
-
- (^ [location (#.Tuple (list singleton))])
- (analyse_pattern #.None inputT singleton next)
-
- [location (#.Tuple sub_patterns)]
- (/.with_location location
- (do {! ///.monad}
- [inputT' (simplify_case inputT)]
- (.case inputT'
- (#.Product _)
- (let [subs (type.flatten_tuple inputT')
- num_subs (maybe.default (list.size subs)
- num_tags)
- num_sub_patterns (list.size sub_patterns)
- matches (cond (n.< num_subs num_sub_patterns)
- (let [[prefix suffix] (list.split (dec num_sub_patterns) subs)]
- (list.zip/2 (list\compose prefix (list (type.tuple suffix))) sub_patterns))
-
- (n.> num_subs num_sub_patterns)
- (let [[prefix suffix] (list.split (dec num_subs) sub_patterns)]
- (list.zip/2 subs (list\compose prefix (list (code.tuple suffix)))))
-
- ## (n.= num_subs num_sub_patterns)
- (list.zip/2 subs sub_patterns))]
- (do !
- [[memberP+ thenA] (list\fold (: (All [a]
- (-> [Type Code] (Operation [(List Pattern) a])
- (Operation [(List Pattern) a])))
- (function (_ [memberT memberC] then)
- (do !
- [[memberP [memberP+ thenA]] ((:as (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a])))
- analyse_pattern)
- #.None memberT memberC then)]
- (wrap [(list& memberP memberP+) thenA]))))
- (do !
- [nextA next]
- (wrap [(list) nextA]))
- (list.reverse matches))]
- (wrap [(/.pattern/tuple memberP+)
- thenA])))
-
- _
- (/.throw ..cannot_match_with_pattern [inputT' pattern])
- )))
-
- [location (#.Record record)]
- (do ///.monad
- [record (//structure.normalize record)
- [members recordT] (//structure.order record)
- _ (.case inputT
- (#.Var _id)
- (//type.with_env
- (check.check inputT recordT))
-
- _
- (wrap []))]
- (analyse_pattern (#.Some (list.size members)) inputT [location (#.Tuple members)] next))
-
- [location (#.Tag tag)]
- (/.with_location location
- (analyse_pattern #.None inputT (` ((~ pattern))) next))
-
- (^ [location (#.Form (list& [_ (#.Nat lefts)] [_ (#.Bit right?)] values))])
- (/.with_location location
- (do ///.monad
- [inputT' (simplify_case inputT)]
- (.case inputT'
- (#.Sum _)
- (let [flat_sum (type.flatten_variant inputT')
- size_sum (list.size flat_sum)
- num_cases (maybe.default size_sum num_tags)
- idx (/.tag lefts right?)]
- (.case (list.nth idx flat_sum)
- (^multi (#.Some caseT)
- (n.< num_cases idx))
- (do ///.monad
- [[testP nextA] (if (and (n.> num_cases size_sum)
- (n.= (dec num_cases) idx))
- (analyse_pattern #.None
- (type.variant (list.drop (dec num_cases) flat_sum))
- (` [(~+ values)])
- next)
- (analyse_pattern #.None caseT (` [(~+ values)]) next))]
- (wrap [(/.pattern/variant [lefts right? testP])
- nextA]))
-
- _
- (/.throw ..sum_has_no_case [idx inputT])))
-
- (#.UnivQ _)
- (do ///.monad
- [[ex_id exT] (//type.with_env
- check.existential)]
- (analyse_pattern num_tags
- (maybe.assume (type.apply (list exT) inputT'))
- pattern
- next))
-
- _
- (/.throw ..cannot_match_with_pattern [inputT' pattern]))))
-
- (^ [location (#.Form (list& [_ (#.Tag tag)] values))])
- (/.with_location location
- (do ///.monad
- [tag (///extension.lift (meta.normalize tag))
- [idx group variantT] (///extension.lift (meta.resolve_tag tag))
- _ (//type.with_env
- (check.check inputT variantT))
- #let [[lefts right?] (/.choice (list.size group) idx)]]
- (analyse_pattern (#.Some (list.size group)) inputT (` ((~ (code.nat lefts)) (~ (code.bit right?)) (~+ values))) next)))
-
- _
- (/.throw ..not_a_pattern pattern)
- ))
-
-(def: #export (case analyse branches archive inputC)
- (-> Phase (List [Code Code]) Phase)
- (.case branches
- (#.Cons [patternH bodyH] branchesT)
- (do {! ///.monad}
- [[inputT inputA] (//type.with_inference
- (analyse archive inputC))
- outputH (analyse_pattern #.None inputT patternH (analyse archive bodyH))
- outputT (monad.map !
- (function (_ [patternT bodyT])
- (analyse_pattern #.None inputT patternT (analyse archive bodyT)))
- branchesT)
- outputHC (|> outputH product.left /coverage.determine)
- outputTC (monad.map ! (|>> product.left /coverage.determine) outputT)
- _ (.case (monad.fold try.monad /coverage.merge outputHC outputTC)
- (#try.Success coverage)
- (///.assert non_exhaustive_pattern_matching [inputC branches coverage]
- (/coverage.exhaustive? coverage))
-
- (#try.Failure error)
- (/.fail error))]
- (wrap (#/.Case inputA [outputH outputT])))
-
- #.Nil
- (/.throw ..cannot_have_empty_branches "")))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux
deleted file mode 100644
index 4a3afc3f5..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux
+++ /dev/null
@@ -1,372 +0,0 @@
-(.module:
- [lux #*
- [abstract
- equivalence
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try) ("#\." monad)]
- ["ex" exception (#+ exception:)]]
- [data
- ["." bit ("#\." equivalence)]
- ["." maybe]
- ["." text
- ["%" format (#+ Format format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." dictionary (#+ Dictionary)]]]
- [math
- [number
- ["n" nat]]]]
- ["." //// #_
- [//
- ["/" analysis (#+ Pattern Variant Operation)]
- [///
- ["#" phase ("#\." monad)]]]])
-
-(exception: #export (invalid_tuple_pattern)
- "Tuple size must be >= 2")
-
-(def: cases
- (-> (Maybe Nat) Nat)
- (|>> (maybe.default 0)))
-
-(def: known_cases?
- (-> Nat Bit)
- (n.> 0))
-
-## The coverage of a pattern-matching expression summarizes how well
-## all the possible values of an input are being covered by the
-## different patterns involved.
-## Ideally, the pattern-matching has "exhaustive" coverage, which just
-## means that every possible value can be matched by at least 1
-## pattern.
-## Every other coverage is considered partial, and it would be valued
-## as insuficient (since it could lead to runtime errors due to values
-## not being handled by any pattern).
-## The #Partial tag covers arbitrary partial coverages in a general
-## way, while the other tags cover more specific cases for bits
-## and variants.
-(type: #export #rec Coverage
- #Partial
- (#Bit Bit)
- (#Variant (Maybe Nat) (Dictionary Nat Coverage))
- (#Seq Coverage Coverage)
- (#Alt Coverage Coverage)
- #Exhaustive)
-
-(def: #export (exhaustive? coverage)
- (-> Coverage Bit)
- (case coverage
- (#Exhaustive _)
- #1
-
- _
- #0))
-
-(def: #export (%coverage value)
- (Format Coverage)
- (case value
- #Partial
- "#Partial"
-
- (#Bit value')
- (|> value'
- %.bit
- (text.enclose ["(#Bit " ")"]))
-
- (#Variant ?max_cases cases)
- (|> cases
- dictionary.entries
- (list\map (function (_ [idx coverage])
- (format (%.nat idx) " " (%coverage coverage))))
- (text.join_with " ")
- (text.enclose ["{" "}"])
- (format (%.nat (..cases ?max_cases)) " ")
- (text.enclose ["(#Variant " ")"]))
-
- (#Seq left right)
- (format "(#Seq " (%coverage left) " " (%coverage right) ")")
-
- (#Alt left right)
- (format "(#Alt " (%coverage left) " " (%coverage right) ")")
-
- #Exhaustive
- "#Exhaustive"))
-
-(def: #export (determine pattern)
- (-> Pattern (Operation Coverage))
- (case pattern
- (^or (#/.Simple #/.Unit)
- (#/.Bind _))
- (////\wrap #Exhaustive)
-
- ## Primitive patterns always have partial coverage because there
- ## are too many possibilities as far as values go.
- (^template [<tag>]
- [(#/.Simple (<tag> _))
- (////\wrap #Partial)])
- ([#/.Nat]
- [#/.Int]
- [#/.Rev]
- [#/.Frac]
- [#/.Text])
-
- ## Bits are the exception, since there is only "#1" and
- ## "#0", which means it is possible for bit
- ## pattern-matching to become exhaustive if complementary parts meet.
- (#/.Simple (#/.Bit value))
- (////\wrap (#Bit value))
-
- ## Tuple patterns can be exhaustive if there is exhaustiveness for all of
- ## their sub-patterns.
- (#/.Complex (#/.Tuple membersP+))
- (case (list.reverse membersP+)
- (^or #.Nil (#.Cons _ #.Nil))
- (/.throw ..invalid_tuple_pattern [])
-
- (#.Cons lastP prevsP+)
- (do ////.monad
- [lastC (determine lastP)]
- (monad.fold ////.monad
- (function (_ leftP rightC)
- (do ////.monad
- [leftC (determine leftP)]
- (case rightC
- #Exhaustive
- (wrap leftC)
-
- _
- (wrap (#Seq leftC rightC)))))
- lastC prevsP+)))
-
- ## Variant patterns can be shown to be exhaustive if all the possible
- ## cases are handled exhaustively.
- (#/.Complex (#/.Variant [lefts right? value]))
- (do ////.monad
- [value_coverage (determine value)
- #let [idx (if right?
- (inc lefts)
- lefts)]]
- (wrap (#Variant (if right?
- (#.Some idx)
- #.None)
- (|> (dictionary.new n.hash)
- (dictionary.put idx value_coverage)))))))
-
-(def: (xor left right)
- (-> Bit Bit Bit)
- (or (and left (not right))
- (and (not left) right)))
-
-## The coverage checker not only verifies that pattern-matching is
-## exhaustive, but also that there are no redundant patterns.
-## Redundant patterns will never be executed, since there will
-## always be a pattern prior to them that would match the input.
-## Because of that, the presence of redundant patterns is assumed to
-## be a bug, likely due to programmer carelessness.
-(exception: #export (redundant_pattern {so_far Coverage} {addition Coverage})
- (ex.report ["Coverage so-far" (%coverage so_far)]
- ["Coverage addition" (%coverage addition)]))
-
-(def: (flatten_alt coverage)
- (-> Coverage (List Coverage))
- (case coverage
- (#Alt left right)
- (list& left (flatten_alt right))
-
- _
- (list coverage)))
-
-(implementation: equivalence (Equivalence Coverage)
- (def: (= reference sample)
- (case [reference sample]
- [#Exhaustive #Exhaustive]
- #1
-
- [(#Bit sideR) (#Bit sideS)]
- (bit\= sideR sideS)
-
- [(#Variant allR casesR) (#Variant allS casesS)]
- (and (n.= (cases allR)
- (cases allS))
- (\ (dictionary.equivalence =) = casesR casesS))
-
- [(#Seq leftR rightR) (#Seq leftS rightS)]
- (and (= leftR leftS)
- (= rightR rightS))
-
- [(#Alt _) (#Alt _)]
- (let [flatR (flatten_alt reference)
- flatS (flatten_alt sample)]
- (and (n.= (list.size flatR) (list.size flatS))
- (list.every? (function (_ [coverageR coverageS])
- (= coverageR coverageS))
- (list.zip/2 flatR flatS))))
-
- _
- #0)))
-
-(open: "coverage/." ..equivalence)
-
-(exception: #export (variants_do_not_match {addition_cases Nat} {so_far_cases Nat})
- (ex.report ["So-far Cases" (%.nat so_far_cases)]
- ["Addition Cases" (%.nat addition_cases)]))
-
-## After determining the coverage of each individual pattern, it is
-## necessary to merge them all to figure out if the entire
-## pattern-matching expression is exhaustive and whether it contains
-## redundant patterns.
-(def: #export (merge addition so_far)
- (-> Coverage Coverage (Try Coverage))
- (case [addition so_far]
- [#Partial #Partial]
- (try\wrap #Partial)
-
- ## 2 bit coverages are exhaustive if they complement one another.
- (^multi [(#Bit sideA) (#Bit sideSF)]
- (xor sideA sideSF))
- (try\wrap #Exhaustive)
-
- [(#Variant allA casesA) (#Variant allSF casesSF)]
- (let [addition_cases (cases allSF)
- so_far_cases (cases allA)]
- (cond (and (known_cases? addition_cases)
- (known_cases? so_far_cases)
- (not (n.= addition_cases so_far_cases)))
- (ex.throw ..variants_do_not_match [addition_cases so_far_cases])
-
- (\ (dictionary.equivalence ..equivalence) = casesSF casesA)
- (ex.throw ..redundant_pattern [so_far addition])
-
- ## else
- (do {! try.monad}
- [casesM (monad.fold !
- (function (_ [tagA coverageA] casesSF')
- (case (dictionary.get tagA casesSF')
- (#.Some coverageSF)
- (do !
- [coverageM (merge coverageA coverageSF)]
- (wrap (dictionary.put tagA coverageM casesSF')))
-
- #.None
- (wrap (dictionary.put tagA coverageA casesSF'))))
- casesSF (dictionary.entries casesA))]
- (wrap (if (and (or (known_cases? addition_cases)
- (known_cases? so_far_cases))
- (n.= (inc (n.max addition_cases so_far_cases))
- (dictionary.size casesM))
- (list.every? exhaustive? (dictionary.values casesM)))
- #Exhaustive
- (#Variant (case allSF
- (#.Some _)
- allSF
-
- _
- allA)
- casesM))))))
-
- [(#Seq leftA rightA) (#Seq leftSF rightSF)]
- (case [(coverage/= leftSF leftA) (coverage/= rightSF rightA)]
- ## Same prefix
- [#1 #0]
- (do try.monad
- [rightM (merge rightA rightSF)]
- (if (exhaustive? rightM)
- ## If all that follows is exhaustive, then it can be safely dropped
- ## (since only the "left" part would influence whether the
- ## merged coverage is exhaustive or not).
- (wrap leftSF)
- (wrap (#Seq leftSF rightM))))
-
- ## Same suffix
- [#0 #1]
- (do try.monad
- [leftM (merge leftA leftSF)]
- (wrap (#Seq leftM rightA)))
-
- ## The 2 sequences cannot possibly be merged.
- [#0 #0]
- (try\wrap (#Alt so_far addition))
-
- ## There is nothing the addition adds to the coverage.
- [#1 #1]
- (ex.throw ..redundant_pattern [so_far addition]))
-
- ## The addition cannot possibly improve the coverage.
- [_ #Exhaustive]
- (ex.throw ..redundant_pattern [so_far addition])
-
- ## The addition completes the coverage.
- [#Exhaustive _]
- (try\wrap #Exhaustive)
-
- ## The left part will always match, so the addition is redundant.
- (^multi [(#Seq left right) single]
- (coverage/= left single))
- (ex.throw ..redundant_pattern [so_far addition])
-
- ## The right part is not necessary, since it can always match the left.
- (^multi [single (#Seq left right)]
- (coverage/= left single))
- (try\wrap single)
-
- ## When merging a new coverage against one based on Alt, it may be
- ## that one of the many coverages in the Alt is complementary to
- ## the new one, so effort must be made to fuse carefully, to match
- ## the right coverages together.
- ## If one of the Alt sub-coverages matches the new one, the cycle
- ## must be repeated, in case the resulting coverage can now match
- ## other ones in the original Alt.
- ## This process must be repeated until no further productive
- ## merges can be done.
- [_ (#Alt leftS rightS)]
- (do {! try.monad}
- [#let [fuse_once (: (-> Coverage (List Coverage)
- (Try [(Maybe Coverage)
- (List Coverage)]))
- (function (_ coverageA possibilitiesSF)
- (loop [altsSF possibilitiesSF]
- (case altsSF
- #.Nil
- (wrap [#.None (list coverageA)])
-
- (#.Cons altSF altsSF')
- (case (merge coverageA altSF)
- (#try.Success altMSF)
- (case altMSF
- (#Alt _)
- (do !
- [[success altsSF+] (recur altsSF')]
- (wrap [success (#.Cons altSF altsSF+)]))
-
- _
- (wrap [(#.Some altMSF) altsSF']))
-
- (#try.Failure error)
- (try.fail error))
- ))))]
- [successA possibilitiesSF] (fuse_once addition (flatten_alt so_far))]
- (loop [successA successA
- possibilitiesSF possibilitiesSF]
- (case successA
- (#.Some coverageA')
- (do !
- [[successA' possibilitiesSF'] (fuse_once coverageA' possibilitiesSF)]
- (recur successA' possibilitiesSF'))
-
- #.None
- (case (list.reverse possibilitiesSF)
- (#.Cons last prevs)
- (wrap (list\fold (function (_ left right) (#Alt left right))
- last
- prevs))
-
- #.Nil
- (undefined)))))
-
- _
- (if (coverage/= so_far addition)
- ## The addition cannot possibly improve the coverage.
- (ex.throw ..redundant_pattern [so_far addition])
- ## There are now 2 alternative paths.
- (try\wrap (#Alt so_far addition)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/function.lux
deleted file mode 100644
index 3b654fffd..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/function.lux
+++ /dev/null
@@ -1,112 +0,0 @@
-(.module:
- [lux (#- function)
- [abstract
- monad]
- [control
- ["ex" exception (#+ exception:)]]
- [data
- ["." maybe]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." fold monoid monad)]]]
- ["." type
- ["." check]]
- ["." meta]]
- ["." // #_
- ["#." scope]
- ["#." type]
- ["#." inference]
- ["/#" // #_
- ["#." extension]
- [//
- ["/" analysis (#+ Analysis Operation Phase)]
- [///
- ["#" phase]
- [reference (#+)
- [variable (#+)]]]]]])
-
-(exception: #export (cannot_analyse {expected Type} {function Text} {argument Text} {body Code})
- (ex.report ["Type" (%.type expected)]
- ["Function" function]
- ["Argument" argument]
- ["Body" (%.code body)]))
-
-(exception: #export (cannot_apply {functionT Type} {functionC Code} {arguments (List Code)})
- (ex.report ["Function type" (%.type functionT)]
- ["Function" (%.code functionC)]
- ["Arguments" (|> arguments
- list.enumeration
- (list\map (.function (_ [idx argC])
- (format (%.nat idx) " " (%.code argC))))
- (text.join_with text.new_line))]))
-
-(def: #export (function analyse function_name arg_name archive body)
- (-> Phase Text Text Phase)
- (do {! ///.monad}
- [functionT (///extension.lift meta.expected_type)]
- (loop [expectedT functionT]
- (/.with_stack ..cannot_analyse [expectedT function_name arg_name body]
- (case expectedT
- (#.Named name unnamedT)
- (recur unnamedT)
-
- (#.Apply argT funT)
- (case (type.apply (list argT) funT)
- (#.Some value)
- (recur value)
-
- #.None
- (/.fail (ex.construct cannot_analyse [expectedT function_name arg_name body])))
-
- (^template [<tag> <instancer>]
- [(<tag> _)
- (do !
- [[_ instanceT] (//type.with_env <instancer>)]
- (recur (maybe.assume (type.apply (list instanceT) expectedT))))])
- ([#.UnivQ check.existential]
- [#.ExQ check.var])
-
- (#.Var id)
- (do !
- [?expectedT' (//type.with_env
- (check.read id))]
- (case ?expectedT'
- (#.Some expectedT')
- (recur expectedT')
-
- ## Inference
- _
- (do !
- [[input_id inputT] (//type.with_env check.var)
- [output_id outputT] (//type.with_env check.var)
- #let [functionT (#.Function inputT outputT)]
- functionA (recur functionT)
- _ (//type.with_env
- (check.check expectedT functionT))]
- (wrap functionA))
- ))
-
- (#.Function inputT outputT)
- (<| (\ ! map (.function (_ [scope bodyA])
- (#/.Function (list\map (|>> /.variable)
- (//scope.environment scope))
- bodyA)))
- /.with_scope
- ## Functions have access not only to their argument, but
- ## also to themselves, through a local variable.
- (//scope.with_local [function_name expectedT])
- (//scope.with_local [arg_name inputT])
- (//type.with_type outputT)
- (analyse archive body))
-
- _
- (/.fail "")
- )))))
-
-(def: #export (apply analyse argsC+ functionT functionA archive functionC)
- (-> Phase (List Code) Type Analysis Phase)
- (<| (/.with_stack ..cannot_apply [functionT functionC argsC+])
- (do ///.monad
- [[applyT argsA+] (//inference.general archive analyse functionT argsC+)])
- (wrap (/.apply [functionA argsA+]))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux
deleted file mode 100644
index 31a5cb912..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux
+++ /dev/null
@@ -1,300 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." exception (#+ exception:)]]
- [data
- ["." maybe]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]]]
- [math
- [number
- ["n" nat]]]
- ["." type
- ["." check]]
- ["." meta]]
- ["." // #_
- ["#." type]
- ["/#" // #_
- ["#." extension]
- [//
- ["/" analysis (#+ Tag Analysis Operation Phase)]
- [///
- ["#" phase ("#\." monad)]
- [meta
- [archive (#+ Archive)]]]]]])
-
-(exception: #export (variant_tag_out_of_bounds {size Nat} {tag Tag} {type Type})
- (exception.report
- ["Tag" (%.nat tag)]
- ["Variant size" (%.int (.int size))]
- ["Variant type" (%.type type)]))
-
-(exception: #export (cannot_infer {type Type} {args (List Code)})
- (exception.report
- ["Type" (%.type type)]
- ["Arguments" (exception.enumerate %.code args)]))
-
-(exception: #export (cannot_infer_argument {inferred Type} {argument Code})
- (exception.report
- ["Inferred Type" (%.type inferred)]
- ["Argument" (%.code argument)]))
-
-(exception: #export (smaller_variant_than_expected {expected Nat} {actual Nat})
- (exception.report
- ["Expected" (%.int (.int expected))]
- ["Actual" (%.int (.int actual))]))
-
-(template [<name>]
- [(exception: #export (<name> {type Type})
- (%.type type))]
-
- [not_a_variant_type]
- [not_a_record_type]
- [invalid_type_application]
- )
-
-(def: (replace parameter_idx replacement type)
- (-> Nat Type Type Type)
- (case type
- (#.Primitive name params)
- (#.Primitive name (list\map (replace parameter_idx replacement) params))
-
- (^template [<tag>]
- [(<tag> left right)
- (<tag> (replace parameter_idx replacement left)
- (replace parameter_idx replacement right))])
- ([#.Sum]
- [#.Product]
- [#.Function]
- [#.Apply])
-
- (#.Parameter idx)
- (if (n.= parameter_idx idx)
- replacement
- type)
-
- (^template [<tag>]
- [(<tag> env quantified)
- (<tag> (list\map (replace parameter_idx replacement) env)
- (replace (n.+ 2 parameter_idx) replacement quantified))])
- ([#.UnivQ]
- [#.ExQ])
-
- _
- type))
-
-(def: (named_type location id)
- (-> Location Nat Type)
- (let [name (format "{New Type " (%.location location) " " (%.nat id) "}")]
- (#.Primitive name (list))))
-
-(def: new_named_type
- (Operation Type)
- (do ///.monad
- [location (///extension.lift meta.location)
- [ex_id _] (//type.with_env check.existential)]
- (wrap (named_type location ex_id))))
-
-## Type-inference works by applying some (potentially quantified) type
-## to a sequence of values.
-## Function types are used for this, although inference is not always
-## done for function application (alternative uses may be records and
-## tagged variants).
-## But, so long as the type being used for the inference can be treated
-## as a function type, this method of inference should work.
-(def: #export (general archive analyse inferT args)
- (-> Archive Phase Type (List Code) (Operation [Type (List Analysis)]))
- (case args
- #.Nil
- (do ///.monad
- [_ (//type.infer inferT)]
- (wrap [inferT (list)]))
-
- (#.Cons argC args')
- (case inferT
- (#.Named name unnamedT)
- (general archive analyse unnamedT args)
-
- (#.UnivQ _)
- (do ///.monad
- [[var_id varT] (//type.with_env check.var)]
- (general archive analyse (maybe.assume (type.apply (list varT) inferT)) args))
-
- (#.ExQ _)
- (do {! ///.monad}
- [[var_id varT] (//type.with_env check.var)
- output (general archive analyse
- (maybe.assume (type.apply (list varT) inferT))
- args)
- bound? (//type.with_env
- (check.bound? var_id))
- _ (if bound?
- (wrap [])
- (do !
- [newT new_named_type]
- (//type.with_env
- (check.check varT newT))))]
- (wrap output))
-
- (#.Apply inputT transT)
- (case (type.apply (list inputT) transT)
- (#.Some outputT)
- (general archive analyse outputT args)
-
- #.None
- (/.throw ..invalid_type_application inferT))
-
- ## Arguments are inferred back-to-front because, by convention,
- ## Lux functions take the most important arguments *last*, which
- ## means that the most information for doing proper inference is
- ## located in the last arguments to a function call.
- ## By inferring back-to-front, a lot of type-annotations can be
- ## avoided in Lux code, since the inference algorithm can piece
- ## things together more easily.
- (#.Function inputT outputT)
- (do ///.monad
- [[outputT' args'A] (general archive analyse outputT args')
- argA (<| (/.with_stack ..cannot_infer_argument [inputT argC])
- (//type.with_type inputT)
- (analyse archive argC))]
- (wrap [outputT' (list& argA args'A)]))
-
- (#.Var infer_id)
- (do ///.monad
- [?inferT' (//type.with_env (check.read infer_id))]
- (case ?inferT'
- (#.Some inferT')
- (general archive analyse inferT' args)
-
- _
- (/.throw ..cannot_infer [inferT args])))
-
- _
- (/.throw ..cannot_infer [inferT args]))
- ))
-
-(def: (substitute_bound target sub)
- (-> Nat Type Type Type)
- (function (recur base)
- (case base
- (#.Primitive name parameters)
- (#.Primitive name (list\map recur parameters))
-
- (^template [<tag>]
- [(<tag> left right)
- (<tag> (recur left) (recur right))])
- ([#.Sum] [#.Product] [#.Function] [#.Apply])
-
- (#.Parameter index)
- (if (n.= target index)
- sub
- base)
-
- (^template [<tag>]
- [(<tag> environment quantified)
- (<tag> (list\map recur environment) quantified)])
- ([#.UnivQ] [#.ExQ])
-
- _
- base)))
-
-## Turns a record type into the kind of function type suitable for inference.
-(def: (record' target originalT inferT)
- (-> Nat Type Type (Operation Type))
- (case inferT
- (#.Named name unnamedT)
- (record' target originalT unnamedT)
-
- (^template [<tag>]
- [(<tag> env bodyT)
- (do ///.monad
- [bodyT+ (record' (n.+ 2 target) originalT bodyT)]
- (wrap (<tag> env bodyT+)))])
- ([#.UnivQ]
- [#.ExQ])
-
- (#.Apply inputT funcT)
- (case (type.apply (list inputT) funcT)
- (#.Some outputT)
- (record' target originalT outputT)
-
- #.None
- (/.throw ..invalid_type_application inferT))
-
- (#.Product _)
- (///\wrap (|> inferT
- (type.function (type.flatten_tuple inferT))
- (substitute_bound target originalT)))
-
- _
- (/.throw ..not_a_record_type inferT)))
-
-(def: #export (record inferT)
- (-> Type (Operation Type))
- (record' (n.- 2 0) inferT inferT))
-
-## Turns a variant type into the kind of function type suitable for inference.
-(def: #export (variant tag expected_size inferT)
- (-> Nat Nat Type (Operation Type))
- (loop [depth 0
- currentT inferT]
- (case currentT
- (#.Named name unnamedT)
- (do ///.monad
- [unnamedT+ (recur depth unnamedT)]
- (wrap unnamedT+))
-
- (^template [<tag>]
- [(<tag> env bodyT)
- (do ///.monad
- [bodyT+ (recur (inc depth) bodyT)]
- (wrap (<tag> env bodyT+)))])
- ([#.UnivQ]
- [#.ExQ])
-
- (#.Sum _)
- (let [cases (type.flatten_variant currentT)
- actual_size (list.size cases)
- boundary (dec expected_size)]
- (cond (or (n.= expected_size actual_size)
- (and (n.> expected_size actual_size)
- (n.< boundary tag)))
- (case (list.nth tag cases)
- (#.Some caseT)
- (///\wrap (if (n.= 0 depth)
- (type.function (list caseT) currentT)
- (let [replace' (replace (|> depth dec (n.* 2)) inferT)]
- (type.function (list (replace' caseT))
- (replace' currentT)))))
-
- #.None
- (/.throw ..variant_tag_out_of_bounds [expected_size tag inferT]))
-
- (n.< expected_size actual_size)
- (/.throw ..smaller_variant_than_expected [expected_size actual_size])
-
- (n.= boundary tag)
- (let [caseT (type.variant (list.drop boundary cases))]
- (///\wrap (if (n.= 0 depth)
- (type.function (list caseT) currentT)
- (let [replace' (replace (|> depth dec (n.* 2)) inferT)]
- (type.function (list (replace' caseT))
- (replace' currentT))))))
-
- ## else
- (/.throw ..variant_tag_out_of_bounds [expected_size tag inferT])))
-
- (#.Apply inputT funcT)
- (case (type.apply (list inputT) funcT)
- (#.Some outputT)
- (variant tag expected_size outputT)
-
- #.None
- (/.throw ..invalid_type_application inferT))
-
- _
- (/.throw ..not_a_variant_type inferT))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux
deleted file mode 100644
index 1d7e5dc27..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux
+++ /dev/null
@@ -1,274 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- pipe
- ["." try]
- ["." exception (#+ exception:)]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." fold functor)]
- [dictionary
- ["." plist]]]]
- ["." meta]]
- ["." /// #_
- ["#." extension]
- [//
- ["/" analysis (#+ Operation)]
- [///
- ["#" phase]]]])
-
-(type: #export Tag Text)
-
-(exception: #export (unknown_module {module Text})
- (exception.report
- ["Module" module]))
-
-(exception: #export (cannot_declare_tag_twice {module Text} {tag Text})
- (exception.report
- ["Module" module]
- ["Tag" tag]))
-
-(template [<name>]
- [(exception: #export (<name> {tags (List Text)} {owner Type})
- (exception.report
- ["Tags" (text.join_with " " tags)]
- ["Type" (%.type owner)]))]
-
- [cannot_declare_tags_for_unnamed_type]
- [cannot_declare_tags_for_foreign_type]
- )
-
-(exception: #export (cannot_define_more_than_once {name Name} {already_existing Global})
- (exception.report
- ["Definition" (%.name name)]
- ["Original" (case already_existing
- (#.Alias alias)
- (format "alias " (%.name alias))
-
- (#.Definition definition)
- (format "definition " (%.name name)))]))
-
-(exception: #export (can_only_change_state_of_active_module {module Text} {state Module_State})
- (exception.report
- ["Module" module]
- ["Desired state" (case state
- #.Active "Active"
- #.Compiled "Compiled"
- #.Cached "Cached")]))
-
-(exception: #export (cannot_set_module_annotations_more_than_once {module Text} {old Code} {new Code})
- (exception.report
- ["Module" module]
- ["Old annotations" (%.code old)]
- ["New annotations" (%.code new)]))
-
-(def: #export (new hash)
- (-> Nat Module)
- {#.module_hash hash
- #.module_aliases (list)
- #.definitions (list)
- #.imports (list)
- #.tags (list)
- #.types (list)
- #.module_annotations #.None
- #.module_state #.Active})
-
-(def: #export (set_annotations annotations)
- (-> Code (Operation Any))
- (///extension.lift
- (do ///.monad
- [self_name meta.current_module_name
- self meta.current_module]
- (case (get@ #.module_annotations self)
- #.None
- (function (_ state)
- (#try.Success [(update@ #.modules
- (plist.put self_name (set@ #.module_annotations (#.Some annotations) self))
- state)
- []]))
-
- (#.Some old)
- (/.throw' cannot_set_module_annotations_more_than_once [self_name old annotations])))))
-
-(def: #export (import module)
- (-> Text (Operation Any))
- (///extension.lift
- (do ///.monad
- [self_name meta.current_module_name]
- (function (_ state)
- (#try.Success [(update@ #.modules
- (plist.update self_name (update@ #.imports (function (_ current)
- (if (list.any? (text\= module)
- current)
- current
- (#.Cons module current)))))
- state)
- []])))))
-
-(def: #export (alias alias module)
- (-> Text Text (Operation Any))
- (///extension.lift
- (do ///.monad
- [self_name meta.current_module_name]
- (function (_ state)
- (#try.Success [(update@ #.modules
- (plist.update self_name (update@ #.module_aliases (: (-> (List [Text Text]) (List [Text Text]))
- (|>> (#.Cons [alias module])))))
- state)
- []])))))
-
-(def: #export (exists? module)
- (-> Text (Operation Bit))
- (///extension.lift
- (function (_ state)
- (|> state
- (get@ #.modules)
- (plist.get module)
- (case> (#.Some _) #1 #.None #0)
- [state] #try.Success))))
-
-(def: #export (define name definition)
- (-> Text Global (Operation Any))
- (///extension.lift
- (do ///.monad
- [self_name meta.current_module_name
- self meta.current_module]
- (function (_ state)
- (case (plist.get name (get@ #.definitions self))
- #.None
- (#try.Success [(update@ #.modules
- (plist.put self_name
- (update@ #.definitions
- (: (-> (List [Text Global]) (List [Text Global]))
- (|>> (#.Cons [name definition])))
- self))
- state)
- []])
-
- (#.Some already_existing)
- ((/.throw' ..cannot_define_more_than_once [[self_name name] already_existing]) state))))))
-
-(def: #export (create hash name)
- (-> Nat Text (Operation Any))
- (///extension.lift
- (function (_ state)
- (#try.Success [(update@ #.modules
- (plist.put name (new hash))
- state)
- []]))))
-
-(def: #export (with_module hash name action)
- (All [a] (-> Nat Text (Operation a) (Operation [Module a])))
- (do ///.monad
- [_ (create hash name)
- output (/.with_current_module name
- action)
- module (///extension.lift (meta.find_module name))]
- (wrap [module output])))
-
-(template [<setter> <asker> <tag>]
- [(def: #export (<setter> module_name)
- (-> Text (Operation Any))
- (///extension.lift
- (function (_ state)
- (case (|> state (get@ #.modules) (plist.get module_name))
- (#.Some module)
- (let [active? (case (get@ #.module_state module)
- #.Active #1
- _ #0)]
- (if active?
- (#try.Success [(update@ #.modules
- (plist.put module_name (set@ #.module_state <tag> module))
- state)
- []])
- ((/.throw' can_only_change_state_of_active_module [module_name <tag>])
- state)))
-
- #.None
- ((/.throw' unknown_module module_name) state)))))
-
- (def: #export (<asker> module_name)
- (-> Text (Operation Bit))
- (///extension.lift
- (function (_ state)
- (case (|> state (get@ #.modules) (plist.get module_name))
- (#.Some module)
- (#try.Success [state
- (case (get@ #.module_state module)
- <tag> #1
- _ #0)])
-
- #.None
- ((/.throw' unknown_module module_name) state)))))]
-
- [set_active active? #.Active]
- [set_compiled compiled? #.Compiled]
- [set_cached cached? #.Cached]
- )
-
-(template [<name> <tag> <type>]
- [(def: (<name> module_name)
- (-> Text (Operation <type>))
- (///extension.lift
- (function (_ state)
- (case (|> state (get@ #.modules) (plist.get module_name))
- (#.Some module)
- (#try.Success [state (get@ <tag> module)])
-
- #.None
- ((/.throw' unknown_module module_name) state)))))]
-
- [tags #.tags (List [Text [Nat (List Name) Bit Type]])]
- [types #.types (List [Text [(List Name) Bit Type]])]
- [hash #.module_hash Nat]
- )
-
-(def: (ensure_undeclared_tags module_name tags)
- (-> Text (List Tag) (Operation Any))
- (do {! ///.monad}
- [bindings (..tags module_name)
- _ (monad.map !
- (function (_ tag)
- (case (plist.get tag bindings)
- #.None
- (wrap [])
-
- (#.Some _)
- (/.throw ..cannot_declare_tag_twice [module_name tag])))
- tags)]
- (wrap [])))
-
-(def: #export (declare_tags tags exported? type)
- (-> (List Tag) Bit Type (Operation Any))
- (do ///.monad
- [self_name (///extension.lift meta.current_module_name)
- [type_module type_name] (case type
- (#.Named type_name _)
- (wrap type_name)
-
- _
- (/.throw ..cannot_declare_tags_for_unnamed_type [tags type]))
- _ (ensure_undeclared_tags self_name tags)
- _ (///.assert cannot_declare_tags_for_foreign_type [tags type]
- (text\= self_name type_module))]
- (///extension.lift
- (function (_ state)
- (case (|> state (get@ #.modules) (plist.get self_name))
- (#.Some module)
- (let [namespaced_tags (list\map (|>> [self_name]) tags)]
- (#try.Success [(update@ #.modules
- (plist.update self_name
- (|>> (update@ #.tags (function (_ tag_bindings)
- (list\fold (function (_ [idx tag] table)
- (plist.put tag [idx namespaced_tags exported? type] table))
- tag_bindings
- (list.enumeration tags))))
- (update@ #.types (plist.put type_name [namespaced_tags exported? type]))))
- state)
- []]))
- #.None
- ((/.throw' unknown_module self_name) state))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/primitive.lux
deleted file mode 100644
index dfdb7e314..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/primitive.lux
+++ /dev/null
@@ -1,32 +0,0 @@
-(.module:
- [lux (#- nat int rev)
- [abstract
- monad]]
- ["." // #_
- ["#." type]
- ["/#" // #_
- [//
- ["/" analysis (#+ Analysis Operation)]
- [///
- ["#" phase]]]]])
-
-(template [<name> <type> <tag>]
- [(def: #export (<name> value)
- (-> <type> (Operation Analysis))
- (do ///.monad
- [_ (//type.infer <type>)]
- (wrap (#/.Primitive (<tag> value)))))]
-
- [bit .Bit #/.Bit]
- [nat .Nat #/.Nat]
- [int .Int #/.Int]
- [rev .Rev #/.Rev]
- [frac .Frac #/.Frac]
- [text .Text #/.Text]
- )
-
-(def: #export unit
- (Operation Analysis)
- (do ///.monad
- [_ (//type.infer .Any)]
- (wrap (#/.Primitive #/.Unit))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/reference.lux
deleted file mode 100644
index a3653935f..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/reference.lux
+++ /dev/null
@@ -1,84 +0,0 @@
-(.module:
- [lux #*
- [abstract
- monad]
- [control
- ["." exception (#+ exception:)]]
- ["." meta]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]]
- ["." // #_
- ["#." scope]
- ["#." type]
- ["/#" // #_
- ["#." extension]
- [//
- ["/" analysis (#+ Analysis Operation)]
- [///
- ["#." reference]
- ["#" phase]]]]])
-
-(exception: #export (foreign_module_has_not_been_imported {current Text} {foreign Text})
- (exception.report
- ["Current" current]
- ["Foreign" foreign]))
-
-(exception: #export (definition_has_not_been_exported {definition Name})
- (exception.report
- ["Definition" (%.name definition)]))
-
-(def: (definition def_name)
- (-> Name (Operation Analysis))
- (with_expansions [<return> (wrap (|> def_name ///reference.constant #/.Reference))]
- (do {! ///.monad}
- [constant (///extension.lift (meta.find_def def_name))]
- (case constant
- (#.Left real_def_name)
- (definition real_def_name)
-
- (#.Right [exported? actualT def_anns _])
- (do !
- [_ (//type.infer actualT)
- (^@ def_name [::module ::name]) (///extension.lift (meta.normalize def_name))
- current (///extension.lift meta.current_module_name)]
- (if (text\= current ::module)
- <return>
- (if exported?
- (do !
- [imported! (///extension.lift (meta.imported_by? ::module current))]
- (if imported!
- <return>
- (/.throw foreign_module_has_not_been_imported [current ::module])))
- (/.throw definition_has_not_been_exported def_name))))))))
-
-(def: (variable var_name)
- (-> Text (Operation (Maybe Analysis)))
- (do {! ///.monad}
- [?var (//scope.find var_name)]
- (case ?var
- (#.Some [actualT ref])
- (do !
- [_ (//type.infer actualT)]
- (wrap (#.Some (|> ref ///reference.variable #/.Reference))))
-
- #.None
- (wrap #.None))))
-
-(def: #export (reference reference)
- (-> Name (Operation Analysis))
- (case reference
- ["" simple_name]
- (do {! ///.monad}
- [?var (variable simple_name)]
- (case ?var
- (#.Some varA)
- (wrap varA)
-
- #.None
- (do !
- [this_module (///extension.lift meta.current_module_name)]
- (definition [this_module simple_name]))))
-
- _
- (definition reference)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux
deleted file mode 100644
index beee6a1b7..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux
+++ /dev/null
@@ -1,205 +0,0 @@
-(.module:
- [lux #*
- [abstract
- monad]
- [control
- ["." try]
- ["." exception (#+ exception:)]]
- [data
- ["." text ("#\." equivalence)]
- ["." maybe ("#\." monad)]
- ["." product]
- [collection
- ["." list ("#\." functor fold monoid)]
- [dictionary
- ["." plist]]]]]
- ["." /// #_
- ["#." extension]
- [//
- ["/" analysis (#+ Operation Phase)]
- [///
- [reference
- ["." variable (#+ Register Variable)]]
- ["#" phase]]]])
-
-(type: Local (Bindings Text [Type Register]))
-(type: Foreign (Bindings Text [Type Variable]))
-
-(def: (local? name scope)
- (-> Text Scope Bit)
- (|> scope
- (get@ [#.locals #.mappings])
- (plist.contains? name)))
-
-(def: (local name scope)
- (-> Text Scope (Maybe [Type Variable]))
- (|> scope
- (get@ [#.locals #.mappings])
- (plist.get name)
- (maybe\map (function (_ [type value])
- [type (#variable.Local value)]))))
-
-(def: (captured? name scope)
- (-> Text Scope Bit)
- (|> scope
- (get@ [#.captured #.mappings])
- (plist.contains? name)))
-
-(def: (captured name scope)
- (-> Text Scope (Maybe [Type Variable]))
- (loop [idx 0
- mappings (get@ [#.captured #.mappings] scope)]
- (case mappings
- (#.Cons [_name [_source_type _source_ref]] mappings')
- (if (text\= name _name)
- (#.Some [_source_type (#variable.Foreign idx)])
- (recur (inc idx) mappings'))
-
- #.Nil
- #.None)))
-
-(def: (reference? name scope)
- (-> Text Scope Bit)
- (or (local? name scope)
- (captured? name scope)))
-
-(def: (reference name scope)
- (-> Text Scope (Maybe [Type Variable]))
- (case (..local name scope)
- (#.Some type)
- (#.Some type)
-
- _
- (..captured name scope)))
-
-(def: #export (find name)
- (-> Text (Operation (Maybe [Type Variable])))
- (///extension.lift
- (function (_ state)
- (let [[inner outer] (|> state
- (get@ #.scopes)
- (list.split_with (|>> (reference? name) not)))]
- (case outer
- #.Nil
- (#.Right [state #.None])
-
- (#.Cons top_outer _)
- (let [[ref_type init_ref] (maybe.default (undefined)
- (..reference name top_outer))
- [ref inner'] (list\fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)])
- (function (_ scope ref+inner)
- [(#variable.Foreign (get@ [#.captured #.counter] scope))
- (#.Cons (update@ #.captured
- (: (-> Foreign Foreign)
- (|>> (update@ #.counter inc)
- (update@ #.mappings (plist.put name [ref_type (product.left ref+inner)]))))
- scope)
- (product.right ref+inner))]))
- [init_ref #.Nil]
- (list.reverse inner))
- scopes (list\compose inner' outer)]
- (#.Right [(set@ #.scopes scopes state)
- (#.Some [ref_type ref])]))
- )))))
-
-(exception: #export cannot_create_local_binding_without_a_scope)
-(exception: #export invalid_scope_alteration)
-
-(def: #export (with_local [name type] action)
- (All [a] (-> [Text Type] (Operation a) (Operation a)))
- (function (_ [bundle state])
- (case (get@ #.scopes state)
- (#.Cons head tail)
- (let [old_mappings (get@ [#.locals #.mappings] head)
- new_var_id (get@ [#.locals #.counter] head)
- new_head (update@ #.locals
- (: (-> Local Local)
- (|>> (update@ #.counter inc)
- (update@ #.mappings (plist.put name [type new_var_id]))))
- head)]
- (case (///.run' [bundle (set@ #.scopes (#.Cons new_head tail) state)]
- action)
- (#try.Success [[bundle' state'] output])
- (case (get@ #.scopes state')
- (#.Cons head' tail')
- (let [scopes' (#.Cons (set@ #.locals (get@ #.locals head) head')
- tail')]
- (#try.Success [[bundle' (set@ #.scopes scopes' state')]
- output]))
-
- _
- (exception.throw ..invalid_scope_alteration []))
-
- (#try.Failure error)
- (#try.Failure error)))
-
- _
- (exception.throw ..cannot_create_local_binding_without_a_scope []))
- ))
-
-(template [<name> <val_type>]
- [(def: <name>
- (Bindings Text [Type <val_type>])
- {#.counter 0
- #.mappings (list)})]
-
- [init_locals Nat]
- [init_captured Variable]
- )
-
-(def: (scope parent_name child_name)
- (-> (List Text) Text Scope)
- {#.name (list& child_name parent_name)
- #.inner 0
- #.locals init_locals
- #.captured init_captured})
-
-(def: #export (with_scope name action)
- (All [a] (-> Text (Operation a) (Operation a)))
- (function (_ [bundle state])
- (let [parent_name (case (get@ #.scopes state)
- #.Nil
- (list)
-
- (#.Cons top _)
- (get@ #.name top))]
- (case (action [bundle (update@ #.scopes
- (|>> (#.Cons (scope parent_name name)))
- state)])
- (#try.Success [[bundle' state'] output])
- (#try.Success [[bundle' (update@ #.scopes
- (|>> list.tail (maybe.default (list)))
- state')]
- output])
-
- (#try.Failure error)
- (#try.Failure error)))
- ))
-
-(exception: #export cannot_get_next_reference_when_there_is_no_scope)
-
-(def: #export next_local
- (Operation Register)
- (///extension.lift
- (function (_ state)
- (case (get@ #.scopes state)
- (#.Cons top _)
- (#try.Success [state (get@ [#.locals #.counter] top)])
-
- #.Nil
- (exception.throw ..cannot_get_next_reference_when_there_is_no_scope [])))))
-
-(def: (ref_to_variable ref)
- (-> Ref Variable)
- (case ref
- (#.Local register)
- (#variable.Local register)
-
- (#.Captured register)
- (#variable.Foreign register)))
-
-(def: #export (environment scope)
- (-> Scope (List Variable))
- (|> scope
- (get@ [#.captured #.mappings])
- (list\map (function (_ [_ [_ ref]]) (ref_to_variable ref)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux
deleted file mode 100644
index dadc61c2d..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux
+++ /dev/null
@@ -1,360 +0,0 @@
-(.module:
- [lux #*
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["ex" exception (#+ exception:)]
- ["." state]]
- [data
- ["." name]
- ["." product]
- ["." maybe]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]
- ["." dictionary (#+ Dictionary)]]]
- [macro
- ["." code]]
- [math
- [number
- ["n" nat]]]
- ["." type
- ["." check]]]
- ["." // #_
- ["#." type]
- ["#." primitive]
- ["#." inference]
- ["/#" // #_
- ["#." extension]
- [//
- ["/" analysis (#+ Tag Analysis Operation Phase)]
- [///
- ["#" phase]
- [meta
- [archive (#+ Archive)]]]]]])
-
-(exception: #export (invalid_variant_type {type Type} {tag Tag} {code Code})
- (ex.report ["Type" (%.type type)]
- ["Tag" (%.nat tag)]
- ["Expression" (%.code code)]))
-
-(template [<name>]
- [(exception: #export (<name> {type Type} {members (List Code)})
- (ex.report ["Type" (%.type type)]
- ["Expression" (%.code (` [(~+ members)]))]))]
-
- [invalid_tuple_type]
- [cannot_analyse_tuple]
- )
-
-(exception: #export (not_a_quantified_type {type Type})
- (%.type type))
-
-(template [<name>]
- [(exception: #export (<name> {type Type} {tag Tag} {code Code})
- (ex.report ["Type" (%.type type)]
- ["Tag" (%.nat tag)]
- ["Expression" (%.code code)]))]
-
- [cannot_analyse_variant]
- [cannot_infer_numeric_tag]
- )
-
-(exception: #export (record_keys_must_be_tags {key Code} {record (List [Code Code])})
- (ex.report ["Key" (%.code key)]
- ["Record" (%.code (code.record record))]))
-
-(template [<name>]
- [(exception: #export (<name> {key Name} {record (List [Name Code])})
- (ex.report ["Tag" (%.code (code.tag key))]
- ["Record" (%.code (code.record (list\map (function (_ [keyI valC])
- [(code.tag keyI) valC])
- record)))]))]
-
- [cannot_repeat_tag]
- )
-
-(exception: #export (tag_does_not_belong_to_record {key Name} {type Type})
- (ex.report ["Tag" (%.code (code.tag key))]
- ["Type" (%.type type)]))
-
-(exception: #export (record_size_mismatch {expected Nat} {actual Nat} {type Type} {record (List [Name Code])})
- (ex.report ["Expected" (%.nat expected)]
- ["Actual" (%.nat actual)]
- ["Type" (%.type type)]
- ["Expression" (%.code (|> record
- (list\map (function (_ [keyI valueC])
- [(code.tag keyI) valueC]))
- code.record))]))
-
-(def: #export (sum analyse lefts right? archive)
- (-> Phase Nat Bit Phase)
- (let [tag (/.tag lefts right?)]
- (function (recur valueC)
- (do {! ///.monad}
- [expectedT (///extension.lift meta.expected_type)
- expectedT' (//type.with_env
- (check.clean expectedT))]
- (/.with_stack ..cannot_analyse_variant [expectedT' tag valueC]
- (case expectedT
- (#.Sum _)
- (let [flat (type.flatten_variant expectedT)]
- (case (list.nth tag flat)
- (#.Some variant_type)
- (do !
- [valueA (//type.with_type variant_type
- (analyse archive valueC))]
- (wrap (/.variant [lefts right? valueA])))
-
- #.None
- (/.throw //inference.variant_tag_out_of_bounds [(list.size flat) tag expectedT])))
-
- (#.Named name unnamedT)
- (//type.with_type unnamedT
- (recur valueC))
-
- (#.Var id)
- (do !
- [?expectedT' (//type.with_env
- (check.read id))]
- (case ?expectedT'
- (#.Some expectedT')
- (//type.with_type expectedT'
- (recur valueC))
-
- ## Cannot do inference when the tag is numeric.
- ## This is because there is no way of knowing how many
- ## cases the inferred sum type would have.
- _
- (/.throw ..cannot_infer_numeric_tag [expectedT tag valueC])))
-
- (^template [<tag> <instancer>]
- [(<tag> _)
- (do !
- [[instance_id instanceT] (//type.with_env <instancer>)]
- (//type.with_type (maybe.assume (type.apply (list instanceT) expectedT))
- (recur valueC)))])
- ([#.UnivQ check.existential]
- [#.ExQ check.var])
-
- (#.Apply inputT funT)
- (case funT
- (#.Var funT_id)
- (do !
- [?funT' (//type.with_env (check.read funT_id))]
- (case ?funT'
- (#.Some funT')
- (//type.with_type (#.Apply inputT funT')
- (recur valueC))
-
- _
- (/.throw ..invalid_variant_type [expectedT tag valueC])))
-
- _
- (case (type.apply (list inputT) funT)
- (#.Some outputT)
- (//type.with_type outputT
- (recur valueC))
-
- #.None
- (/.throw ..not_a_quantified_type funT)))
-
- _
- (/.throw ..invalid_variant_type [expectedT tag valueC])))))))
-
-(def: (typed_product archive analyse members)
- (-> Archive Phase (List Code) (Operation Analysis))
- (do {! ///.monad}
- [expectedT (///extension.lift meta.expected_type)
- membersA+ (: (Operation (List Analysis))
- (loop [membersT+ (type.flatten_tuple expectedT)
- membersC+ members]
- (case [membersT+ membersC+]
- [(#.Cons memberT #.Nil) _]
- (//type.with_type memberT
- (\ ! map (|>> list) (analyse archive (code.tuple membersC+))))
-
- [_ (#.Cons memberC #.Nil)]
- (//type.with_type (type.tuple membersT+)
- (\ ! map (|>> list) (analyse archive memberC)))
-
- [(#.Cons memberT membersT+') (#.Cons memberC membersC+')]
- (do !
- [memberA (//type.with_type memberT
- (analyse archive memberC))
- memberA+ (recur membersT+' membersC+')]
- (wrap (#.Cons memberA memberA+)))
-
- _
- (/.throw ..cannot_analyse_tuple [expectedT members]))))]
- (wrap (/.tuple membersA+))))
-
-(def: #export (product archive analyse membersC)
- (-> Archive Phase (List Code) (Operation Analysis))
- (do {! ///.monad}
- [expectedT (///extension.lift meta.expected_type)]
- (/.with_stack ..cannot_analyse_tuple [expectedT membersC]
- (case expectedT
- (#.Product _)
- (..typed_product archive analyse membersC)
-
- (#.Named name unnamedT)
- (//type.with_type unnamedT
- (product archive analyse membersC))
-
- (#.Var id)
- (do !
- [?expectedT' (//type.with_env
- (check.read id))]
- (case ?expectedT'
- (#.Some expectedT')
- (//type.with_type expectedT'
- (product archive analyse membersC))
-
- _
- ## Must do inference...
- (do !
- [membersTA (monad.map ! (|>> (analyse archive) //type.with_inference)
- membersC)
- _ (//type.with_env
- (check.check expectedT
- (type.tuple (list\map product.left membersTA))))]
- (wrap (/.tuple (list\map product.right membersTA))))))
-
- (^template [<tag> <instancer>]
- [(<tag> _)
- (do !
- [[instance_id instanceT] (//type.with_env <instancer>)]
- (//type.with_type (maybe.assume (type.apply (list instanceT) expectedT))
- (product archive analyse membersC)))])
- ([#.UnivQ check.existential]
- [#.ExQ check.var])
-
- (#.Apply inputT funT)
- (case funT
- (#.Var funT_id)
- (do !
- [?funT' (//type.with_env (check.read funT_id))]
- (case ?funT'
- (#.Some funT')
- (//type.with_type (#.Apply inputT funT')
- (product archive analyse membersC))
-
- _
- (/.throw ..invalid_tuple_type [expectedT membersC])))
-
- _
- (case (type.apply (list inputT) funT)
- (#.Some outputT)
- (//type.with_type outputT
- (product archive analyse membersC))
-
- #.None
- (/.throw ..not_a_quantified_type funT)))
-
- _
- (/.throw ..invalid_tuple_type [expectedT membersC])
- ))))
-
-(def: #export (tagged_sum analyse tag archive valueC)
- (-> Phase Name Phase)
- (do {! ///.monad}
- [tag (///extension.lift (meta.normalize tag))
- [idx group variantT] (///extension.lift (meta.resolve_tag tag))
- #let [case_size (list.size group)
- [lefts right?] (/.choice case_size idx)]
- expectedT (///extension.lift meta.expected_type)]
- (case expectedT
- (#.Var _)
- (do !
- [inferenceT (//inference.variant idx case_size variantT)
- [inferredT valueA+] (//inference.general archive analyse inferenceT (list valueC))]
- (wrap (/.variant [lefts right? (|> valueA+ list.head maybe.assume)])))
-
- _
- (..sum analyse lefts right? archive valueC))))
-
-## There cannot be any ambiguity or improper syntax when analysing
-## records, so they must be normalized for further analysis.
-## Normalization just means that all the tags get resolved to their
-## canonical form (with their corresponding module identified).
-(def: #export (normalize record)
- (-> (List [Code Code]) (Operation (List [Name Code])))
- (monad.map ///.monad
- (function (_ [key val])
- (case key
- [_ (#.Tag key)]
- (do ///.monad
- [key (///extension.lift (meta.normalize key))]
- (wrap [key val]))
-
- _
- (/.throw ..record_keys_must_be_tags [key record])))
- record))
-
-## Lux already possesses the means to analyse tuples, so
-## re-implementing the same functionality for records makes no sense.
-## Records, thus, get transformed into tuples by ordering the elements.
-(def: #export (order record)
- (-> (List [Name Code]) (Operation [(List Code) Type]))
- (case record
- ## empty_record = empty_tuple = unit = []
- #.Nil
- (\ ///.monad wrap [(list) Any])
-
- (#.Cons [head_k head_v] _)
- (do {! ///.monad}
- [head_k (///extension.lift (meta.normalize head_k))
- [_ tag_set recordT] (///extension.lift (meta.resolve_tag head_k))
- #let [size_record (list.size record)
- size_ts (list.size tag_set)]
- _ (if (n.= size_ts size_record)
- (wrap [])
- (/.throw ..record_size_mismatch [size_ts size_record recordT record]))
- #let [tuple_range (list.indices size_ts)
- tag->idx (dictionary.from_list name.hash (list.zip/2 tag_set tuple_range))]
- idx->val (monad.fold !
- (function (_ [key val] idx->val)
- (do !
- [key (///extension.lift (meta.normalize key))]
- (case (dictionary.get key tag->idx)
- (#.Some idx)
- (if (dictionary.key? idx->val idx)
- (/.throw ..cannot_repeat_tag [key record])
- (wrap (dictionary.put idx val idx->val)))
-
- #.None
- (/.throw ..tag_does_not_belong_to_record [key recordT]))))
- (: (Dictionary Nat Code)
- (dictionary.new n.hash))
- record)
- #let [ordered_tuple (list\map (function (_ idx) (maybe.assume (dictionary.get idx idx->val)))
- tuple_range)]]
- (wrap [ordered_tuple recordT]))
- ))
-
-(def: #export (record archive analyse members)
- (-> Archive Phase (List [Code Code]) (Operation Analysis))
- (case members
- (^ (list))
- //primitive.unit
-
- (^ (list [_ singletonC]))
- (analyse archive singletonC)
-
- _
- (do {! ///.monad}
- [members (normalize members)
- [membersC recordT] (order members)
- expectedT (///extension.lift meta.expected_type)]
- (case expectedT
- (#.Var _)
- (do !
- [inferenceT (//inference.record recordT)
- [inferredT membersA] (//inference.general archive analyse inferenceT membersC)]
- (wrap (/.tuple membersA)))
-
- _
- (..product archive analyse membersC)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux
deleted file mode 100644
index f72ec593b..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux
+++ /dev/null
@@ -1,55 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." function]
- ["." try]]
- [type
- ["." check (#+ Check)]]
- ["." meta]]
- ["." /// #_
- ["#." extension]
- [//
- ["/" analysis (#+ Operation)]
- [///
- ["#" phase]]]])
-
-(def: #export (with_type expected)
- (All [a] (-> Type (Operation a) (Operation a)))
- (///extension.localized (get@ #.expected) (set@ #.expected)
- (function.constant (#.Some expected))))
-
-(def: #export (with_env action)
- (All [a] (-> (Check a) (Operation a)))
- (function (_ (^@ stateE [bundle state]))
- (case (action (get@ #.type_context state))
- (#try.Success [context' output])
- (#try.Success [[bundle (set@ #.type_context context' state)]
- output])
-
- (#try.Failure error)
- ((/.fail error) stateE))))
-
-(def: #export with_fresh_env
- (All [a] (-> (Operation a) (Operation a)))
- (///extension.localized (get@ #.type_context) (set@ #.type_context)
- (function.constant check.fresh_context)))
-
-(def: #export (infer actualT)
- (-> Type (Operation Any))
- (do ///.monad
- [expectedT (///extension.lift meta.expected_type)]
- (with_env
- (check.check expectedT actualT))))
-
-(def: #export (with_inference action)
- (All [a] (-> (Operation a) (Operation [Type a])))
- (do ///.monad
- [[_ varT] (..with_env
- check.var)
- output (with_type varT
- action)
- knownT (..with_env
- (check.clean varT))]
- (wrap [knownT output])))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/directive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/directive.lux
deleted file mode 100644
index 088bed17a..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/directive.lux
+++ /dev/null
@@ -1,78 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." exception (#+ exception:)]]
- [data
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." fold monoid)]]]
- ["." meta]]
- ["." // #_
- ["#." extension]
- ["#." analysis
- ["#/." type]]
- ["/#" // #_
- ["/" directive (#+ Phase)]
- ["#." analysis
- ["#/." macro (#+ Expander)]]
- [///
- ["//" phase]
- [reference (#+)
- [variable (#+)]]]]])
-
-(exception: #export (not_a_directive {code Code})
- (exception.report
- ["Directive" (%.code code)]))
-
-(exception: #export (invalid_macro_call {code Code})
- (exception.report
- ["Code" (%.code code)]))
-
-(exception: #export (macro_was_not_found {name Name})
- (exception.report
- ["Name" (%.name name)]))
-
-(with_expansions [<lux_def_module> (as_is [|form_location| (#.Form (list& [|text_location| (#.Text "lux def module")] annotations))])]
- (def: #export (phase expander)
- (-> Expander Phase)
- (let [analyze (//analysis.phase expander)]
- (function (recur archive code)
- (case code
- (^ [_ (#.Form (list& [_ (#.Text name)] inputs))])
- (//extension.apply archive recur [name inputs])
-
- (^ [_ (#.Form (list& macro inputs))])
- (do {! //.monad}
- [expansion (/.lift_analysis
- (do !
- [macroA (//analysis/type.with_type Macro
- (analyze archive macro))]
- (case macroA
- (^ (///analysis.constant macro_name))
- (do !
- [?macro (//extension.lift (meta.find_macro macro_name))
- macro (case ?macro
- (#.Some macro)
- (wrap macro)
-
- #.None
- (//.throw ..macro_was_not_found macro_name))]
- (//extension.lift (///analysis/macro.expand expander macro_name macro inputs)))
-
- _
- (//.throw ..invalid_macro_call code))))]
- (case expansion
- (^ (list& <lux_def_module> referrals))
- (|> (recur archive <lux_def_module>)
- (\ ! map (update@ #/.referrals (list\compose referrals))))
-
- _
- (|> expansion
- (monad.map ! (recur archive))
- (\ ! map (list\fold /.merge_requirements /.no_requirements)))))
-
- _
- (//.throw ..not_a_directive code))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux
deleted file mode 100644
index 7004b8d1a..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux
+++ /dev/null
@@ -1,176 +0,0 @@
-(.module:
- [lux (#- Name)
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." product]
- ["." text ("#\." order)
- ["%" format (#+ Format format)]]
- [collection
- ["." list]
- ["." dictionary (#+ Dictionary)]]]]
- [/////
- ["//" phase]
- [meta
- [archive (#+ Archive)]]])
-
-(type: #export Name
- Text)
-
-(type: #export (Extension a)
- [Name (List a)])
-
-(def: #export equivalence
- (All [a] (-> (Equivalence a) (Equivalence (Extension a))))
- (|>> list.equivalence
- (product.equivalence text.equivalence)))
-
-(def: #export hash
- (All [a] (-> (Hash a) (Hash (Extension a))))
- (|>> list.hash
- (product.hash text.hash)))
-
-(with_expansions [<Bundle> (as_is (Dictionary Name (Handler s i o)))]
- (type: #export (Handler s i o)
- (-> Name
- (//.Phase [<Bundle> s] i o)
- (//.Phase [<Bundle> s] (List i) o)))
-
- (type: #export (Bundle s i o)
- <Bundle>))
-
-(def: #export empty
- Bundle
- (dictionary.new text.hash))
-
-(type: #export (State s i o)
- {#bundle (Bundle s i o)
- #state s})
-
-(type: #export (Operation s i o v)
- (//.Operation (State s i o) v))
-
-(type: #export (Phase s i o)
- (//.Phase (State s i o) i o))
-
-(exception: #export (cannot_overwrite {name Name})
- (exception.report
- ["Extension" (%.text name)]))
-
-(exception: #export (incorrect_arity {name Name} {arity Nat} {args Nat})
- (exception.report
- ["Extension" (%.text name)]
- ["Expected" (%.nat arity)]
- ["Actual" (%.nat args)]))
-
-(exception: #export [a] (invalid_syntax {name Name} {%format (Format a)} {inputs (List a)})
- (exception.report
- ["Extension" (%.text name)]
- ["Inputs" (exception.enumerate %format inputs)]))
-
-(exception: #export [s i o] (unknown {name Name} {bundle (Bundle s i o)})
- (exception.report
- ["Extension" (%.text name)]
- ["Available" (|> bundle
- dictionary.keys
- (list.sort text\<)
- (exception.enumerate %.text))]))
-
-(type: #export (Extender s i o)
- (-> Any (Handler s i o)))
-
-(def: #export (install extender name handler)
- (All [s i o]
- (-> (Extender s i o) Text (Handler s i o) (Operation s i o Any)))
- (function (_ [bundle state])
- (case (dictionary.get name bundle)
- #.None
- (#try.Success [[(dictionary.put name (extender handler) bundle) state]
- []])
-
- _
- (exception.throw ..cannot_overwrite name))))
-
-(def: #export (with extender extensions)
- (All [s i o]
- (-> Extender (Bundle s i o) (Operation s i o Any)))
- (|> extensions
- dictionary.entries
- (monad.fold //.monad
- (function (_ [extension handle] output)
- (..install extender extension handle))
- [])))
-
-(def: #export (apply archive phase [name parameters])
- (All [s i o]
- (-> Archive (Phase s i o) (Extension i) (Operation s i o o)))
- (function (_ (^@ stateE [bundle state]))
- (case (dictionary.get name bundle)
- (#.Some handler)
- (((handler name phase) archive parameters)
- stateE)
-
- #.None
- (exception.throw ..unknown [name bundle]))))
-
-(def: #export (localized get set transform)
- (All [s s' i o v]
- (-> (-> s s') (-> s' s s) (-> s' s')
- (-> (Operation s i o v) (Operation s i o v))))
- (function (_ operation)
- (function (_ [bundle state])
- (let [old (get state)]
- (case (operation [bundle (set (transform old) state)])
- (#try.Success [[bundle' state'] output])
- (#try.Success [[bundle' (set old state')] output])
-
- (#try.Failure error)
- (#try.Failure error))))))
-
-(def: #export (temporary transform)
- (All [s i o v]
- (-> (-> s s)
- (-> (Operation s i o v) (Operation s i o v))))
- (function (_ operation)
- (function (_ [bundle state])
- (case (operation [bundle (transform state)])
- (#try.Success [[bundle' state'] output])
- (#try.Success [[bundle' state] output])
-
- (#try.Failure error)
- (#try.Failure error)))))
-
-(def: #export (with_state state)
- (All [s i o v]
- (-> s (-> (Operation s i o v) (Operation s i o v))))
- (..temporary (function.constant state)))
-
-(def: #export (read get)
- (All [s i o v]
- (-> (-> s v) (Operation s i o v)))
- (function (_ [bundle state])
- (#try.Success [[bundle state] (get state)])))
-
-(def: #export (update transform)
- (All [s i o]
- (-> (-> s s) (Operation s i o Any)))
- (function (_ [bundle state])
- (#try.Success [[bundle (transform state)] []])))
-
-(def: #export (lift action)
- (All [s i o v]
- (-> (//.Operation s v)
- (//.Operation [(Bundle s i o) s] v)))
- (function (_ [bundle state])
- (case (action state)
- (#try.Success [state' output])
- (#try.Success [[bundle state'] output])
-
- (#try.Failure error)
- (#try.Failure error))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis.lux
deleted file mode 100644
index 0f38bce97..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis.lux
+++ /dev/null
@@ -1,15 +0,0 @@
-(.module:
- [lux #*
- [data
- [collection
- ["." dictionary]]]]
- [////
- [analysis (#+ Bundle)
- [evaluation (#+ Eval)]]]
- ["." / #_
- ["#." lux]])
-
-(def: #export (bundle eval host-specific)
- (-> Eval Bundle Bundle)
- (dictionary.merge host-specific
- (/lux.bundle eval)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux
deleted file mode 100644
index 887d639f1..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux
+++ /dev/null
@@ -1,34 +0,0 @@
-(.module:
- [lux #*
- ["." ffi]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["<>" parser
- ["<c>" code (#+ Parser)]]]
- [data
- [collection
- ["." array (#+ Array)]
- ["." dictionary]
- ["." list]]]
- ["." type
- ["." check]]
- ["@" target
- ["_" common_lisp]]]
- [//
- ["/" lux (#+ custom)]
- [//
- ["." bundle]
- [//
- ["." analysis #_
- ["#/." type]]
- [//
- ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
- [///
- ["." phase]]]]]])
-
-(def: #export bundle
- Bundle
- (<| (bundle.prefix "common_lisp")
- (|> bundle.empty
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux
deleted file mode 100644
index d36dcd1ef..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux
+++ /dev/null
@@ -1,217 +0,0 @@
-(.module:
- [lux #*
- ["." ffi]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["<>" parser
- ["<c>" code (#+ Parser)]]]
- [data
- [collection
- ["." array (#+ Array)]
- ["." dictionary]
- ["." list]]]
- ["." type
- ["." check]]
- ["@" target
- ["_" js]]]
- [//
- ["/" lux (#+ custom)]
- [//
- ["." bundle]
- [//
- ["." analysis #_
- ["#/." type]]
- [//
- ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
- [///
- ["." phase]]]]]])
-
-(def: array::new
- Handler
- (custom
- [<c>.any
- (function (_ extension phase archive lengthC)
- (do phase.monad
- [lengthA (analysis/type.with_type Nat
- (phase archive lengthC))
- [var_id varT] (analysis/type.with_env check.var)
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list lengthA)))))]))
-
-(def: array::length
- Handler
- (custom
- [<c>.any
- (function (_ extension phase archive arrayC)
- (do phase.monad
- [[var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer Nat)]
- (wrap (#analysis.Extension extension (list arrayA)))))]))
-
-(def: array::read
- Handler
- (custom
- [(<>.and <c>.any <c>.any)
- (function (_ extension phase archive [indexC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer varT)]
- (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
-
-(def: array::write
- Handler
- (custom
- [($_ <>.and <c>.any <c>.any <c>.any)
- (function (_ extension phase archive [indexC valueC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- valueA (analysis/type.with_type varT
- (phase archive valueC))
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))]))
-
-(def: array::delete
- Handler
- (custom
- [($_ <>.and <c>.any <c>.any)
- (function (_ extension phase archive [indexC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
-
-(def: bundle::array
- Bundle
- (<| (bundle.prefix "array")
- (|> bundle.empty
- (bundle.install "new" array::new)
- (bundle.install "length" array::length)
- (bundle.install "read" array::read)
- (bundle.install "write" array::write)
- (bundle.install "delete" array::delete)
- )))
-
-(def: object::new
- Handler
- (custom
- [($_ <>.and <c>.any (<c>.tuple (<>.some <c>.any)))
- (function (_ extension phase archive [constructorC inputsC])
- (do {! phase.monad}
- [constructorA (analysis/type.with_type Any
- (phase archive constructorC))
- inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
- _ (analysis/type.infer .Any)]
- (wrap (#analysis.Extension extension (list& constructorA inputsA)))))]))
-
-(def: object::get
- Handler
- (custom
- [($_ <>.and <c>.text <c>.any)
- (function (_ extension phase archive [fieldC objectC])
- (do phase.monad
- [objectA (analysis/type.with_type Any
- (phase archive objectC))
- _ (analysis/type.infer .Any)]
- (wrap (#analysis.Extension extension (list (analysis.text fieldC)
- objectA)))))]))
-
-(def: object::do
- Handler
- (custom
- [($_ <>.and <c>.text <c>.any (<c>.tuple (<>.some <c>.any)))
- (function (_ extension phase archive [methodC objectC inputsC])
- (do {! phase.monad}
- [objectA (analysis/type.with_type Any
- (phase archive objectC))
- inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
- _ (analysis/type.infer .Any)]
- (wrap (#analysis.Extension extension (list& (analysis.text methodC)
- objectA
- inputsA)))))]))
-
-(def: bundle::object
- Bundle
- (<| (bundle.prefix "object")
- (|> bundle.empty
- (bundle.install "new" object::new)
- (bundle.install "get" object::get)
- (bundle.install "do" object::do)
- (bundle.install "null" (/.nullary Any))
- (bundle.install "null?" (/.unary Any Bit))
- (bundle.install "undefined" (/.nullary Any))
- (bundle.install "undefined?" (/.unary Any Bit))
- )))
-
-(def: js::constant
- Handler
- (custom
- [<c>.text
- (function (_ extension phase archive name)
- (do phase.monad
- [_ (analysis/type.infer Any)]
- (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
-
-(def: js::apply
- Handler
- (custom
- [($_ <>.and <c>.any (<>.some <c>.any))
- (function (_ extension phase archive [abstractionC inputsC])
- (do {! phase.monad}
- [abstractionA (analysis/type.with_type Any
- (phase archive abstractionC))
- inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
- _ (analysis/type.infer Any)]
- (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))]))
-
-(def: js::type_of
- Handler
- (custom
- [<c>.any
- (function (_ extension phase archive objectC)
- (do phase.monad
- [objectA (analysis/type.with_type Any
- (phase archive objectC))
- _ (analysis/type.infer .Text)]
- (wrap (#analysis.Extension extension (list objectA)))))]))
-
-(def: js::function
- Handler
- (custom
- [($_ <>.and <c>.nat <c>.any)
- (function (_ extension phase archive [arity abstractionC])
- (do phase.monad
- [#let [inputT (type.tuple (list.repeat arity Any))]
- abstractionA (analysis/type.with_type (-> inputT Any)
- (phase archive abstractionC))
- _ (analysis/type.infer (for {@.js ffi.Function}
- Any))]
- (wrap (#analysis.Extension extension (list (analysis.nat arity)
- abstractionA)))))]))
-
-(def: #export bundle
- Bundle
- (<| (bundle.prefix "js")
- (|> bundle.empty
- (dictionary.merge bundle::array)
- (dictionary.merge bundle::object)
-
- (bundle.install "constant" js::constant)
- (bundle.install "apply" js::apply)
- (bundle.install "type-of" js::type_of)
- (bundle.install "function" js::function)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux
deleted file mode 100644
index 0d67b2224..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux
+++ /dev/null
@@ -1,2075 +0,0 @@
-(.module:
- [lux (#- Type Module primitive type char int)
- ["." ffi (#+ import:)]
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- pipe
- ["." try (#+ Try) ("#\." monad)]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<.>" code (#+ Parser)]
- ["<.>" text]]]
- [data
- ["." maybe]
- ["." product]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." fold monad monoid)]
- ["." array]
- ["." dictionary (#+ Dictionary)]]]
- [math
- [number
- ["n" nat]]]
- [target
- ["." jvm #_
- [".!" reflection]
- [encoding
- [name (#+ External)]]
- ["#" type (#+ Type Argument Typed) ("#\." equivalence)
- ["." category (#+ Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method)]
- ["." box]
- ["." reflection]
- ["." descriptor]
- ["." signature]
- ["#_." parser]
- ["#_." alias (#+ Aliasing)]
- [".T" lux (#+ Mapping)]]]]
- ["." type
- ["." check (#+ Check) ("#\." monad)]]]
- ["." // #_
- ["#." lux (#+ custom)]
- ["/#" //
- ["#." bundle]
- ["/#" // #_
- [analysis
- [".A" type]
- [".A" inference]
- ["." scope]]
- ["/#" // #_
- ["#." analysis (#+ Analysis Operation Phase Handler Bundle)]
- ["#." synthesis]
- [///
- ["." phase ("#\." monad)]
- [meta
- [archive (#+ Archive)
- [descriptor (#+ Module)]]]]]]]])
-
-(import: java/lang/Object
- ["#::."
- (equals [java/lang/Object] boolean)])
-
-(import: java/lang/reflect/Type)
-
-(import: (java/lang/reflect/TypeVariable d)
- ["#::."
- (getName [] java/lang/String)
- (getBounds [] [java/lang/reflect/Type])])
-
-(import: java/lang/reflect/Modifier
- ["#::."
- (#static isStatic [int] boolean)
- (#static isFinal [int] boolean)
- (#static isInterface [int] boolean)
- (#static isAbstract [int] boolean)])
-
-(import: java/lang/annotation/Annotation)
-
-(import: java/lang/reflect/Method
- ["#::."
- (getName [] java/lang/String)
- (getModifiers [] int)
- (getDeclaringClass [] (java/lang/Class java/lang/Object))
- (getTypeParameters [] [(java/lang/reflect/TypeVariable java/lang/reflect/Method)])
- (getGenericParameterTypes [] [java/lang/reflect/Type])
- (getGenericReturnType [] java/lang/reflect/Type)
- (getGenericExceptionTypes [] [java/lang/reflect/Type])
- (getDeclaredAnnotations [] [java/lang/annotation/Annotation])])
-
-(import: (java/lang/reflect/Constructor c)
- ["#::."
- (getModifiers [] int)
- (getDeclaringClass [] (java/lang/Class c))
- (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/reflect/Constructor c))])
- (getGenericParameterTypes [] [java/lang/reflect/Type])
- (getGenericExceptionTypes [] [java/lang/reflect/Type])
- (getDeclaredAnnotations [] [java/lang/annotation/Annotation])])
-
-(import: (java/lang/Class c)
- ["#::."
- (#static forName [java/lang/String] #try (java/lang/Class java/lang/Object))
- (getName [] java/lang/String)
- (getModifiers [] int)
- (isAssignableFrom [(java/lang/Class java/lang/Object)] boolean)
- (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/Class c))])
- (getGenericInterfaces [] [java/lang/reflect/Type])
- (getGenericSuperclass [] #? java/lang/reflect/Type)
- (getDeclaredField [java/lang/String] #try java/lang/reflect/Field)
- (getConstructors [] [(java/lang/reflect/Constructor java/lang/Object)])
- (getDeclaredMethods [] [java/lang/reflect/Method])
- (getDeclaredAnnotations [] [java/lang/annotation/Annotation])])
-
-(template [<name>]
- [(exception: #export (<name> {class External} {field Text})
- (exception.report
- ["Class" (%.text class)]
- ["Field" (%.text field)]))]
-
- [cannot_set_a_final_field]
- [deprecated_field]
- )
-
-(exception: #export (deprecated_method {class External} {method Text} {type .Type})
- (exception.report
- ["Class" (%.text class)]
- ["Method" (%.text method)]
- ["Type" (%.type type)]))
-
-(exception: #export (deprecated_class {class External})
- (exception.report
- ["Class" (%.text class)]))
-
-(def: (ensure_fresh_class! name)
- (-> External (Operation Any))
- (do phase.monad
- [class (phase.lift (reflection!.load name))]
- (phase.assert ..deprecated_class [name]
- (|> class
- java/lang/Class::getDeclaredAnnotations
- reflection!.deprecated?
- not))))
-
-(def: reflection
- (All [category]
- (-> (Type (<| Return' Value' category)) Text))
- (|>> jvm.reflection reflection.reflection))
-
-(def: signature (|>> jvm.signature signature.signature))
-
-(def: object_class
- External
- "java.lang.Object")
-
-(def: inheritance_relationship_type_name "_jvm_inheritance")
-(def: #export (inheritance_relationship_type class super_class super_interfaces)
- (-> .Type .Type (List .Type) .Type)
- (#.Primitive ..inheritance_relationship_type_name
- (list& class super_class super_interfaces)))
-
-## TODO: Get rid of this template block and use the definition in
-## lux/ffi.jvm.lux ASAP
-(template [<name> <class>]
- [(def: #export <name> .Type (#.Primitive <class> #.Nil))]
-
- ## Boxes
- [Boolean box.boolean]
- [Byte box.byte]
- [Short box.short]
- [Integer box.int]
- [Long box.long]
- [Float box.float]
- [Double box.double]
- [Character box.char]
- [String "java.lang.String"]
-
- ## Primitives
- [boolean (reflection.reflection reflection.boolean)]
- [byte (reflection.reflection reflection.byte)]
- [short (reflection.reflection reflection.short)]
- [int (reflection.reflection reflection.int)]
- [long (reflection.reflection reflection.long)]
- [float (reflection.reflection reflection.float)]
- [double (reflection.reflection reflection.double)]
- [char (reflection.reflection reflection.char)]
- )
-
-(type: Member
- {#class External
- #member Text})
-
-(def: member
- (Parser Member)
- ($_ <>.and <code>.text <code>.text))
-
-(type: Method_Signature
- {#method .Type
- #deprecated? Bit
- #exceptions (List .Type)})
-
-(template [<name>]
- [(exception: #export (<name> {type .Type})
- (exception.report
- ["Type" (%.type type)]))]
-
- [non_object]
- [non_array]
- [non_parameter]
- [non_jvm_type]
- )
-
-(template [<name>]
- [(exception: #export (<name> {class External})
- (exception.report
- ["Class/type" (%.text class)]))]
-
- [non_interface]
- [non_throwable]
- [primitives_are_not_objects]
- )
-
-(template [<name>]
- [(exception: #export (<name> {class External}
- {method Text}
- {inputsJT (List (Type Value))}
- {hints (List Method_Signature)})
- (exception.report
- ["Class" class]
- ["Method" method]
- ["Arguments" (exception.enumerate ..signature inputsJT)]
- ["Hints" (exception.enumerate %.type (list\map product.left hints))]))]
-
- [no_candidates]
- [too_many_candidates]
- )
-
-(exception: #export (cannot_cast {from .Type} {to .Type} {value Code})
- (exception.report
- ["From" (%.type from)]
- ["To" (%.type to)]
- ["Value" (%.code value)]))
-
-(template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
-
- [primitives_cannot_have_type_parameters]
-
- [cannot_possibly_be_an_instance]
-
- [unknown_type_var]
- )
-
-(def: bundle::conversion
- Bundle
- (<| (///bundle.prefix "conversion")
- (|> ///bundle.empty
- (///bundle.install "double-to-float" (//lux.unary ..double ..float))
- (///bundle.install "double-to-int" (//lux.unary ..double ..int))
- (///bundle.install "double-to-long" (//lux.unary ..double ..long))
- (///bundle.install "float-to-double" (//lux.unary ..float ..double))
- (///bundle.install "float-to-int" (//lux.unary ..float ..int))
- (///bundle.install "float-to-long" (//lux.unary ..float ..long))
- (///bundle.install "int-to-byte" (//lux.unary ..int ..byte))
- (///bundle.install "int-to-char" (//lux.unary ..int ..char))
- (///bundle.install "int-to-double" (//lux.unary ..int ..double))
- (///bundle.install "int-to-float" (//lux.unary ..int ..float))
- (///bundle.install "int-to-long" (//lux.unary ..int ..long))
- (///bundle.install "int-to-short" (//lux.unary ..int ..short))
- (///bundle.install "long-to-double" (//lux.unary ..long ..double))
- (///bundle.install "long-to-float" (//lux.unary ..long ..float))
- (///bundle.install "long-to-int" (//lux.unary ..long ..int))
- (///bundle.install "long-to-short" (//lux.unary ..long ..short))
- (///bundle.install "long-to-byte" (//lux.unary ..long ..byte))
- (///bundle.install "char-to-byte" (//lux.unary ..char ..byte))
- (///bundle.install "char-to-short" (//lux.unary ..char ..short))
- (///bundle.install "char-to-int" (//lux.unary ..char ..int))
- (///bundle.install "char-to-long" (//lux.unary ..char ..long))
- (///bundle.install "byte-to-long" (//lux.unary ..byte ..long))
- (///bundle.install "short-to-long" (//lux.unary ..short ..long))
- )))
-
-(template [<name> <prefix> <type>]
- [(def: <name>
- Bundle
- (<| (///bundle.prefix (reflection.reflection <prefix>))
- (|> ///bundle.empty
- (///bundle.install "+" (//lux.binary <type> <type> <type>))
- (///bundle.install "-" (//lux.binary <type> <type> <type>))
- (///bundle.install "*" (//lux.binary <type> <type> <type>))
- (///bundle.install "/" (//lux.binary <type> <type> <type>))
- (///bundle.install "%" (//lux.binary <type> <type> <type>))
- (///bundle.install "=" (//lux.binary <type> <type> Bit))
- (///bundle.install "<" (//lux.binary <type> <type> Bit))
- (///bundle.install "and" (//lux.binary <type> <type> <type>))
- (///bundle.install "or" (//lux.binary <type> <type> <type>))
- (///bundle.install "xor" (//lux.binary <type> <type> <type>))
- (///bundle.install "shl" (//lux.binary ..int <type> <type>))
- (///bundle.install "shr" (//lux.binary ..int <type> <type>))
- (///bundle.install "ushr" (//lux.binary ..int <type> <type>))
- )))]
-
- [bundle::int reflection.int ..int]
- [bundle::long reflection.long ..long]
- )
-
-(template [<name> <prefix> <type>]
- [(def: <name>
- Bundle
- (<| (///bundle.prefix (reflection.reflection <prefix>))
- (|> ///bundle.empty
- (///bundle.install "+" (//lux.binary <type> <type> <type>))
- (///bundle.install "-" (//lux.binary <type> <type> <type>))
- (///bundle.install "*" (//lux.binary <type> <type> <type>))
- (///bundle.install "/" (//lux.binary <type> <type> <type>))
- (///bundle.install "%" (//lux.binary <type> <type> <type>))
- (///bundle.install "=" (//lux.binary <type> <type> Bit))
- (///bundle.install "<" (//lux.binary <type> <type> Bit))
- )))]
-
- [bundle::float reflection.float ..float]
- [bundle::double reflection.double ..double]
- )
-
-(def: bundle::char
- Bundle
- (<| (///bundle.prefix (reflection.reflection reflection.char))
- (|> ///bundle.empty
- (///bundle.install "=" (//lux.binary ..char ..char Bit))
- (///bundle.install "<" (//lux.binary ..char ..char Bit))
- )))
-
-(def: #export boxes
- (Dictionary External [External (Type Primitive)])
- (|> (list [(reflection.reflection reflection.boolean) [box.boolean jvm.boolean]]
- [(reflection.reflection reflection.byte) [box.byte jvm.byte]]
- [(reflection.reflection reflection.short) [box.short jvm.short]]
- [(reflection.reflection reflection.int) [box.int jvm.int]]
- [(reflection.reflection reflection.long) [box.long jvm.long]]
- [(reflection.reflection reflection.float) [box.float jvm.float]]
- [(reflection.reflection reflection.double) [box.double jvm.double]]
- [(reflection.reflection reflection.char) [box.char jvm.char]])
- (dictionary.from_list text.hash)))
-
-(def: (jvm_type luxT)
- (-> .Type (Operation (Type Value)))
- (case luxT
- (#.Named name anonymousT)
- (jvm_type anonymousT)
-
- (#.Apply inputT abstractionT)
- (case (type.apply (list inputT) abstractionT)
- (#.Some outputT)
- (jvm_type outputT)
-
- #.None
- (/////analysis.throw ..non_jvm_type luxT))
-
- (^ (#.Primitive (static array.type_name) (list elemT)))
- (phase\map jvm.array (jvm_type elemT))
-
- (#.Primitive class parametersT)
- (case (dictionary.get class ..boxes)
- (#.Some [_ primitive_type])
- (case parametersT
- #.Nil
- (phase\wrap primitive_type)
-
- _
- (/////analysis.throw ..primitives_cannot_have_type_parameters class))
-
- #.None
- (do {! phase.monad}
- [parametersJT (: (Operation (List (Type Parameter)))
- (monad.map !
- (function (_ parameterT)
- (do phase.monad
- [parameterJT (jvm_type parameterT)]
- (case (jvm_parser.parameter? parameterJT)
- (#.Some parameterJT)
- (wrap parameterJT)
-
- #.None
- (/////analysis.throw ..non_parameter parameterT))))
- parametersT))]
- (wrap (jvm.class class parametersJT))))
-
- (#.Ex _)
- (phase\wrap (jvm.class ..object_class (list)))
-
- _
- (/////analysis.throw ..non_jvm_type luxT)))
-
-(def: (jvm_array_type objectT)
- (-> .Type (Operation (Type Array)))
- (do phase.monad
- [objectJ (jvm_type objectT)]
- (|> objectJ
- ..signature
- (<text>.run jvm_parser.array)
- phase.lift)))
-
-(def: (primitive_array_length_handler primitive_type)
- (-> (Type Primitive) Handler)
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list arrayC))
- (do phase.monad
- [_ (typeA.infer ..int)
- arrayA (typeA.with_type (#.Primitive (|> (jvm.array primitive_type)
- ..reflection)
- (list))
- (analyse archive arrayC))]
- (wrap (#/////analysis.Extension extension_name (list arrayA))))
-
- _
- (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
-
-(def: array::length::object
- Handler
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list arrayC))
- (do phase.monad
- [_ (typeA.infer ..int)
- [var_id varT] (typeA.with_env check.var)
- arrayA (typeA.with_type (.type (array.Array varT))
- (analyse archive arrayC))
- varT (typeA.with_env (check.clean varT))
- arrayJT (jvm_array_type (.type (array.Array varT)))]
- (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature arrayJT))
- arrayA))))
-
- _
- (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
-
-(def: (new_primitive_array_handler primitive_type)
- (-> (Type Primitive) Handler)
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list lengthC))
- (do phase.monad
- [lengthA (typeA.with_type ..int
- (analyse archive lengthC))
- _ (typeA.infer (#.Primitive (|> (jvm.array primitive_type) ..reflection)
- (list)))]
- (wrap (#/////analysis.Extension extension_name (list lengthA))))
-
- _
- (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
-
-(def: array::new::object
- Handler
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list lengthC))
- (do phase.monad
- [lengthA (typeA.with_type ..int
- (analyse archive lengthC))
- expectedT (///.lift meta.expected_type)
- expectedJT (jvm_array_type expectedT)
- elementJT (case (jvm_parser.array? expectedJT)
- (#.Some elementJT)
- (wrap elementJT)
-
- #.None
- (/////analysis.throw ..non_array expectedT))]
- (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature elementJT))
- lengthA))))
-
- _
- (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
-
-(def: (check_parameter objectT)
- (-> .Type (Operation (Type Parameter)))
- (case objectT
- (^ (#.Primitive (static array.type_name)
- (list elementT)))
- (/////analysis.throw ..non_parameter objectT)
-
- (#.Primitive name parameters)
- (`` (cond (or (~~ (template [<type>]
- [(text\= (..reflection <type>) name)]
-
- [jvm.boolean]
- [jvm.byte]
- [jvm.short]
- [jvm.int]
- [jvm.long]
- [jvm.float]
- [jvm.double]
- [jvm.char]))
- (text.starts_with? descriptor.array_prefix name))
- (/////analysis.throw ..non_parameter objectT)
-
- ## else
- (phase\wrap (jvm.class name (list)))))
-
- (#.Named name anonymous)
- (check_parameter anonymous)
-
- (^template [<tag>]
- [(<tag> id)
- (phase\wrap (jvm.class ..object_class (list)))])
- ([#.Var]
- [#.Ex])
-
- (^template [<tag>]
- [(<tag> env unquantified)
- (check_parameter unquantified)])
- ([#.UnivQ]
- [#.ExQ])
-
- (#.Apply inputT abstractionT)
- (case (type.apply (list inputT) abstractionT)
- (#.Some outputT)
- (check_parameter outputT)
-
- #.None
- (/////analysis.throw ..non_parameter objectT))
-
- _
- (/////analysis.throw ..non_parameter objectT)))
-
-(def: (check_jvm objectT)
- (-> .Type (Operation (Type Value)))
- (case objectT
- (#.Primitive name #.Nil)
- (`` (cond (~~ (template [<type>]
- [(text\= (..reflection <type>) name)
- (phase\wrap <type>)]
-
- [jvm.boolean]
- [jvm.byte]
- [jvm.short]
- [jvm.int]
- [jvm.long]
- [jvm.float]
- [jvm.double]
- [jvm.char]))
-
- (~~ (template [<type>]
- [(text\= (..reflection (jvm.array <type>)) name)
- (phase\wrap (jvm.array <type>))]
-
- [jvm.boolean]
- [jvm.byte]
- [jvm.short]
- [jvm.int]
- [jvm.long]
- [jvm.float]
- [jvm.double]
- [jvm.char]))
-
- (text.starts_with? descriptor.array_prefix name)
- (let [[_ unprefixed] (maybe.assume (text.split_with descriptor.array_prefix name))]
- (\ phase.monad map jvm.array
- (check_jvm (#.Primitive unprefixed (list)))))
-
- ## else
- (phase\wrap (jvm.class name (list)))))
-
- (^ (#.Primitive (static array.type_name)
- (list elementT)))
- (|> elementT
- check_jvm
- (phase\map jvm.array))
-
- (#.Primitive name parameters)
- (do {! phase.monad}
- [parameters (monad.map ! check_parameter parameters)]
- (phase\wrap (jvm.class name parameters)))
-
- (#.Named name anonymous)
- (check_jvm anonymous)
-
- (^template [<tag>]
- [(<tag> env unquantified)
- (check_jvm unquantified)])
- ([#.UnivQ]
- [#.ExQ])
-
- (#.Apply inputT abstractionT)
- (case (type.apply (list inputT) abstractionT)
- (#.Some outputT)
- (check_jvm outputT)
-
- #.None
- (/////analysis.throw ..non_object objectT))
-
- _
- (check_parameter objectT)))
-
-(def: (check_object objectT)
- (-> .Type (Operation External))
- (do {! phase.monad}
- [name (\ ! map ..reflection (check_jvm objectT))]
- (if (dictionary.key? ..boxes name)
- (/////analysis.throw ..primitives_are_not_objects [name])
- (phase\wrap name))))
-
-(def: (check_return type)
- (-> .Type (Operation (Type Return)))
- (if (is? .Any type)
- (phase\wrap jvm.void)
- (check_jvm type)))
-
-(def: (read_primitive_array_handler lux_type jvm_type)
- (-> .Type (Type Primitive) Handler)
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list idxC arrayC))
- (do phase.monad
- [_ (typeA.infer lux_type)
- idxA (typeA.with_type ..int
- (analyse archive idxC))
- arrayA (typeA.with_type (#.Primitive (|> (jvm.array jvm_type) ..reflection)
- (list))
- (analyse archive arrayC))]
- (wrap (#/////analysis.Extension extension_name (list idxA arrayA))))
-
- _
- (/////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)]))))
-
-(def: array::read::object
- Handler
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list idxC arrayC))
- (do phase.monad
- [[var_id varT] (typeA.with_env check.var)
- _ (typeA.infer varT)
- arrayA (typeA.with_type (.type (array.Array varT))
- (analyse archive arrayC))
- varT (typeA.with_env
- (check.clean varT))
- arrayJT (jvm_array_type (.type (array.Array varT)))
- idxA (typeA.with_type ..int
- (analyse archive idxC))]
- (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature arrayJT))
- idxA
- arrayA))))
-
- _
- (/////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)]))))
-
-(def: (write_primitive_array_handler lux_type jvm_type)
- (-> .Type (Type Primitive) Handler)
- (let [array_type (#.Primitive (|> (jvm.array jvm_type) ..reflection)
- (list))]
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list idxC valueC arrayC))
- (do phase.monad
- [_ (typeA.infer array_type)
- idxA (typeA.with_type ..int
- (analyse archive idxC))
- valueA (typeA.with_type lux_type
- (analyse archive valueC))
- arrayA (typeA.with_type array_type
- (analyse archive arrayC))]
- (wrap (#/////analysis.Extension extension_name (list idxA
- valueA
- arrayA))))
-
- _
- (/////analysis.throw ///.incorrect_arity [extension_name 3 (list.size args)])))))
-
-(def: array::write::object
- Handler
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list idxC valueC arrayC))
- (do phase.monad
- [[var_id varT] (typeA.with_env check.var)
- _ (typeA.infer (.type (array.Array varT)))
- arrayA (typeA.with_type (.type (array.Array varT))
- (analyse archive arrayC))
- varT (typeA.with_env
- (check.clean varT))
- arrayJT (jvm_array_type (.type (array.Array varT)))
- idxA (typeA.with_type ..int
- (analyse archive idxC))
- valueA (typeA.with_type varT
- (analyse archive valueC))]
- (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature arrayJT))
- idxA
- valueA
- arrayA))))
-
- _
- (/////analysis.throw ///.incorrect_arity [extension_name 3 (list.size args)]))))
-
-(def: bundle::array
- Bundle
- (<| (///bundle.prefix "array")
- (|> ///bundle.empty
- (dictionary.merge (<| (///bundle.prefix "length")
- (|> ///bundle.empty
- (///bundle.install (reflection.reflection reflection.boolean) (primitive_array_length_handler jvm.boolean))
- (///bundle.install (reflection.reflection reflection.byte) (primitive_array_length_handler jvm.byte))
- (///bundle.install (reflection.reflection reflection.short) (primitive_array_length_handler jvm.short))
- (///bundle.install (reflection.reflection reflection.int) (primitive_array_length_handler jvm.int))
- (///bundle.install (reflection.reflection reflection.long) (primitive_array_length_handler jvm.long))
- (///bundle.install (reflection.reflection reflection.float) (primitive_array_length_handler jvm.float))
- (///bundle.install (reflection.reflection reflection.double) (primitive_array_length_handler jvm.double))
- (///bundle.install (reflection.reflection reflection.char) (primitive_array_length_handler jvm.char))
- (///bundle.install "object" array::length::object))))
- (dictionary.merge (<| (///bundle.prefix "new")
- (|> ///bundle.empty
- (///bundle.install (reflection.reflection reflection.boolean) (new_primitive_array_handler jvm.boolean))
- (///bundle.install (reflection.reflection reflection.byte) (new_primitive_array_handler jvm.byte))
- (///bundle.install (reflection.reflection reflection.short) (new_primitive_array_handler jvm.short))
- (///bundle.install (reflection.reflection reflection.int) (new_primitive_array_handler jvm.int))
- (///bundle.install (reflection.reflection reflection.long) (new_primitive_array_handler jvm.long))
- (///bundle.install (reflection.reflection reflection.float) (new_primitive_array_handler jvm.float))
- (///bundle.install (reflection.reflection reflection.double) (new_primitive_array_handler jvm.double))
- (///bundle.install (reflection.reflection reflection.char) (new_primitive_array_handler jvm.char))
- (///bundle.install "object" array::new::object))))
- (dictionary.merge (<| (///bundle.prefix "read")
- (|> ///bundle.empty
- (///bundle.install (reflection.reflection reflection.boolean) (read_primitive_array_handler ..boolean jvm.boolean))
- (///bundle.install (reflection.reflection reflection.byte) (read_primitive_array_handler ..byte jvm.byte))
- (///bundle.install (reflection.reflection reflection.short) (read_primitive_array_handler ..short jvm.short))
- (///bundle.install (reflection.reflection reflection.int) (read_primitive_array_handler ..int jvm.int))
- (///bundle.install (reflection.reflection reflection.long) (read_primitive_array_handler ..long jvm.long))
- (///bundle.install (reflection.reflection reflection.float) (read_primitive_array_handler ..float jvm.float))
- (///bundle.install (reflection.reflection reflection.double) (read_primitive_array_handler ..double jvm.double))
- (///bundle.install (reflection.reflection reflection.char) (read_primitive_array_handler ..char jvm.char))
- (///bundle.install "object" array::read::object))))
- (dictionary.merge (<| (///bundle.prefix "write")
- (|> ///bundle.empty
- (///bundle.install (reflection.reflection reflection.boolean) (write_primitive_array_handler ..boolean jvm.boolean))
- (///bundle.install (reflection.reflection reflection.byte) (write_primitive_array_handler ..byte jvm.byte))
- (///bundle.install (reflection.reflection reflection.short) (write_primitive_array_handler ..short jvm.short))
- (///bundle.install (reflection.reflection reflection.int) (write_primitive_array_handler ..int jvm.int))
- (///bundle.install (reflection.reflection reflection.long) (write_primitive_array_handler ..long jvm.long))
- (///bundle.install (reflection.reflection reflection.float) (write_primitive_array_handler ..float jvm.float))
- (///bundle.install (reflection.reflection reflection.double) (write_primitive_array_handler ..double jvm.double))
- (///bundle.install (reflection.reflection reflection.char) (write_primitive_array_handler ..char jvm.char))
- (///bundle.install "object" array::write::object))))
- )))
-
-(def: object::null
- Handler
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list))
- (do phase.monad
- [expectedT (///.lift meta.expected_type)
- _ (check_object expectedT)]
- (wrap (#/////analysis.Extension extension_name (list))))
-
- _
- (/////analysis.throw ///.incorrect_arity [extension_name 0 (list.size args)]))))
-
-(def: object::null?
- Handler
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list objectC))
- (do phase.monad
- [_ (typeA.infer Bit)
- [objectT objectA] (typeA.with_inference
- (analyse archive objectC))
- _ (check_object objectT)]
- (wrap (#/////analysis.Extension extension_name (list objectA))))
-
- _
- (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
-
-(def: object::synchronized
- Handler
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list monitorC exprC))
- (do phase.monad
- [[monitorT monitorA] (typeA.with_inference
- (analyse archive monitorC))
- _ (check_object monitorT)
- exprA (analyse archive exprC)]
- (wrap (#/////analysis.Extension extension_name (list monitorA exprA))))
-
- _
- (/////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)]))))
-
-(def: object::throw
- Handler
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list exceptionC))
- (do phase.monad
- [_ (typeA.infer Nothing)
- [exceptionT exceptionA] (typeA.with_inference
- (analyse archive exceptionC))
- exception_class (check_object exceptionT)
- ? (phase.lift (reflection!.sub? "java.lang.Throwable" exception_class))
- _ (: (Operation Any)
- (if ?
- (wrap [])
- (/////analysis.throw non_throwable exception_class)))]
- (wrap (#/////analysis.Extension extension_name (list exceptionA))))
-
- _
- (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
-
-(def: object::class
- Handler
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list classC))
- (case classC
- [_ (#.Text class)]
- (do phase.monad
- [_ (..ensure_fresh_class! class)
- _ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list)))))
- _ (phase.lift (reflection!.load class))]
- (wrap (#/////analysis.Extension extension_name (list (/////analysis.text class)))))
-
- _
- (/////analysis.throw ///.invalid_syntax [extension_name %.code args]))
-
- _
- (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
-
-(def: object::instance?
- Handler
- (..custom
- [($_ <>.and <code>.text <code>.any)
- (function (_ extension_name analyse archive [sub_class objectC])
- (do phase.monad
- [_ (..ensure_fresh_class! sub_class)
- _ (typeA.infer Bit)
- [objectT objectA] (typeA.with_inference
- (analyse archive objectC))
- object_class (check_object objectT)
- ? (phase.lift (reflection!.sub? object_class sub_class))]
- (if ?
- (wrap (#/////analysis.Extension extension_name (list (/////analysis.text sub_class) objectA)))
- (/////analysis.throw cannot_possibly_be_an_instance (format sub_class " !<= " object_class)))))]))
-
-(template [<name> <category> <parser>]
- [(def: (<name> mapping typeJ)
- (-> Mapping (Type <category>) (Operation .Type))
- (case (|> typeJ ..signature (<text>.run (<parser> mapping)))
- (#try.Success check)
- (typeA.with_env
- check)
-
- (#try.Failure error)
- (phase.fail error)))]
-
- [reflection_type Value luxT.type]
- [reflection_return Return luxT.return]
- )
-
-(def: (class_candidate_parents from_name fromT to_name to_class)
- (-> External .Type External (java/lang/Class java/lang/Object) (Operation (List [[Text .Type] Bit])))
- (do {! phase.monad}
- [from_class (phase.lift (reflection!.load from_name))
- mapping (phase.lift (reflection!.correspond from_class fromT))]
- (monad.map !
- (function (_ superJT)
- (do !
- [superJT (phase.lift (reflection!.type superJT))
- #let [super_name (|> superJT ..reflection)]
- super_class (phase.lift (reflection!.load super_name))
- superT (reflection_type mapping superJT)]
- (wrap [[super_name superT] (java/lang/Class::isAssignableFrom super_class to_class)])))
- (case (java/lang/Class::getGenericSuperclass from_class)
- (#.Some super)
- (list& super (array.to_list (java/lang/Class::getGenericInterfaces from_class)))
-
- #.None
- (if (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers from_class))
- (#.Cons (:as java/lang/reflect/Type (ffi.class_for java/lang/Object))
- (array.to_list (java/lang/Class::getGenericInterfaces from_class)))
- (array.to_list (java/lang/Class::getGenericInterfaces from_class)))))))
-
-(def: (inheritance_candidate_parents fromT to_class toT fromC)
- (-> .Type (java/lang/Class java/lang/Object) .Type Code (Operation (List [[Text .Type] Bit])))
- (case fromT
- (^ (#.Primitive _ (list& self_classT super_classT super_interfacesT+)))
- (monad.map phase.monad
- (function (_ superT)
- (do {! phase.monad}
- [super_name (\ ! map ..reflection (check_jvm superT))
- super_class (phase.lift (reflection!.load super_name))]
- (wrap [[super_name superT]
- (java/lang/Class::isAssignableFrom super_class to_class)])))
- (list& super_classT super_interfacesT+))
-
- _
- (/////analysis.throw ..cannot_cast [fromT toT fromC])))
-
-(def: object::cast
- Handler
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list fromC))
- (do {! phase.monad}
- [toT (///.lift meta.expected_type)
- to_name (\ ! map ..reflection (check_jvm toT))
- [fromT fromA] (typeA.with_inference
- (analyse archive fromC))
- from_name (\ ! map ..reflection (check_jvm fromT))
- can_cast? (: (Operation Bit)
- (`` (cond (~~ (template [<primitive> <object>]
- [(let [=primitive (reflection.reflection <primitive>)]
- (or (and (text\= =primitive from_name)
- (or (text\= <object> to_name)
- (text\= =primitive to_name)))
- (and (text\= <object> from_name)
- (text\= =primitive to_name))))
- (wrap true)]
-
- [reflection.boolean box.boolean]
- [reflection.byte box.byte]
- [reflection.short box.short]
- [reflection.int box.int]
- [reflection.long box.long]
- [reflection.float box.float]
- [reflection.double box.double]
- [reflection.char box.char]))
-
- ## else
- (do !
- [_ (phase.assert ..primitives_are_not_objects [from_name]
- (not (dictionary.key? ..boxes from_name)))
- _ (phase.assert ..primitives_are_not_objects [to_name]
- (not (dictionary.key? ..boxes to_name)))
- to_class (phase.lift (reflection!.load to_name))
- _ (if (text\= ..inheritance_relationship_type_name from_name)
- (wrap [])
- (do !
- [from_class (phase.lift (reflection!.load from_name))]
- (phase.assert ..cannot_cast [fromT toT fromC]
- (java/lang/Class::isAssignableFrom from_class to_class))))]
- (loop [[current_name currentT] [from_name fromT]]
- (if (text\= to_name current_name)
- (wrap true)
- (do !
- [candidate_parents (: (Operation (List [[Text .Type] Bit]))
- (if (text\= ..inheritance_relationship_type_name current_name)
- (inheritance_candidate_parents currentT to_class toT fromC)
- (class_candidate_parents current_name currentT to_name to_class)))]
- (case (|> candidate_parents
- (list.filter product.right)
- (list\map product.left))
- (#.Cons [next_name nextT] _)
- (recur [next_name nextT])
-
- #.Nil
- (wrap false)))))))))]
- (if can_cast?
- (wrap (#/////analysis.Extension extension_name (list (/////analysis.text from_name)
- (/////analysis.text to_name)
- fromA)))
- (/////analysis.throw ..cannot_cast [fromT toT fromC])))
-
- _
- (/////analysis.throw ///.invalid_syntax [extension_name %.code args]))))
-
-(def: bundle::object
- Bundle
- (<| (///bundle.prefix "object")
- (|> ///bundle.empty
- (///bundle.install "null" object::null)
- (///bundle.install "null?" object::null?)
- (///bundle.install "synchronized" object::synchronized)
- (///bundle.install "throw" object::throw)
- (///bundle.install "class" object::class)
- (///bundle.install "instance?" object::instance?)
- (///bundle.install "cast" object::cast)
- )))
-
-(def: get::static
- Handler
- (..custom
- [..member
- (function (_ extension_name analyse archive [class field])
- (do phase.monad
- [_ (..ensure_fresh_class! class)
- [final? deprecated? fieldJT] (phase.lift
- (do try.monad
- [class (reflection!.load class)]
- (reflection!.static_field field class)))
- _ (phase.assert ..deprecated_field [class field]
- (not deprecated?))
- fieldT (reflection_type luxT.fresh fieldJT)
- _ (typeA.infer fieldT)]
- (wrap (<| (#/////analysis.Extension extension_name)
- (list (/////analysis.text class)
- (/////analysis.text field)
- (/////analysis.text (|> fieldJT ..reflection)))))))]))
-
-(def: put::static
- Handler
- (..custom
- [($_ <>.and ..member <code>.any)
- (function (_ extension_name analyse archive [[class field] valueC])
- (do phase.monad
- [_ (..ensure_fresh_class! class)
- _ (typeA.infer Any)
- [final? deprecated? fieldJT] (phase.lift
- (do try.monad
- [class (reflection!.load class)]
- (reflection!.static_field field class)))
- _ (phase.assert ..deprecated_field [class field]
- (not deprecated?))
- _ (phase.assert ..cannot_set_a_final_field [class field]
- (not final?))
- fieldT (reflection_type luxT.fresh fieldJT)
- valueA (typeA.with_type fieldT
- (analyse archive valueC))]
- (wrap (<| (#/////analysis.Extension extension_name)
- (list (/////analysis.text class)
- (/////analysis.text field)
- valueA)))))]))
-
-(def: get::virtual
- Handler
- (..custom
- [($_ <>.and ..member <code>.any)
- (function (_ extension_name analyse archive [[class field] objectC])
- (do phase.monad
- [_ (..ensure_fresh_class! class)
- [objectT objectA] (typeA.with_inference
- (analyse archive objectC))
- [deprecated? mapping fieldJT] (phase.lift
- (do try.monad
- [class (reflection!.load class)
- [final? deprecated? fieldJT] (reflection!.virtual_field field class)
- mapping (reflection!.correspond class objectT)]
- (wrap [deprecated? mapping fieldJT])))
- _ (phase.assert ..deprecated_field [class field]
- (not deprecated?))
- fieldT (reflection_type mapping fieldJT)
- _ (typeA.infer fieldT)]
- (wrap (<| (#/////analysis.Extension extension_name)
- (list (/////analysis.text class)
- (/////analysis.text field)
- objectA)))))]))
-
-(def: put::virtual
- Handler
- (..custom
- [($_ <>.and ..member <code>.any <code>.any)
- (function (_ extension_name analyse archive [[class field] valueC objectC])
- (do phase.monad
- [_ (..ensure_fresh_class! class)
- [objectT objectA] (typeA.with_inference
- (analyse archive objectC))
- _ (typeA.infer objectT)
- [final? deprecated? mapping fieldJT] (phase.lift
- (do try.monad
- [class (reflection!.load class)
- [final? deprecated? fieldJT] (reflection!.virtual_field field class)
- mapping (reflection!.correspond class objectT)]
- (wrap [final? deprecated? mapping fieldJT])))
- _ (phase.assert ..deprecated_field [class field]
- (not deprecated?))
- _ (phase.assert ..cannot_set_a_final_field [class field]
- (not final?))
- fieldT (reflection_type mapping fieldJT)
- valueA (typeA.with_type fieldT
- (analyse archive valueC))]
- (wrap (<| (#/////analysis.Extension extension_name)
- (list (/////analysis.text class)
- (/////analysis.text field)
- valueA
- objectA)))))]))
-
-(type: Method_Style
- #Static
- #Abstract
- #Virtual
- #Special
- #Interface)
-
-(def: (check_method aliasing class method_name method_style inputsJT method)
- (-> Aliasing (java/lang/Class java/lang/Object) Text Method_Style (List (Type Value)) java/lang/reflect/Method (Operation Bit))
- (do phase.monad
- [parameters (|> (java/lang/reflect/Method::getGenericParameterTypes method)
- array.to_list
- (monad.map try.monad reflection!.type)
- phase.lift)
- #let [modifiers (java/lang/reflect/Method::getModifiers method)
- correct_class? (java/lang/Object::equals class (java/lang/reflect/Method::getDeclaringClass method))
- correct_method? (text\= method_name (java/lang/reflect/Method::getName method))
- static_matches? (case method_style
- #Static
- (java/lang/reflect/Modifier::isStatic modifiers)
-
- _
- true)
- special_matches? (case method_style
- #Special
- (not (or (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class))
- (java/lang/reflect/Modifier::isAbstract modifiers)))
-
- _
- true)
- arity_matches? (n.= (list.size inputsJT) (list.size parameters))
- inputs_match? (and arity_matches?
- (list\fold (function (_ [expectedJC actualJC] prev)
- (and prev
- (jvm\= expectedJC (: (Type Value)
- (case (jvm_parser.var? actualJC)
- (#.Some name)
- (|> aliasing
- (dictionary.get name)
- (maybe.default name)
- jvm.var)
-
- #.None
- actualJC)))))
- true
- (list.zip/2 parameters inputsJT)))]]
- (wrap (and correct_class?
- correct_method?
- static_matches?
- special_matches?
- arity_matches?
- inputs_match?))))
-
-(def: (check_constructor aliasing class inputsJT constructor)
- (-> Aliasing (java/lang/Class java/lang/Object) (List (Type Value)) (java/lang/reflect/Constructor java/lang/Object) (Operation Bit))
- (do phase.monad
- [parameters (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor)
- array.to_list
- (monad.map try.monad reflection!.type)
- phase.lift)]
- (wrap (and (java/lang/Object::equals class (java/lang/reflect/Constructor::getDeclaringClass constructor))
- (n.= (list.size inputsJT) (list.size parameters))
- (list\fold (function (_ [expectedJC actualJC] prev)
- (and prev
- (jvm\= expectedJC (: (Type Value)
- (case (jvm_parser.var? actualJC)
- (#.Some name)
- (|> aliasing
- (dictionary.get name)
- (maybe.default name)
- jvm.var)
-
- #.None
- actualJC)))))
- true
- (list.zip/2 parameters inputsJT))))))
-
-(def: idx_to_parameter
- (-> Nat .Type)
- (|>> (n.* 2) inc #.Parameter))
-
-(def: (jvm_type_var_mapping owner_tvars method_tvars)
- (-> (List Text) (List Text) [(List .Type) Mapping])
- (let [jvm_tvars (list\compose owner_tvars method_tvars)
- lux_tvars (|> jvm_tvars
- list.reverse
- list.enumeration
- (list\map (function (_ [idx name])
- [name (idx_to_parameter idx)]))
- list.reverse)
- num_owner_tvars (list.size owner_tvars)
- owner_tvarsT (|> lux_tvars (list.take num_owner_tvars) (list\map product.right))
- mapping (dictionary.from_list text.hash lux_tvars)]
- [owner_tvarsT mapping]))
-
-(def: (method_signature method_style method)
- (-> Method_Style java/lang/reflect/Method (Operation Method_Signature))
- (let [owner (java/lang/reflect/Method::getDeclaringClass method)
- owner_tvars (case method_style
- #Static
- (list)
-
- _
- (|> (java/lang/Class::getTypeParameters owner)
- array.to_list
- (list\map (|>> java/lang/reflect/TypeVariable::getName))))
- method_tvars (|> (java/lang/reflect/Method::getTypeParameters method)
- array.to_list
- (list\map (|>> java/lang/reflect/TypeVariable::getName)))
- [owner_tvarsT mapping] (jvm_type_var_mapping owner_tvars method_tvars)]
- (do {! phase.monad}
- [inputsT (|> (java/lang/reflect/Method::getGenericParameterTypes method)
- array.to_list
- (monad.map ! (|>> reflection!.type phase.lift))
- (phase\map (monad.map ! (..reflection_type mapping)))
- phase\join)
- outputT (|> method
- java/lang/reflect/Method::getGenericReturnType
- reflection!.return
- phase.lift
- (phase\map (..reflection_return mapping))
- phase\join)
- exceptionsT (|> (java/lang/reflect/Method::getGenericExceptionTypes method)
- array.to_list
- (monad.map ! (|>> reflection!.type phase.lift))
- (phase\map (monad.map ! (..reflection_type mapping)))
- phase\join)
- #let [methodT (<| (type.univ_q (dictionary.size mapping))
- (type.function (case method_style
- #Static
- inputsT
-
- _
- (list& (#.Primitive (java/lang/Class::getName owner) owner_tvarsT)
- inputsT)))
- outputT)]]
- (wrap [methodT
- (reflection!.deprecated? (java/lang/reflect/Method::getDeclaredAnnotations method))
- exceptionsT]))))
-
-(def: (constructor_signature constructor)
- (-> (java/lang/reflect/Constructor java/lang/Object) (Operation Method_Signature))
- (let [owner (java/lang/reflect/Constructor::getDeclaringClass constructor)
- owner_tvars (|> (java/lang/Class::getTypeParameters owner)
- array.to_list
- (list\map (|>> java/lang/reflect/TypeVariable::getName)))
- method_tvars (|> (java/lang/reflect/Constructor::getTypeParameters constructor)
- array.to_list
- (list\map (|>> java/lang/reflect/TypeVariable::getName)))
- [owner_tvarsT mapping] (jvm_type_var_mapping owner_tvars method_tvars)]
- (do {! phase.monad}
- [inputsT (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor)
- array.to_list
- (monad.map ! (|>> reflection!.type phase.lift))
- (phase\map (monad.map ! (reflection_type mapping)))
- phase\join)
- exceptionsT (|> (java/lang/reflect/Constructor::getGenericExceptionTypes constructor)
- array.to_list
- (monad.map ! (|>> reflection!.type phase.lift))
- (phase\map (monad.map ! (reflection_type mapping)))
- phase\join)
- #let [objectT (#.Primitive (java/lang/Class::getName owner) owner_tvarsT)
- constructorT (<| (type.univ_q (dictionary.size mapping))
- (type.function inputsT)
- objectT)]]
- (wrap [constructorT
- (reflection!.deprecated? (java/lang/reflect/Constructor::getDeclaredAnnotations constructor))
- exceptionsT]))))
-
-(type: Evaluation
- (#Pass Method_Signature)
- (#Hint Method_Signature))
-
-(template [<name> <tag>]
- [(def: <name>
- (-> Evaluation (Maybe Method_Signature))
- (|>> (case> (<tag> output)
- (#.Some output)
-
- _
- #.None)))]
-
- [pass! #Pass]
- [hint! #Hint]
- )
-
-(template [<name> <type> <method>]
- [(def: <name>
- (-> <type> (List (Type Var)))
- (|>> <method>
- array.to_list
- (list\map (|>> java/lang/reflect/TypeVariable::getName jvm.var))))]
-
- [class_type_variables (java/lang/Class java/lang/Object) java/lang/Class::getTypeParameters]
- [constructor_type_variables (java/lang/reflect/Constructor java/lang/Object) java/lang/reflect/Constructor::getTypeParameters]
- [method_type_variables java/lang/reflect/Method java/lang/reflect/Method::getTypeParameters]
- )
-
-(def: (aliasing expected actual)
- (-> (List (Type Var)) (List (Type Var)) Aliasing)
- (|> (list.zip/2 (list\map jvm_parser.name actual)
- (list\map jvm_parser.name expected))
- (dictionary.from_list text.hash)))
-
-(def: (method_candidate actual_class_tvars class_name actual_method_tvars method_name method_style inputsJT)
- (-> (List (Type Var)) External (List (Type Var)) Text Method_Style (List (Type Value)) (Operation Method_Signature))
- (do {! phase.monad}
- [class (phase.lift (reflection!.load class_name))
- #let [expected_class_tvars (class_type_variables class)]
- candidates (|> class
- java/lang/Class::getDeclaredMethods
- array.to_list
- (list.filter (|>> java/lang/reflect/Method::getName (text\= method_name)))
- (monad.map ! (: (-> java/lang/reflect/Method (Operation Evaluation))
- (function (_ method)
- (do !
- [#let [expected_method_tvars (method_type_variables method)
- aliasing (dictionary.merge (..aliasing expected_class_tvars actual_class_tvars)
- (..aliasing expected_method_tvars actual_method_tvars))]
- passes? (check_method aliasing class method_name method_style inputsJT method)]
- (\ ! map (if passes?
- (|>> #Pass)
- (|>> #Hint))
- (method_signature method_style method)))))))]
- (case (list.all pass! candidates)
- (#.Cons method #.Nil)
- (wrap method)
-
- #.Nil
- (/////analysis.throw ..no_candidates [class_name method_name inputsJT (list.all hint! candidates)])
-
- candidates
- (/////analysis.throw ..too_many_candidates [class_name method_name inputsJT candidates]))))
-
-(def: constructor_method
- "<init>")
-
-(def: (constructor_candidate actual_class_tvars class_name actual_method_tvars inputsJT)
- (-> (List (Type Var)) External (List (Type Var)) (List (Type Value)) (Operation Method_Signature))
- (do {! phase.monad}
- [class (phase.lift (reflection!.load class_name))
- #let [expected_class_tvars (class_type_variables class)]
- candidates (|> class
- java/lang/Class::getConstructors
- array.to_list
- (monad.map ! (function (_ constructor)
- (do !
- [#let [expected_method_tvars (constructor_type_variables constructor)
- aliasing (dictionary.merge (..aliasing expected_class_tvars actual_class_tvars)
- (..aliasing expected_method_tvars actual_method_tvars))]
- passes? (check_constructor aliasing class inputsJT constructor)]
- (\ ! map
- (if passes? (|>> #Pass) (|>> #Hint))
- (constructor_signature constructor))))))]
- (case (list.all pass! candidates)
- (#.Cons constructor #.Nil)
- (wrap constructor)
-
- #.Nil
- (/////analysis.throw ..no_candidates [class_name ..constructor_method inputsJT (list.all hint! candidates)])
-
- candidates
- (/////analysis.throw ..too_many_candidates [class_name ..constructor_method inputsJT candidates]))))
-
-(template [<name> <category> <parser>]
- [(def: #export <name>
- (Parser (Type <category>))
- (<text>.embed <parser> <code>.text))]
-
- [var Var jvm_parser.var]
- [class Class jvm_parser.class]
- [type Value jvm_parser.value]
- [return Return jvm_parser.return]
- )
-
-(def: input
- (Parser (Typed Code))
- (<code>.tuple (<>.and ..type <code>.any)))
-
-(def: (decorate_inputs typesT inputsA)
- (-> (List (Type Value)) (List Analysis) (List Analysis))
- (|> inputsA
- (list.zip/2 (list\map (|>> ..signature /////analysis.text) typesT))
- (list\map (function (_ [type value])
- (/////analysis.tuple (list type value))))))
-
-(def: type_vars
- (<code>.tuple (<>.some ..var)))
-
-(def: invoke::static
- Handler
- (..custom
- [($_ <>.and ..type_vars ..member ..type_vars (<>.some ..input))
- (function (_ extension_name analyse archive [class_tvars [class method] method_tvars argsTC])
- (do phase.monad
- [_ (..ensure_fresh_class! class)
- #let [argsT (list\map product.left argsTC)]
- [methodT deprecated? exceptionsT] (..method_candidate class_tvars class method_tvars method #Static argsT)
- _ (phase.assert ..deprecated_method [class method methodT]
- (not deprecated?))
- [outputT argsA] (inferenceA.general archive analyse methodT (list\map product.right argsTC))
- outputJT (check_return outputT)]
- (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list))))
- (/////analysis.text method)
- (/////analysis.text (..signature outputJT))
- (decorate_inputs argsT argsA))))))]))
-
-(def: invoke::virtual
- Handler
- (..custom
- [($_ <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input))
- (function (_ extension_name analyse archive [class_tvars [class method] method_tvars objectC argsTC])
- (do phase.monad
- [_ (..ensure_fresh_class! class)
- #let [argsT (list\map product.left argsTC)]
- [methodT deprecated? exceptionsT] (..method_candidate class_tvars class method_tvars method #Virtual argsT)
- _ (phase.assert ..deprecated_method [class method methodT]
- (not deprecated?))
- [outputT allA] (inferenceA.general archive analyse methodT (list& objectC (list\map product.right argsTC)))
- #let [[objectA argsA] (case allA
- (#.Cons objectA argsA)
- [objectA argsA]
-
- _
- (undefined))]
- outputJT (check_return outputT)]
- (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list))))
- (/////analysis.text method)
- (/////analysis.text (..signature outputJT))
- objectA
- (decorate_inputs argsT argsA))))))]))
-
-(def: invoke::special
- Handler
- (..custom
- [($_ <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input))
- (function (_ extension_name analyse archive [class_tvars [class method] method_tvars objectC argsTC])
- (do phase.monad
- [_ (..ensure_fresh_class! class)
- #let [argsT (list\map product.left argsTC)]
- [methodT deprecated? exceptionsT] (..method_candidate class_tvars class method_tvars method #Special argsT)
- _ (phase.assert ..deprecated_method [class method methodT]
- (not deprecated?))
- [outputT argsA] (inferenceA.general archive analyse methodT (list& objectC (list\map product.right argsTC)))
- outputJT (check_return outputT)]
- (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list))))
- (/////analysis.text method)
- (/////analysis.text (..signature outputJT))
- (decorate_inputs argsT argsA))))))]))
-
-(def: invoke::interface
- Handler
- (..custom
- [($_ <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input))
- (function (_ extension_name analyse archive [class_tvars [class_name method] method_tvars objectC argsTC])
- (do phase.monad
- [_ (..ensure_fresh_class! class_name)
- #let [argsT (list\map product.left argsTC)]
- class (phase.lift (reflection!.load class_name))
- _ (phase.assert non_interface class_name
- (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class)))
- [methodT deprecated? exceptionsT] (..method_candidate class_tvars class_name method_tvars method #Interface argsT)
- _ (phase.assert ..deprecated_method [class_name method methodT]
- (not deprecated?))
- [outputT allA] (inferenceA.general archive analyse methodT (list& objectC (list\map product.right argsTC)))
- #let [[objectA argsA] (case allA
- (#.Cons objectA argsA)
- [objectA argsA]
-
- _
- (undefined))]
- outputJT (check_return outputT)]
- (wrap (#/////analysis.Extension extension_name
- (list& (/////analysis.text (..signature (jvm.class class_name (list))))
- (/////analysis.text method)
- (/////analysis.text (..signature outputJT))
- objectA
- (decorate_inputs argsT argsA))))))]))
-
-(def: invoke::constructor
- (..custom
- [($_ <>.and ..type_vars <code>.text ..type_vars (<>.some ..input))
- (function (_ extension_name analyse archive [class_tvars class method_tvars argsTC])
- (do phase.monad
- [_ (..ensure_fresh_class! class)
- #let [argsT (list\map product.left argsTC)]
- [methodT deprecated? exceptionsT] (..constructor_candidate class_tvars class method_tvars argsT)
- _ (phase.assert ..deprecated_method [class ..constructor_method methodT]
- (not deprecated?))
- [outputT argsA] (inferenceA.general archive analyse methodT (list\map product.right argsTC))]
- (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list))))
- (decorate_inputs argsT argsA))))))]))
-
-(def: bundle::member
- Bundle
- (<| (///bundle.prefix "member")
- (|> ///bundle.empty
- (dictionary.merge (<| (///bundle.prefix "get")
- (|> ///bundle.empty
- (///bundle.install "static" get::static)
- (///bundle.install "virtual" get::virtual))))
- (dictionary.merge (<| (///bundle.prefix "put")
- (|> ///bundle.empty
- (///bundle.install "static" put::static)
- (///bundle.install "virtual" put::virtual))))
- (dictionary.merge (<| (///bundle.prefix "invoke")
- (|> ///bundle.empty
- (///bundle.install "static" invoke::static)
- (///bundle.install "virtual" invoke::virtual)
- (///bundle.install "special" invoke::special)
- (///bundle.install "interface" invoke::interface)
- (///bundle.install "constructor" invoke::constructor)
- )))
- )))
-
-(type: #export (Annotation_Parameter a)
- [Text a])
-
-(def: annotation_parameter
- (Parser (Annotation_Parameter Code))
- (<code>.tuple (<>.and <code>.text <code>.any)))
-
-(type: #export (Annotation a)
- [Text (List (Annotation_Parameter a))])
-
-(def: #export annotation
- (Parser (Annotation Code))
- (<code>.form (<>.and <code>.text (<>.some ..annotation_parameter))))
-
-(def: #export argument
- (Parser Argument)
- (<code>.tuple (<>.and <code>.text ..type)))
-
-(def: (annotation_parameter_analysis [name value])
- (-> (Annotation_Parameter Analysis) Analysis)
- (/////analysis.tuple (list (/////analysis.text name) value)))
-
-(def: (annotation_analysis [name parameters])
- (-> (Annotation Analysis) Analysis)
- (/////analysis.tuple (list& (/////analysis.text name)
- (list\map annotation_parameter_analysis parameters))))
-
-(template [<name> <category>]
- [(def: <name>
- (-> (Type <category>) Analysis)
- (|>> ..signature /////analysis.text))]
-
- [var_analysis Var]
- [class_analysis Class]
- [value_analysis Value]
- [return_analysis Return]
- )
-
-(def: (typed_analysis [type term])
- (-> (Typed Analysis) Analysis)
- (/////analysis.tuple (list (value_analysis type) term)))
-
-(def: (argument_analysis [argument argumentJT])
- (-> Argument Analysis)
- (/////analysis.tuple
- (list (/////analysis.text argument)
- (value_analysis argumentJT))))
-
-(template [<name> <filter>]
- [(def: <name>
- (-> (java/lang/Class java/lang/Object)
- (Try (List [Text (Type Method)])))
- (|>> java/lang/Class::getDeclaredMethods
- array.to_list
- <filter>
- (monad.map try.monad
- (function (_ method)
- (do {! try.monad}
- [inputs (|> (java/lang/reflect/Method::getGenericParameterTypes method)
- array.to_list
- (monad.map ! reflection!.type))
- return (|> method
- java/lang/reflect/Method::getGenericReturnType
- reflection!.return)
- exceptions (|> (java/lang/reflect/Method::getGenericExceptionTypes method)
- array.to_list
- (monad.map ! reflection!.class))]
- (wrap [(java/lang/reflect/Method::getName method)
- (jvm.method [inputs return exceptions])]))))))]
-
- [abstract_methods (list.filter (|>> java/lang/reflect/Method::getModifiers java/lang/reflect/Modifier::isAbstract))]
- [methods (<|)]
- )
-
-(def: jvm_package_separator ".")
-
-(template [<name> <methods>]
- [(def: <name>
- (-> (List (Type Class)) (Try (List [Text (Type Method)])))
- (|>> (monad.map try.monad (|>> ..reflection reflection!.load))
- (try\map (monad.map try.monad <methods>))
- try\join
- (try\map list\join)))]
-
- [all_abstract_methods ..abstract_methods]
- [all_methods ..methods]
- )
-
-(template [<name>]
- [(exception: #export (<name> {methods (List [Text (Type Method)])})
- (exception.report
- ["Methods" (exception.enumerate
- (function (_ [name type])
- (format (%.text name) " " (..signature type)))
- methods)]))]
-
- [missing_abstract_methods]
- [invalid_overriden_methods]
- )
-
-(type: #export Visibility
- #Public
- #Private
- #Protected
- #Default)
-
-(type: #export Finality Bit)
-(type: #export Strictness Bit)
-
-(def: #export public_tag "public")
-(def: #export private_tag "private")
-(def: #export protected_tag "protected")
-(def: #export default_tag "default")
-
-(def: #export visibility
- (Parser Visibility)
- ($_ <>.or
- (<code>.text! ..public_tag)
- (<code>.text! ..private_tag)
- (<code>.text! ..protected_tag)
- (<code>.text! ..default_tag)))
-
-(def: #export (visibility_analysis visibility)
- (-> Visibility Analysis)
- (/////analysis.text (case visibility
- #Public ..public_tag
- #Private ..private_tag
- #Protected ..protected_tag
- #Default ..default_tag)))
-
-(type: #export (Constructor a)
- [Visibility
- Strictness
- (List (Annotation a))
- (List (Type Var))
- (List (Type Class)) ## Exceptions
- Text
- (List Argument)
- (List (Typed a))
- a])
-
-(def: #export constructor_tag "init")
-
-(def: #export constructor_definition
- (Parser (Constructor Code))
- (<| <code>.form
- (<>.after (<code>.text! ..constructor_tag))
- ($_ <>.and
- ..visibility
- <code>.bit
- (<code>.tuple (<>.some ..annotation))
- (<code>.tuple (<>.some ..var))
- (<code>.tuple (<>.some ..class))
- <code>.text
- (<code>.tuple (<>.some ..argument))
- (<code>.tuple (<>.some ..input))
- <code>.any)))
-
-(def: #export (analyse_constructor_method analyse archive selfT mapping method)
- (-> Phase Archive .Type Mapping (Constructor Code) (Operation Analysis))
- (let [[visibility strict_fp?
- annotations vars exceptions
- self_name arguments super_arguments body] method]
- (do {! phase.monad}
- [annotationsA (monad.map ! (function (_ [name parameters])
- (do !
- [parametersA (monad.map ! (function (_ [name value])
- (do !
- [valueA (analyse archive value)]
- (wrap [name valueA])))
- parameters)]
- (wrap [name parametersA])))
- annotations)
- super_arguments (monad.map ! (function (_ [jvmT super_argC])
- (do !
- [luxT (reflection_type mapping jvmT)
- super_argA (typeA.with_type luxT
- (analyse archive super_argC))]
- (wrap [jvmT super_argA])))
- super_arguments)
- arguments' (monad.map !
- (function (_ [name jvmT])
- (do !
- [luxT (reflection_type mapping jvmT)]
- (wrap [name luxT])))
- arguments)
- [scope bodyA] (|> arguments'
- (#.Cons [self_name selfT])
- list.reverse
- (list\fold scope.with_local (analyse archive body))
- (typeA.with_type .Any)
- /////analysis.with_scope)]
- (wrap (/////analysis.tuple (list (/////analysis.text ..constructor_tag)
- (visibility_analysis visibility)
- (/////analysis.bit strict_fp?)
- (/////analysis.tuple (list\map annotation_analysis annotationsA))
- (/////analysis.tuple (list\map var_analysis vars))
- (/////analysis.text self_name)
- (/////analysis.tuple (list\map ..argument_analysis arguments))
- (/////analysis.tuple (list\map class_analysis exceptions))
- (/////analysis.tuple (list\map typed_analysis super_arguments))
- (#/////analysis.Function
- (list\map (|>> /////analysis.variable)
- (scope.environment scope))
- (/////analysis.tuple (list bodyA)))
- ))))))
-
-(type: #export (Virtual_Method a)
- [Text
- Visibility
- Finality
- Strictness
- (List (Annotation a))
- (List (Type Var))
- Text
- (List Argument)
- (Type Return)
- (List (Type Class)) ## Exceptions
- a])
-
-(def: virtual_tag "virtual")
-
-(def: #export virtual_method_definition
- (Parser (Virtual_Method Code))
- (<| <code>.form
- (<>.after (<code>.text! ..virtual_tag))
- ($_ <>.and
- <code>.text
- ..visibility
- <code>.bit
- <code>.bit
- (<code>.tuple (<>.some ..annotation))
- (<code>.tuple (<>.some ..var))
- <code>.text
- (<code>.tuple (<>.some ..argument))
- ..return
- (<code>.tuple (<>.some ..class))
- <code>.any)))
-
-(def: #export (analyse_virtual_method analyse archive selfT mapping method)
- (-> Phase Archive .Type Mapping (Virtual_Method Code) (Operation Analysis))
- (let [[method_name visibility
- final? strict_fp? annotations vars
- self_name arguments return exceptions
- body] method]
- (do {! phase.monad}
- [annotationsA (monad.map ! (function (_ [name parameters])
- (do !
- [parametersA (monad.map ! (function (_ [name value])
- (do !
- [valueA (analyse archive value)]
- (wrap [name valueA])))
- parameters)]
- (wrap [name parametersA])))
- annotations)
- returnT (reflection_return mapping return)
- arguments' (monad.map !
- (function (_ [name jvmT])
- (do !
- [luxT (reflection_type mapping jvmT)]
- (wrap [name luxT])))
- arguments)
- [scope bodyA] (|> arguments'
- (#.Cons [self_name selfT])
- list.reverse
- (list\fold scope.with_local (analyse archive body))
- (typeA.with_type returnT)
- /////analysis.with_scope)]
- (wrap (/////analysis.tuple (list (/////analysis.text ..virtual_tag)
- (/////analysis.text method_name)
- (visibility_analysis visibility)
- (/////analysis.bit final?)
- (/////analysis.bit strict_fp?)
- (/////analysis.tuple (list\map annotation_analysis annotationsA))
- (/////analysis.tuple (list\map var_analysis vars))
- (/////analysis.text self_name)
- (/////analysis.tuple (list\map ..argument_analysis arguments))
- (return_analysis return)
- (/////analysis.tuple (list\map class_analysis exceptions))
- (#/////analysis.Function
- (list\map (|>> /////analysis.variable)
- (scope.environment scope))
- (/////analysis.tuple (list bodyA)))
- ))))))
-
-(type: #export (Static_Method a)
- [Text
- Visibility
- Strictness
- (List (Annotation a))
- (List (Type Var))
- (List (Type Class)) ## Exceptions
- (List Argument)
- (Type Return)
- a])
-
-(def: #export static_tag "static")
-
-(def: #export static_method_definition
- (Parser (Static_Method Code))
- (<| <code>.form
- (<>.after (<code>.text! ..static_tag))
- ($_ <>.and
- <code>.text
- ..visibility
- <code>.bit
- (<code>.tuple (<>.some ..annotation))
- (<code>.tuple (<>.some ..var))
- (<code>.tuple (<>.some ..class))
- (<code>.tuple (<>.some ..argument))
- ..return
- <code>.any)))
-
-(def: #export (analyse_static_method analyse archive mapping method)
- (-> Phase Archive Mapping (Static_Method Code) (Operation Analysis))
- (let [[method_name visibility
- strict_fp? annotations vars exceptions
- arguments return
- body] method]
- (do {! phase.monad}
- [annotationsA (monad.map ! (function (_ [name parameters])
- (do !
- [parametersA (monad.map ! (function (_ [name value])
- (do !
- [valueA (analyse archive value)]
- (wrap [name valueA])))
- parameters)]
- (wrap [name parametersA])))
- annotations)
- returnT (reflection_return mapping return)
- arguments' (monad.map !
- (function (_ [name jvmT])
- (do !
- [luxT (reflection_type mapping jvmT)]
- (wrap [name luxT])))
- arguments)
- [scope bodyA] (|> arguments'
- list.reverse
- (list\fold scope.with_local (analyse archive body))
- (typeA.with_type returnT)
- /////analysis.with_scope)]
- (wrap (/////analysis.tuple (list (/////analysis.text ..static_tag)
- (/////analysis.text method_name)
- (visibility_analysis visibility)
- (/////analysis.bit strict_fp?)
- (/////analysis.tuple (list\map annotation_analysis annotationsA))
- (/////analysis.tuple (list\map var_analysis vars))
- (/////analysis.tuple (list\map ..argument_analysis arguments))
- (return_analysis return)
- (/////analysis.tuple (list\map class_analysis
- exceptions))
- (#/////analysis.Function
- (list\map (|>> /////analysis.variable)
- (scope.environment scope))
- (/////analysis.tuple (list bodyA)))
- ))))))
-
-(type: #export (Overriden_Method a)
- [(Type Class)
- Text
- Bit
- (List (Annotation a))
- (List (Type Var))
- Text
- (List Argument)
- (Type Return)
- (List (Type Class))
- a])
-
-(def: #export overriden_tag "override")
-
-(def: #export overriden_method_definition
- (Parser (Overriden_Method Code))
- (<| <code>.form
- (<>.after (<code>.text! ..overriden_tag))
- ($_ <>.and
- ..class
- <code>.text
- <code>.bit
- (<code>.tuple (<>.some ..annotation))
- (<code>.tuple (<>.some ..var))
- <code>.text
- (<code>.tuple (<>.some ..argument))
- ..return
- (<code>.tuple (<>.some ..class))
- <code>.any
- )))
-
-(def: #export (analyse_overriden_method analyse archive selfT mapping method)
- (-> Phase Archive .Type Mapping (Overriden_Method Code) (Operation Analysis))
- (let [[parent_type method_name
- strict_fp? annotations vars
- self_name arguments return exceptions
- body] method]
- (do {! phase.monad}
- [annotationsA (monad.map ! (function (_ [name parameters])
- (do !
- [parametersA (monad.map ! (function (_ [name value])
- (do !
- [valueA (analyse archive value)]
- (wrap [name valueA])))
- parameters)]
- (wrap [name parametersA])))
- annotations)
- returnT (reflection_return mapping return)
- arguments' (monad.map !
- (function (_ [name jvmT])
- (do !
- [luxT (reflection_type mapping jvmT)]
- (wrap [name luxT])))
- arguments)
- [scope bodyA] (|> arguments'
- (#.Cons [self_name selfT])
- list.reverse
- (list\fold scope.with_local (analyse archive body))
- (typeA.with_type returnT)
- /////analysis.with_scope)]
- (wrap (/////analysis.tuple (list (/////analysis.text ..overriden_tag)
- (class_analysis parent_type)
- (/////analysis.text method_name)
- (/////analysis.bit strict_fp?)
- (/////analysis.tuple (list\map annotation_analysis annotationsA))
- (/////analysis.tuple (list\map var_analysis vars))
- (/////analysis.text self_name)
- (/////analysis.tuple (list\map ..argument_analysis arguments))
- (return_analysis return)
- (/////analysis.tuple (list\map class_analysis
- exceptions))
- (#/////analysis.Function
- (list\map (|>> /////analysis.variable)
- (scope.environment scope))
- (/////analysis.tuple (list bodyA)))
- ))))))
-
-(type: #export (Method_Definition a)
- (#Overriden_Method (Overriden_Method a)))
-
-(def: #export parameter_types
- (-> (List (Type Var)) (Check (List [(Type Var) .Type])))
- (monad.map check.monad
- (function (_ parameterJ)
- (do check.monad
- [[_ parameterT] check.existential]
- (wrap [parameterJ parameterT])))))
-
-(def: (mismatched_methods super_set sub_set)
- (-> (List [Text (Type Method)])
- (List [Text (Type Method)])
- (List [Text (Type Method)]))
- (list.filter (function (_ [sub_name subJT])
- (|> super_set
- (list.filter (function (_ [super_name superJT])
- (and (text\= super_name sub_name)
- (jvm\= superJT subJT))))
- list.size
- (n.= 1)
- not))
- sub_set))
-
-(exception: #export (class_parameter_mismatch {expected (List Text)}
- {actual (List (Type Parameter))})
- (exception.report
- ["Expected (amount)" (%.nat (list.size expected))]
- ["Expected (parameters)" (exception.enumerate %.text expected)]
- ["Actual (amount)" (%.nat (list.size actual))]
- ["Actual (parameters)" (exception.enumerate ..signature actual)]))
-
-(def: (super_aliasing class)
- (-> (Type Class) (Operation Aliasing))
- (do phase.monad
- [#let [[name actual_parameters] (jvm_parser.read_class class)]
- class (phase.lift (reflection!.load name))
- #let [expected_parameters (|> (java/lang/Class::getTypeParameters class)
- array.to_list
- (list\map (|>> java/lang/reflect/TypeVariable::getName)))]
- _ (phase.assert ..class_parameter_mismatch [expected_parameters actual_parameters]
- (n.= (list.size expected_parameters)
- (list.size actual_parameters)))]
- (wrap (|> (list.zip/2 expected_parameters actual_parameters)
- (list\fold (function (_ [expected actual] mapping)
- (case (jvm_parser.var? actual)
- (#.Some actual)
- (dictionary.put actual expected mapping)
-
- #.None
- mapping))
- jvm_alias.fresh)))))
-
-(def: (anonymous_class_name module id)
- (-> Module Nat Text)
- (let [global (text.replace_all .module_separator ..jvm_package_separator module)
- local (format "anonymous-class" (%.nat id))]
- (format global ..jvm_package_separator local)))
-
-(def: class::anonymous
- Handler
- (..custom
- [($_ <>.and
- (<code>.tuple (<>.some ..var))
- ..class
- (<code>.tuple (<>.some ..class))
- (<code>.tuple (<>.some ..input))
- (<code>.tuple (<>.some ..overriden_method_definition)))
- (function (_ extension_name analyse archive [parameters
- super_class
- super_interfaces
- constructor_args
- methods])
- (do {! phase.monad}
- [_ (..ensure_fresh_class! (..reflection super_class))
- _ (monad.map ! (|>> ..reflection ..ensure_fresh_class!) super_interfaces)
- parameters (typeA.with_env
- (..parameter_types parameters))
- #let [mapping (list\fold (function (_ [parameterJ parameterT] mapping)
- (dictionary.put (jvm_parser.name parameterJ)
- parameterT
- mapping))
- luxT.fresh
- parameters)]
- super_classT (typeA.with_env
- (luxT.check (luxT.class mapping) (..signature super_class)))
- super_interfaceT+ (typeA.with_env
- (monad.map check.monad
- (|>> ..signature (luxT.check (luxT.class mapping)))
- super_interfaces))
- selfT (///.lift (do meta.monad
- [where meta.current_module_name
- id meta.count]
- (wrap (inheritance_relationship_type (#.Primitive (..anonymous_class_name where id) (list))
- super_classT
- super_interfaceT+))))
- _ (typeA.infer selfT)
- constructor_argsA+ (monad.map ! (function (_ [type term])
- (do !
- [argT (reflection_type mapping type)
- termA (typeA.with_type argT
- (analyse archive term))]
- (wrap [type termA])))
- constructor_args)
- methodsA (monad.map ! (analyse_overriden_method analyse archive selfT mapping) methods)
- required_abstract_methods (phase.lift (all_abstract_methods (list& super_class super_interfaces)))
- available_methods (phase.lift (all_methods (list& super_class super_interfaces)))
- overriden_methods (monad.map ! (function (_ [parent_type method_name
- strict_fp? annotations vars
- self_name arguments return exceptions
- body])
- (do !
- [aliasing (super_aliasing parent_type)]
- (wrap [method_name (|> (jvm.method [(list\map product.right arguments)
- return
- exceptions])
- (jvm_alias.method aliasing))])))
- methods)
- #let [missing_abstract_methods (mismatched_methods overriden_methods required_abstract_methods)
- invalid_overriden_methods (mismatched_methods available_methods overriden_methods)]
- _ (phase.assert ..missing_abstract_methods missing_abstract_methods
- (list.empty? missing_abstract_methods))
- _ (phase.assert ..invalid_overriden_methods invalid_overriden_methods
- (list.empty? invalid_overriden_methods))]
- (wrap (#/////analysis.Extension extension_name
- (list (class_analysis super_class)
- (/////analysis.tuple (list\map class_analysis super_interfaces))
- (/////analysis.tuple (list\map typed_analysis constructor_argsA+))
- (/////analysis.tuple methodsA))))))]))
-
-(def: bundle::class
- Bundle
- (<| (///bundle.prefix "class")
- (|> ///bundle.empty
- (///bundle.install "anonymous" class::anonymous)
- )))
-
-(def: #export bundle
- Bundle
- (<| (///bundle.prefix "jvm")
- (|> ///bundle.empty
- (dictionary.merge bundle::conversion)
- (dictionary.merge bundle::int)
- (dictionary.merge bundle::long)
- (dictionary.merge bundle::float)
- (dictionary.merge bundle::double)
- (dictionary.merge bundle::char)
- (dictionary.merge bundle::array)
- (dictionary.merge bundle::object)
- (dictionary.merge bundle::member)
- (dictionary.merge bundle::class)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux
deleted file mode 100644
index 8f97d1ba9..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux
+++ /dev/null
@@ -1,251 +0,0 @@
-(.module:
- [lux #*
- ["." ffi]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- [collection
- ["." array (#+ Array)]
- ["." dictionary]
- ["." list]]]
- ["." type
- ["." check]]
- ["@" target
- ["_" lua]]]
- [//
- ["/" lux (#+ custom)]
- [//
- ["." bundle]
- [//
- ["." analysis #_
- ["#/." type]]
- [//
- ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
- [///
- ["." phase]]]]]])
-
-(def: Nil
- (for {@.lua ffi.Nil}
- Any))
-
-(def: Object
- (for {@.lua (type (ffi.Object Any))}
- Any))
-
-(def: Function
- (for {@.lua ffi.Function}
- Any))
-
-(def: array::new
- Handler
- (custom
- [<code>.any
- (function (_ extension phase archive lengthC)
- (do phase.monad
- [lengthA (analysis/type.with_type Nat
- (phase archive lengthC))
- [var_id varT] (analysis/type.with_env check.var)
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list lengthA)))))]))
-
-(def: array::length
- Handler
- (custom
- [<code>.any
- (function (_ extension phase archive arrayC)
- (do phase.monad
- [[var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer Nat)]
- (wrap (#analysis.Extension extension (list arrayA)))))]))
-
-(def: array::read
- Handler
- (custom
- [(<>.and <code>.any <code>.any)
- (function (_ extension phase archive [indexC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer varT)]
- (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
-
-(def: array::write
- Handler
- (custom
- [($_ <>.and <code>.any <code>.any <code>.any)
- (function (_ extension phase archive [indexC valueC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- valueA (analysis/type.with_type varT
- (phase archive valueC))
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))]))
-
-(def: array::delete
- Handler
- (custom
- [($_ <>.and <code>.any <code>.any)
- (function (_ extension phase archive [indexC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
-
-(def: bundle::array
- Bundle
- (<| (bundle.prefix "array")
- (|> bundle.empty
- (bundle.install "new" array::new)
- (bundle.install "length" array::length)
- (bundle.install "read" array::read)
- (bundle.install "write" array::write)
- (bundle.install "delete" array::delete)
- )))
-
-(def: object::get
- Handler
- (custom
- [($_ <>.and <code>.text <code>.any)
- (function (_ extension phase archive [fieldC objectC])
- (do phase.monad
- [objectA (analysis/type.with_type ..Object
- (phase archive objectC))
- _ (analysis/type.infer .Any)]
- (wrap (#analysis.Extension extension (list (analysis.text fieldC)
- objectA)))))]))
-
-(def: object::do
- Handler
- (custom
- [($_ <>.and <code>.text <code>.any (<>.some <code>.any))
- (function (_ extension phase archive [methodC objectC inputsC])
- (do {! phase.monad}
- [objectA (analysis/type.with_type ..Object
- (phase archive objectC))
- inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
- _ (analysis/type.infer .Any)]
- (wrap (#analysis.Extension extension (list& (analysis.text methodC)
- objectA
- inputsA)))))]))
-
-(def: bundle::object
- Bundle
- (<| (bundle.prefix "object")
- (|> bundle.empty
- (bundle.install "get" object::get)
- (bundle.install "do" object::do)
- (bundle.install "nil" (/.nullary ..Nil))
- (bundle.install "nil?" (/.unary Any Bit))
- )))
-
-(template [<name> <fromT> <toT>]
- [(def: <name>
- Handler
- (custom
- [<code>.any
- (function (_ extension phase archive inputC)
- (do {! phase.monad}
- [inputA (analysis/type.with_type (type <fromT>)
- (phase archive inputC))
- _ (analysis/type.infer (type <toT>))]
- (wrap (#analysis.Extension extension (list inputA)))))]))]
-
- [utf8::encode Text (array.Array (I64 Any))]
- [utf8::decode (array.Array (I64 Any)) Text]
- )
-
-(def: bundle::utf8
- Bundle
- (<| (bundle.prefix "utf8")
- (|> bundle.empty
- (bundle.install "encode" utf8::encode)
- (bundle.install "decode" utf8::decode)
- )))
-
-(def: lua::constant
- Handler
- (custom
- [<code>.text
- (function (_ extension phase archive name)
- (do phase.monad
- [_ (analysis/type.infer Any)]
- (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
-
-(def: lua::apply
- Handler
- (custom
- [($_ <>.and <code>.any (<>.some <code>.any))
- (function (_ extension phase archive [abstractionC inputsC])
- (do {! phase.monad}
- [abstractionA (analysis/type.with_type ..Function
- (phase archive abstractionC))
- inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
- _ (analysis/type.infer Any)]
- (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))]))
-
-(def: lua::power
- Handler
- (custom
- [($_ <>.and <code>.any <code>.any)
- (function (_ extension phase archive [powerC baseC])
- (do {! phase.monad}
- [powerA (analysis/type.with_type Frac
- (phase archive powerC))
- baseA (analysis/type.with_type Frac
- (phase archive baseC))
- _ (analysis/type.infer Frac)]
- (wrap (#analysis.Extension extension (list powerA baseA)))))]))
-
-(def: lua::import
- Handler
- (custom
- [<code>.text
- (function (_ extension phase archive name)
- (do phase.monad
- [_ (analysis/type.infer ..Object)]
- (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
-
-(def: lua::function
- Handler
- (custom
- [($_ <>.and <code>.nat <code>.any)
- (function (_ extension phase archive [arity abstractionC])
- (do phase.monad
- [#let [inputT (type.tuple (list.repeat arity Any))]
- abstractionA (analysis/type.with_type (-> inputT Any)
- (phase archive abstractionC))
- _ (analysis/type.infer ..Function)]
- (wrap (#analysis.Extension extension (list (analysis.nat arity)
- abstractionA)))))]))
-
-(def: #export bundle
- Bundle
- (<| (bundle.prefix "lua")
- (|> bundle.empty
- (dictionary.merge bundle::array)
- (dictionary.merge bundle::object)
- (dictionary.merge bundle::utf8)
-
- (bundle.install "constant" lua::constant)
- (bundle.install "apply" lua::apply)
- (bundle.install "power" lua::power)
- (bundle.install "import" lua::import)
- (bundle.install "function" lua::function)
- (bundle.install "script universe" (/.nullary .Bit))
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux
deleted file mode 100644
index a86295b2a..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux
+++ /dev/null
@@ -1,300 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- ["." maybe]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]
- ["." dictionary (#+ Dictionary)]]]
- [math
- [number
- ["n" nat]]]
- [type
- ["." check]]
- ["." meta]]
- ["." ///
- ["#." bundle]
- ["/#" // #_
- [analysis
- [".A" type]]
- [//
- ["#." analysis (#+ Analysis Operation Phase Handler Bundle)
- [evaluation (#+ Eval)]]
- [///
- ["#" phase]
- [meta
- [archive (#+ Archive)]]]]]])
-
-(def: #export (custom [syntax handler])
- (All [s]
- (-> [(Parser s)
- (-> Text Phase Archive s (Operation Analysis))]
- Handler))
- (function (_ extension_name analyse archive args)
- (case (<code>.run syntax args)
- (#try.Success inputs)
- (handler extension_name analyse archive inputs)
-
- (#try.Failure _)
- (////analysis.throw ///.invalid_syntax [extension_name %.code args]))))
-
-(def: (simple inputsT+ outputT)
- (-> (List Type) Type Handler)
- (let [num_expected (list.size inputsT+)]
- (function (_ extension_name analyse archive args)
- (let [num_actual (list.size args)]
- (if (n.= num_expected num_actual)
- (do {! ////.monad}
- [_ (typeA.infer outputT)
- argsA (monad.map !
- (function (_ [argT argC])
- (typeA.with_type argT
- (analyse archive argC)))
- (list.zip/2 inputsT+ args))]
- (wrap (#////analysis.Extension extension_name argsA)))
- (////analysis.throw ///.incorrect_arity [extension_name num_expected num_actual]))))))
-
-(def: #export (nullary valueT)
- (-> Type Handler)
- (simple (list) valueT))
-
-(def: #export (unary inputT outputT)
- (-> Type Type Handler)
- (simple (list inputT) outputT))
-
-(def: #export (binary subjectT paramT outputT)
- (-> Type Type Type Handler)
- (simple (list subjectT paramT) outputT))
-
-(def: #export (trinary subjectT param0T param1T outputT)
- (-> Type Type Type Type Handler)
- (simple (list subjectT param0T param1T) outputT))
-
-## TODO: Get rid of this ASAP
-(as_is
- (exception: #export (char_text_must_be_size_1 {text Text})
- (exception.report
- ["Text" (%.text text)]))
-
- (def: text_char
- (Parser text.Char)
- (do <>.monad
- [raw <code>.text]
- (case (text.size raw)
- 1 (wrap (|> raw (text.nth 0) maybe.assume))
- _ (<>.fail (exception.construct ..char_text_must_be_size_1 [raw])))))
-
- (def: lux::syntax_char_case!
- (..custom
- [($_ <>.and
- <code>.any
- (<code>.tuple (<>.some (<>.and (<code>.tuple (<>.many ..text_char))
- <code>.any)))
- <code>.any)
- (function (_ extension_name phase archive [input conditionals else])
- (do {! ////.monad}
- [input (typeA.with_type text.Char
- (phase archive input))
- expectedT (///.lift meta.expected_type)
- conditionals (monad.map ! (function (_ [cases branch])
- (do !
- [branch (typeA.with_type expectedT
- (phase archive branch))]
- (wrap [cases branch])))
- conditionals)
- else (typeA.with_type expectedT
- (phase archive else))]
- (wrap (|> conditionals
- (list\map (function (_ [cases branch])
- (////analysis.tuple
- (list (////analysis.tuple (list\map (|>> ////analysis.nat) cases))
- branch))))
- (list& input else)
- (#////analysis.Extension extension_name)))))])))
-
-## "lux is" represents reference/pointer equality.
-(def: lux::is
- Handler
- (function (_ extension_name analyse archive args)
- (do ////.monad
- [[var_id varT] (typeA.with_env check.var)]
- ((binary varT varT Bit extension_name)
- analyse archive args))))
-
-## "lux try" provides a simple way to interact with the host platform's
-## error_handling facilities.
-(def: lux::try
- Handler
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list opC))
- (do ////.monad
- [[var_id varT] (typeA.with_env check.var)
- _ (typeA.infer (type (Either Text varT)))
- opA (typeA.with_type (type (-> .Any varT))
- (analyse archive opC))]
- (wrap (#////analysis.Extension extension_name (list opA))))
-
- _
- (////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)]))))
-
-(def: lux::in_module
- Handler
- (function (_ extension_name analyse archive argsC+)
- (case argsC+
- (^ (list [_ (#.Text module_name)] exprC))
- (////analysis.with_current_module module_name
- (analyse archive exprC))
-
- _
- (////analysis.throw ///.invalid_syntax [extension_name %.code argsC+]))))
-
-(def: (lux::type::check eval)
- (-> Eval Handler)
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list typeC valueC))
- (do {! ////.monad}
- [count (///.lift meta.count)
- actualT (\ ! map (|>> (:as Type))
- (eval archive count Type typeC))
- _ (typeA.infer actualT)]
- (typeA.with_type actualT
- (analyse archive valueC)))
-
- _
- (////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)]))))
-
-(def: (lux::type::as eval)
- (-> Eval Handler)
- (function (_ extension_name analyse archive args)
- (case args
- (^ (list typeC valueC))
- (do {! ////.monad}
- [count (///.lift meta.count)
- actualT (\ ! map (|>> (:as Type))
- (eval archive count Type typeC))
- _ (typeA.infer actualT)
- [valueT valueA] (typeA.with_inference
- (analyse archive valueC))]
- (wrap valueA))
-
- _
- (////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)]))))
-
-(def: (caster input output)
- (-> Type Type Handler)
- (..custom
- [<code>.any
- (function (_ extension_name phase archive valueC)
- (do {! ////.monad}
- [_ (typeA.infer output)]
- (typeA.with_type input
- (phase archive valueC))))]))
-
-(def: lux::macro
- Handler
- (..custom
- [<code>.any
- (function (_ extension_name phase archive valueC)
- (do {! ////.monad}
- [_ (typeA.infer .Macro)
- input_type (loop [input_name (name_of .Macro')]
- (do !
- [input_type (///.lift (meta.find_def (name_of .Macro')))]
- (case input_type
- (#.Definition [exported? def_type def_data def_value])
- (wrap (:as Type def_value))
-
- (#.Alias real_name)
- (recur real_name))))]
- (typeA.with_type input_type
- (phase archive valueC))))]))
-
-(def: (bundle::lux eval)
- (-> Eval Bundle)
- (|> ///bundle.empty
- (///bundle.install "syntax char case!" lux::syntax_char_case!)
- (///bundle.install "is" lux::is)
- (///bundle.install "try" lux::try)
- (///bundle.install "type check" (lux::type::check eval))
- (///bundle.install "type as" (lux::type::as eval))
- (///bundle.install "macro" ..lux::macro)
- (///bundle.install "type check type" (..caster .Type .Type))
- (///bundle.install "in-module" lux::in_module)))
-
-(def: bundle::io
- Bundle
- (<| (///bundle.prefix "io")
- (|> ///bundle.empty
- (///bundle.install "log" (unary Text Any))
- (///bundle.install "error" (unary Text Nothing))
- (///bundle.install "exit" (unary Int Nothing)))))
-
-(def: I64* (type (I64 Any)))
-
-(def: bundle::i64
- Bundle
- (<| (///bundle.prefix "i64")
- (|> ///bundle.empty
- (///bundle.install "and" (binary I64* I64* I64))
- (///bundle.install "or" (binary I64* I64* I64))
- (///bundle.install "xor" (binary I64* I64* I64))
- (///bundle.install "left-shift" (binary Nat I64* I64))
- (///bundle.install "right-shift" (binary Nat I64* I64))
- (///bundle.install "=" (binary I64* I64* Bit))
- (///bundle.install "<" (binary Int Int Bit))
- (///bundle.install "+" (binary I64* I64* I64))
- (///bundle.install "-" (binary I64* I64* I64))
- (///bundle.install "*" (binary Int Int Int))
- (///bundle.install "/" (binary Int Int Int))
- (///bundle.install "%" (binary Int Int Int))
- (///bundle.install "f64" (unary Int Frac))
- (///bundle.install "char" (unary Int Text)))))
-
-(def: bundle::f64
- Bundle
- (<| (///bundle.prefix "f64")
- (|> ///bundle.empty
- (///bundle.install "+" (binary Frac Frac Frac))
- (///bundle.install "-" (binary Frac Frac Frac))
- (///bundle.install "*" (binary Frac Frac Frac))
- (///bundle.install "/" (binary Frac Frac Frac))
- (///bundle.install "%" (binary Frac Frac Frac))
- (///bundle.install "=" (binary Frac Frac Bit))
- (///bundle.install "<" (binary Frac Frac Bit))
- (///bundle.install "i64" (unary Frac Int))
- (///bundle.install "encode" (unary Frac Text))
- (///bundle.install "decode" (unary Text (type (Maybe Frac)))))))
-
-(def: bundle::text
- Bundle
- (<| (///bundle.prefix "text")
- (|> ///bundle.empty
- (///bundle.install "=" (binary Text Text Bit))
- (///bundle.install "<" (binary Text Text Bit))
- (///bundle.install "concat" (binary Text Text Text))
- (///bundle.install "index" (trinary Nat Text Text (type (Maybe Nat))))
- (///bundle.install "size" (unary Text Nat))
- (///bundle.install "char" (binary Nat Text Nat))
- (///bundle.install "clip" (trinary Nat Nat Text Text))
- )))
-
-(def: #export (bundle eval)
- (-> Eval Bundle)
- (<| (///bundle.prefix "lux")
- (|> ///bundle.empty
- (dictionary.merge (bundle::lux eval))
- (dictionary.merge bundle::i64)
- (dictionary.merge bundle::f64)
- (dictionary.merge bundle::text)
- (dictionary.merge bundle::io)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux
deleted file mode 100644
index 19aea38fa..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux
+++ /dev/null
@@ -1,213 +0,0 @@
-(.module:
- [lux #*
- ["." ffi]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["<>" parser
- ["<c>" code (#+ Parser)]]]
- [data
- [collection
- ["." array (#+ Array)]
- ["." dictionary]
- ["." list]]]
- ["." type
- ["." check]]
- ["@" target
- ["_" php]]]
- [//
- ["/" lux (#+ custom)]
- [//
- ["." bundle]
- [//
- ["." analysis #_
- ["#/." type]]
- [//
- ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
- [///
- ["." phase]]]]]])
-
-(def: array::new
- Handler
- (custom
- [<c>.any
- (function (_ extension phase archive lengthC)
- (do phase.monad
- [lengthA (analysis/type.with_type Nat
- (phase archive lengthC))
- [var_id varT] (analysis/type.with_env check.var)
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list lengthA)))))]))
-
-(def: array::length
- Handler
- (custom
- [<c>.any
- (function (_ extension phase archive arrayC)
- (do phase.monad
- [[var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer Nat)]
- (wrap (#analysis.Extension extension (list arrayA)))))]))
-
-(def: array::read
- Handler
- (custom
- [(<>.and <c>.any <c>.any)
- (function (_ extension phase archive [indexC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer varT)]
- (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
-
-(def: array::write
- Handler
- (custom
- [($_ <>.and <c>.any <c>.any <c>.any)
- (function (_ extension phase archive [indexC valueC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- valueA (analysis/type.with_type varT
- (phase archive valueC))
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))]))
-
-(def: array::delete
- Handler
- (custom
- [($_ <>.and <c>.any <c>.any)
- (function (_ extension phase archive [indexC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
-
-(def: bundle::array
- Bundle
- (<| (bundle.prefix "array")
- (|> bundle.empty
- (bundle.install "new" array::new)
- (bundle.install "length" array::length)
- (bundle.install "read" array::read)
- (bundle.install "write" array::write)
- (bundle.install "delete" array::delete)
- )))
-
-(def: Null
- (for {@.php ffi.Null}
- Any))
-
-(def: Object
- (for {@.php (type (ffi.Object Any))}
- Any))
-
-(def: Function
- (for {@.php ffi.Function}
- Any))
-
-(def: object::new
- Handler
- (custom
- [($_ <>.and <c>.text (<>.some <c>.any))
- (function (_ extension phase archive [constructor inputsC])
- (do {! phase.monad}
- [inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
- _ (analysis/type.infer .Any)]
- (wrap (#analysis.Extension extension (list& (analysis.text constructor) inputsA)))))]))
-
-(def: object::get
- Handler
- (custom
- [($_ <>.and <c>.text <c>.any)
- (function (_ extension phase archive [fieldC objectC])
- (do phase.monad
- [objectA (analysis/type.with_type ..Object
- (phase archive objectC))
- _ (analysis/type.infer .Any)]
- (wrap (#analysis.Extension extension (list (analysis.text fieldC)
- objectA)))))]))
-
-(def: object::do
- Handler
- (custom
- [($_ <>.and <c>.text <c>.any (<>.some <c>.any))
- (function (_ extension phase archive [methodC objectC inputsC])
- (do {! phase.monad}
- [objectA (analysis/type.with_type ..Object
- (phase archive objectC))
- inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
- _ (analysis/type.infer .Any)]
- (wrap (#analysis.Extension extension (list& (analysis.text methodC)
- objectA
- inputsA)))))]))
-
-(def: bundle::object
- Bundle
- (<| (bundle.prefix "object")
- (|> bundle.empty
- (bundle.install "new" object::new)
- (bundle.install "get" object::get)
- (bundle.install "do" object::do)
- (bundle.install "null" (/.nullary ..Null))
- (bundle.install "null?" (/.unary Any Bit))
- )))
-
-(def: php::constant
- Handler
- (custom
- [<c>.text
- (function (_ extension phase archive name)
- (do phase.monad
- [_ (analysis/type.infer Any)]
- (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
-
-(def: php::apply
- Handler
- (custom
- [($_ <>.and <c>.any (<>.some <c>.any))
- (function (_ extension phase archive [abstractionC inputsC])
- (do {! phase.monad}
- [abstractionA (analysis/type.with_type ..Function
- (phase archive abstractionC))
- inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
- _ (analysis/type.infer Any)]
- (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))]))
-
-(def: php::pack
- Handler
- (custom
- [($_ <>.and <c>.any <c>.any)
- (function (_ extension phase archive [formatC dataC])
- (do {! phase.monad}
- [formatA (analysis/type.with_type Text
- (phase archive formatC))
- dataA (analysis/type.with_type (type (Array (I64 Any)))
- (phase archive dataC))
- _ (analysis/type.infer Text)]
- (wrap (#analysis.Extension extension (list formatA dataA)))))]))
-
-(def: #export bundle
- Bundle
- (<| (bundle.prefix "php")
- (|> bundle.empty
- (dictionary.merge bundle::array)
- (dictionary.merge bundle::object)
-
- (bundle.install "constant" php::constant)
- (bundle.install "apply" php::apply)
- (bundle.install "pack" php::pack)
- (bundle.install "script universe" (/.nullary .Bit))
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux
deleted file mode 100644
index 53e6c0b05..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux
+++ /dev/null
@@ -1,230 +0,0 @@
-(.module:
- [lux #*
- ["." ffi]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- [collection
- ["." array (#+ Array)]
- ["." dictionary]
- ["." list]]]
- ["." type
- ["." check]]
- ["@" target
- ["_" python]]]
- [//
- ["/" lux (#+ custom)]
- [//
- ["." bundle]
- [//
- ["." analysis #_
- ["#/." type]]
- [//
- ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
- [///
- ["." phase]]]]]])
-
-(def: array::new
- Handler
- (custom
- [<code>.any
- (function (_ extension phase archive lengthC)
- (do phase.monad
- [lengthA (analysis/type.with_type Nat
- (phase archive lengthC))
- [var_id varT] (analysis/type.with_env check.var)
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list lengthA)))))]))
-
-(def: array::length
- Handler
- (custom
- [<code>.any
- (function (_ extension phase archive arrayC)
- (do phase.monad
- [[var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer Nat)]
- (wrap (#analysis.Extension extension (list arrayA)))))]))
-
-(def: array::read
- Handler
- (custom
- [(<>.and <code>.any <code>.any)
- (function (_ extension phase archive [indexC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer varT)]
- (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
-
-(def: array::write
- Handler
- (custom
- [($_ <>.and <code>.any <code>.any <code>.any)
- (function (_ extension phase archive [indexC valueC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- valueA (analysis/type.with_type varT
- (phase archive valueC))
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))]))
-
-(def: array::delete
- Handler
- (custom
- [($_ <>.and <code>.any <code>.any)
- (function (_ extension phase archive [indexC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
-
-(def: bundle::array
- Bundle
- (<| (bundle.prefix "array")
- (|> bundle.empty
- (bundle.install "new" array::new)
- (bundle.install "length" array::length)
- (bundle.install "read" array::read)
- (bundle.install "write" array::write)
- (bundle.install "delete" array::delete)
- )))
-
-(def: None
- (for {@.python
- ffi.None}
- Any))
-
-(def: Object
- (for {@.python (type (ffi.Object Any))}
- Any))
-
-(def: Function
- (for {@.python ffi.Function}
- Any))
-
-(def: Dict
- (for {@.python ffi.Dict}
- Any))
-
-(def: object::get
- Handler
- (custom
- [($_ <>.and <code>.text <code>.any)
- (function (_ extension phase archive [fieldC objectC])
- (do phase.monad
- [objectA (analysis/type.with_type ..Object
- (phase archive objectC))
- _ (analysis/type.infer .Any)]
- (wrap (#analysis.Extension extension (list (analysis.text fieldC)
- objectA)))))]))
-
-(def: object::do
- Handler
- (custom
- [($_ <>.and <code>.text <code>.any (<>.some <code>.any))
- (function (_ extension phase archive [methodC objectC inputsC])
- (do {! phase.monad}
- [objectA (analysis/type.with_type ..Object
- (phase archive objectC))
- inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
- _ (analysis/type.infer .Any)]
- (wrap (#analysis.Extension extension (list& (analysis.text methodC)
- objectA
- inputsA)))))]))
-
-(def: bundle::object
- Bundle
- (<| (bundle.prefix "object")
- (|> bundle.empty
- (bundle.install "get" object::get)
- (bundle.install "do" object::do)
- (bundle.install "none" (/.nullary ..None))
- (bundle.install "none?" (/.unary Any Bit))
- )))
-
-(def: python::constant
- Handler
- (custom
- [<code>.text
- (function (_ extension phase archive name)
- (do phase.monad
- [_ (analysis/type.infer Any)]
- (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
-
-(def: python::import
- Handler
- (custom
- [<code>.text
- (function (_ extension phase archive name)
- (do phase.monad
- [_ (analysis/type.infer ..Object)]
- (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
-
-(def: python::apply
- Handler
- (custom
- [($_ <>.and <code>.any (<>.some <code>.any))
- (function (_ extension phase archive [abstractionC inputsC])
- (do {! phase.monad}
- [abstractionA (analysis/type.with_type ..Function
- (phase archive abstractionC))
- inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
- _ (analysis/type.infer Any)]
- (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))]))
-
-(def: python::function
- Handler
- (custom
- [($_ <>.and <code>.nat <code>.any)
- (function (_ extension phase archive [arity abstractionC])
- (do phase.monad
- [#let [inputT (type.tuple (list.repeat arity Any))]
- abstractionA (analysis/type.with_type (-> inputT Any)
- (phase archive abstractionC))
- _ (analysis/type.infer ..Function)]
- (wrap (#analysis.Extension extension (list (analysis.nat arity)
- abstractionA)))))]))
-
-(def: python::exec
- Handler
- (custom
- [($_ <>.and <code>.any <code>.any)
- (function (_ extension phase archive [codeC globalsC])
- (do phase.monad
- [codeA (analysis/type.with_type Text
- (phase archive codeC))
- globalsA (analysis/type.with_type ..Dict
- (phase archive globalsC))
- _ (analysis/type.infer .Any)]
- (wrap (#analysis.Extension extension (list codeA globalsA)))))]))
-
-(def: #export bundle
- Bundle
- (<| (bundle.prefix "python")
- (|> bundle.empty
- (dictionary.merge bundle::array)
- (dictionary.merge bundle::object)
-
- (bundle.install "constant" python::constant)
- (bundle.install "import" python::import)
- (bundle.install "apply" python::apply)
- (bundle.install "function" python::function)
- (bundle.install "exec" python::exec)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux
deleted file mode 100644
index 12f578ed2..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux
+++ /dev/null
@@ -1,34 +0,0 @@
-(.module:
- [lux #*
- ["." ffi]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["<>" parser
- ["<c>" code (#+ Parser)]]]
- [data
- [collection
- ["." array (#+ Array)]
- ["." dictionary]
- ["." list]]]
- ["." type
- ["." check]]
- ["@" target
- ["_" r]]]
- [//
- ["/" lux (#+ custom)]
- [//
- ["." bundle]
- [//
- ["." analysis #_
- ["#/." type]]
- [//
- ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
- [///
- ["." phase]]]]]])
-
-(def: #export bundle
- Bundle
- (<| (bundle.prefix "r")
- (|> bundle.empty
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux
deleted file mode 100644
index 0fda869e9..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux
+++ /dev/null
@@ -1,198 +0,0 @@
-(.module:
- [lux #*
- ["." ffi]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["<>" parser
- ["<c>" code (#+ Parser)]]]
- [data
- [collection
- ["." array (#+ Array)]
- ["." dictionary]
- ["." list]]]
- ["." type
- ["." check]]
- ["@" target
- ["_" ruby]]]
- [//
- ["/" lux (#+ custom)]
- [//
- ["." bundle]
- [//
- ["." analysis #_
- ["#/." type]]
- [//
- ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
- [///
- ["." phase]]]]]])
-
-(def: array::new
- Handler
- (custom
- [<c>.any
- (function (_ extension phase archive lengthC)
- (do phase.monad
- [lengthA (analysis/type.with_type Nat
- (phase archive lengthC))
- [var_id varT] (analysis/type.with_env check.var)
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list lengthA)))))]))
-
-(def: array::length
- Handler
- (custom
- [<c>.any
- (function (_ extension phase archive arrayC)
- (do phase.monad
- [[var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer Nat)]
- (wrap (#analysis.Extension extension (list arrayA)))))]))
-
-(def: array::read
- Handler
- (custom
- [(<>.and <c>.any <c>.any)
- (function (_ extension phase archive [indexC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer varT)]
- (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
-
-(def: array::write
- Handler
- (custom
- [($_ <>.and <c>.any <c>.any <c>.any)
- (function (_ extension phase archive [indexC valueC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- valueA (analysis/type.with_type varT
- (phase archive valueC))
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))]))
-
-(def: array::delete
- Handler
- (custom
- [($_ <>.and <c>.any <c>.any)
- (function (_ extension phase archive [indexC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
-
-(def: bundle::array
- Bundle
- (<| (bundle.prefix "array")
- (|> bundle.empty
- (bundle.install "new" array::new)
- (bundle.install "length" array::length)
- (bundle.install "read" array::read)
- (bundle.install "write" array::write)
- (bundle.install "delete" array::delete)
- )))
-
-(def: Nil
- (for {@.ruby ffi.Nil}
- Any))
-
-(def: Object
- (for {@.ruby (type (ffi.Object Any))}
- Any))
-
-(def: Function
- (for {@.ruby ffi.Function}
- Any))
-
-(def: object::get
- Handler
- (custom
- [($_ <>.and <c>.text <c>.any)
- (function (_ extension phase archive [fieldC objectC])
- (do phase.monad
- [objectA (analysis/type.with_type ..Object
- (phase archive objectC))
- _ (analysis/type.infer .Any)]
- (wrap (#analysis.Extension extension (list (analysis.text fieldC)
- objectA)))))]))
-
-(def: object::do
- Handler
- (custom
- [($_ <>.and <c>.text <c>.any (<>.some <c>.any))
- (function (_ extension phase archive [methodC objectC inputsC])
- (do {! phase.monad}
- [objectA (analysis/type.with_type ..Object
- (phase archive objectC))
- inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
- _ (analysis/type.infer .Any)]
- (wrap (#analysis.Extension extension (list& (analysis.text methodC)
- objectA
- inputsA)))))]))
-
-(def: bundle::object
- Bundle
- (<| (bundle.prefix "object")
- (|> bundle.empty
- (bundle.install "get" object::get)
- (bundle.install "do" object::do)
- (bundle.install "nil" (/.nullary ..Nil))
- (bundle.install "nil?" (/.unary Any Bit))
- )))
-
-(def: ruby::constant
- Handler
- (custom
- [<c>.text
- (function (_ extension phase archive name)
- (do phase.monad
- [_ (analysis/type.infer Any)]
- (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
-
-(def: ruby::apply
- Handler
- (custom
- [($_ <>.and <c>.any (<>.some <c>.any))
- (function (_ extension phase archive [abstractionC inputsC])
- (do {! phase.monad}
- [abstractionA (analysis/type.with_type ..Function
- (phase archive abstractionC))
- inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
- _ (analysis/type.infer Any)]
- (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))]))
-
-(def: ruby::import
- Handler
- (custom
- [<c>.text
- (function (_ extension phase archive name)
- (do phase.monad
- [_ (analysis/type.infer Bit)]
- (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
-
-(def: #export bundle
- Bundle
- (<| (bundle.prefix "ruby")
- (|> bundle.empty
- (dictionary.merge bundle::array)
- (dictionary.merge bundle::object)
-
- (bundle.install "constant" ruby::constant)
- (bundle.install "apply" ruby::apply)
- (bundle.install "import" ruby::import)
- (bundle.install "script universe" (/.nullary .Bit))
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux
deleted file mode 100644
index 86db4170f..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux
+++ /dev/null
@@ -1,157 +0,0 @@
-(.module:
- [lux #*
- ["." ffi]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["<>" parser
- ["<c>" code (#+ Parser)]]]
- [data
- [collection
- ["." array (#+ Array)]
- ["." dictionary]
- ["." list]]]
- ["." type
- ["." check]]
- ["@" target
- ["_" scheme]]]
- [//
- ["/" lux (#+ custom)]
- [//
- ["." bundle]
- [//
- ["." analysis #_
- ["#/." type]]
- [//
- ["." analysis (#+ Analysis Operation Phase Handler Bundle)]
- [///
- ["." phase]]]]]])
-
-(def: array::new
- Handler
- (custom
- [<c>.any
- (function (_ extension phase archive lengthC)
- (do phase.monad
- [lengthA (analysis/type.with_type Nat
- (phase archive lengthC))
- [var_id varT] (analysis/type.with_env check.var)
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list lengthA)))))]))
-
-(def: array::length
- Handler
- (custom
- [<c>.any
- (function (_ extension phase archive arrayC)
- (do phase.monad
- [[var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer Nat)]
- (wrap (#analysis.Extension extension (list arrayA)))))]))
-
-(def: array::read
- Handler
- (custom
- [(<>.and <c>.any <c>.any)
- (function (_ extension phase archive [indexC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer varT)]
- (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
-
-(def: array::write
- Handler
- (custom
- [($_ <>.and <c>.any <c>.any <c>.any)
- (function (_ extension phase archive [indexC valueC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- valueA (analysis/type.with_type varT
- (phase archive valueC))
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))]))
-
-(def: array::delete
- Handler
- (custom
- [($_ <>.and <c>.any <c>.any)
- (function (_ extension phase archive [indexC arrayC])
- (do phase.monad
- [indexA (analysis/type.with_type Nat
- (phase archive indexC))
- [var_id varT] (analysis/type.with_env check.var)
- arrayA (analysis/type.with_type (type (Array varT))
- (phase archive arrayC))
- _ (analysis/type.infer (type (Array varT)))]
- (wrap (#analysis.Extension extension (list indexA arrayA)))))]))
-
-(def: bundle::array
- Bundle
- (<| (bundle.prefix "array")
- (|> bundle.empty
- (bundle.install "new" array::new)
- (bundle.install "length" array::length)
- (bundle.install "read" array::read)
- (bundle.install "write" array::write)
- (bundle.install "delete" array::delete)
- )))
-
-(def: Nil
- (for {@.scheme
- ffi.Nil}
- Any))
-
-(def: Function
- (for {@.scheme ffi.Function}
- Any))
-
-(def: bundle::object
- Bundle
- (<| (bundle.prefix "object")
- (|> bundle.empty
- (bundle.install "nil" (/.nullary ..Nil))
- (bundle.install "nil?" (/.unary Any Bit))
- )))
-
-(def: scheme::constant
- Handler
- (custom
- [<c>.text
- (function (_ extension phase archive name)
- (do phase.monad
- [_ (analysis/type.infer Any)]
- (wrap (#analysis.Extension extension (list (analysis.text name))))))]))
-
-(def: scheme::apply
- Handler
- (custom
- [($_ <>.and <c>.any (<>.some <c>.any))
- (function (_ extension phase archive [abstractionC inputsC])
- (do {! phase.monad}
- [abstractionA (analysis/type.with_type ..Function
- (phase archive abstractionC))
- inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC)
- _ (analysis/type.infer Any)]
- (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))]))
-
-(def: #export bundle
- Bundle
- (<| (bundle.prefix "scheme")
- (|> bundle.empty
- (dictionary.merge bundle::array)
- (dictionary.merge bundle::object)
-
- (bundle.install "constant" scheme::constant)
- (bundle.install "apply" scheme::apply)
- (bundle.install "script universe" (/.nullary .Bit))
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/bundle.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/bundle.lux
deleted file mode 100644
index 147904b62..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/bundle.lux
+++ /dev/null
@@ -1,28 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]
- ["." dictionary (#+ Dictionary)]]]]
- [// (#+ Handler Bundle)])
-
-(def: #export empty
- Bundle
- (dictionary.new text.hash))
-
-(def: #export (install name anonymous)
- (All [s i o]
- (-> Text (Handler s i o)
- (-> (Bundle s i o) (Bundle s i o))))
- (dictionary.put name anonymous))
-
-(def: #export (prefix prefix)
- (All [s i o]
- (-> Text (-> (Bundle s i o) (Bundle s i o))))
- (|>> dictionary.entries
- (list\map (function (_ [key val]) [(format prefix " " key) val]))
- (dictionary.from_list text.hash)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux
deleted file mode 100644
index a00fe5273..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux
+++ /dev/null
@@ -1,306 +0,0 @@
-(.module:
- [lux (#- Type Definition)
- ["." host]
- [abstract
- ["." monad (#+ do)]]
- [control
- [pipe (#+ case>)]
- ["<>" parser ("#\." monad)
- ["<c>" code (#+ Parser)]
- ["<t>" text]]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." dictionary]
- ["." row]]]
- [macro
- ["." template]]
- [math
- [number
- ["." i32]]]
- [target
- [jvm
- ["_" bytecode (#+ Bytecode)]
- ["." modifier (#+ Modifier) ("#\." monoid)]
- ["." attribute]
- ["." field]
- ["." version]
- ["." class]
- ["." constant
- ["." pool (#+ Resource)]]
- [encoding
- ["." name]]
- ["." type (#+ Type Constraint Argument Typed)
- [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
- [".T" lux (#+ Mapping)]
- ["." signature]
- ["." descriptor (#+ Descriptor)]
- ["." parser]]]]
- [tool
- [compiler
- ["." analysis]
- ["." synthesis]
- ["." generation]
- ["." directive (#+ Handler Bundle)]
- ["." phase
- [analysis
- [".A" type]]
- ["." generation
- [jvm
- [runtime (#+ Anchor Definition)]]]
- ["." extension
- ["." bundle]
- [analysis
- ["." jvm]]
- [directive
- ["/" lux]]]]]]
- [type
- ["." check (#+ Check)]]])
-
-(type: Operation
- (directive.Operation Anchor (Bytecode Any) Definition))
-
-(def: signature (|>> type.signature signature.signature))
-
-(type: Declaration
- [Text (List (Type Var))])
-
-(def: declaration
- (Parser Declaration)
- (<c>.form (<>.and <c>.text (<>.some jvm.var))))
-
-(def: visibility
- (Parser (Modifier field.Field))
- (`` ($_ <>.either
- (~~ (template [<label> <modifier>]
- [(<>.after (<c>.text! <label>) (<>\wrap <modifier>))]
-
- ["public" field.public]
- ["private" field.private]
- ["protected" field.protected]
- ["default" modifier.empty])))))
-
-(def: inheritance
- (Parser (Modifier class.Class))
- (`` ($_ <>.either
- (~~ (template [<label> <modifier>]
- [(<>.after (<c>.text! <label>) (<>\wrap <modifier>))]
-
- ["final" class.final]
- ["abstract" class.abstract]
- ["default" modifier.empty])))))
-
-(def: state
- (Parser (Modifier field.Field))
- (`` ($_ <>.either
- (~~ (template [<label> <modifier>]
- [(<>.after (<c>.text! <label>) (<>\wrap <modifier>))]
-
- ["volatile" field.volatile]
- ["final" field.final]
- ["default" modifier.empty])))))
-
-(type: Annotation Any)
-
-(def: annotation
- (Parser Annotation)
- <c>.any)
-
-(def: field-type
- (Parser (Type Value))
- (<t>.embed parser.value <c>.text))
-
-(type: Constant
- [Text (List Annotation) (Type Value) Code])
-
-(def: constant
- (Parser Constant)
- (<| <c>.form
- (<>.after (<c>.text! "constant"))
- ($_ <>.and
- <c>.text
- (<c>.tuple (<>.some ..annotation))
- ..field-type
- <c>.any
- )))
-
-(type: Variable
- [Text (Modifier field.Field) (Modifier field.Field) (List Annotation) (Type Value)])
-
-(def: variable
- (Parser Variable)
- (<| <c>.form
- (<>.after (<c>.text! "variable"))
- ($_ <>.and
- <c>.text
- ..visibility
- ..state
- (<c>.tuple (<>.some ..annotation))
- ..field-type
- )))
-
-(type: Field
- (#Constant Constant)
- (#Variable Variable))
-
-(def: field
- (Parser Field)
- ($_ <>.or
- ..constant
- ..variable
- ))
-
-(type: Method-Definition
- (#Constructor (jvm.Constructor Code))
- (#Virtual-Method (jvm.Virtual-Method Code))
- (#Static-Method (jvm.Static-Method Code))
- (#Overriden-Method (jvm.Overriden-Method Code)))
-
-(def: method
- (Parser Method-Definition)
- ($_ <>.or
- jvm.constructor-definition
- jvm.virtual-method-definition
- jvm.static-method-definition
- jvm.overriden-method-definition
- ))
-
-(def: (constraint name)
- (-> Text Constraint)
- {#type.name name
- #type.super-class (type.class "java.lang.Object" (list))
- #type.super-interfaces (list)})
-
-(def: constant::modifier
- (Modifier field.Field)
- ($_ modifier\compose
- field.public
- field.static
- field.final))
-
-(def: (field-definition field)
- (-> Field (Resource field.Field))
- (case field
- ## TODO: Handle annotations.
- (#Constant [name annotations type value])
- (case value
- (^template [<tag> <type> <constant>]
- [[_ (<tag> value)]
- (do pool.monad
- [constant (`` (|> value (~~ (template.splice <constant>))))
- attribute (attribute.constant constant)]
- (field.field ..constant::modifier name <type> (row.row attribute)))])
- ([#.Bit type.boolean [(case> #0 +0 #1 +1) .i64 i32.i32 constant.integer pool.integer]]
- [#.Int type.byte [.i64 i32.i32 constant.integer pool.integer]]
- [#.Int type.short [.i64 i32.i32 constant.integer pool.integer]]
- [#.Int type.int [.i64 i32.i32 constant.integer pool.integer]]
- [#.Int type.long [constant.long pool.long]]
- [#.Frac type.float [host.double-to-float constant.float pool.float]]
- [#.Frac type.double [constant.double pool.double]]
- [#.Nat type.char [.i64 i32.i32 constant.integer pool.integer]]
- [#.Text (type.class "java.lang.String" (list)) [pool.string]]
- )
-
- ## TODO: Tighten this pattern-matching so this catch-all clause isn't necessary.
- _
- (undefined))
-
- ## TODO: Handle annotations.
- (#Variable [name visibility state annotations type])
- (field.field (modifier\compose visibility state)
- name type (row.row))))
-
-(def: (method-definition [mapping selfT] [analyse synthesize generate])
- (-> [Mapping .Type]
- [analysis.Phase
- synthesis.Phase
- (generation.Phase Anchor (Bytecode Any) Definition)]
- (-> Method-Definition (Operation synthesis.Synthesis)))
- (function (_ methodC)
- (do phase.monad
- [methodA (: (Operation analysis.Analysis)
- (directive.lift-analysis
- (case methodC
- (#Constructor method)
- (jvm.analyse-constructor-method analyse selfT mapping method)
-
- (#Virtual-Method method)
- (jvm.analyse-virtual-method analyse selfT mapping method)
-
- (#Static-Method method)
- (jvm.analyse-static-method analyse mapping method)
-
- (#Overriden-Method method)
- (jvm.analyse-overriden-method analyse selfT mapping method))))]
- (directive.lift-synthesis
- (synthesize methodA)))))
-
-(def: jvm::class
- (Handler Anchor (Bytecode Any) Definition)
- (/.custom
- [($_ <>.and
- ..declaration
- jvm.class
- (<c>.tuple (<>.some jvm.class))
- ..inheritance
- (<c>.tuple (<>.some ..annotation))
- (<c>.tuple (<>.some ..field))
- (<c>.tuple (<>.some ..method)))
- (function (_ extension phase
- [[name parameters]
- super-class
- super-interfaces
- inheritance
- ## TODO: Handle annotations.
- annotations
- fields
- methods])
- (do {! phase.monad}
- [parameters (directive.lift-analysis
- (typeA.with-env
- (jvm.parameter-types parameters)))
- #let [mapping (list\fold (function (_ [parameterJ parameterT] mapping)
- (dictionary.put (parser.name parameterJ) parameterT mapping))
- luxT.fresh
- parameters)]
- super-classT (directive.lift-analysis
- (typeA.with-env
- (luxT.check (luxT.class mapping) (..signature super-class))))
- super-interfaceT+ (directive.lift-analysis
- (typeA.with-env
- (monad.map check.monad
- (|>> ..signature (luxT.check (luxT.class mapping)))
- super-interfaces)))
- #let [selfT (jvm.inheritance-relationship-type (#.Primitive name (list\map product.right parameters))
- super-classT
- super-interfaceT+)]
- state (extension.lift phase.get-state)
- #let [analyse (get@ [#directive.analysis #directive.phase] state)
- synthesize (get@ [#directive.synthesis #directive.phase] state)
- generate (get@ [#directive.generation #directive.phase] state)]
- methods (monad.map ! (..method-definition [mapping selfT] [analyse synthesize generate])
- methods)
- ## _ (directive.lift-generation
- ## (generation.save! true ["" name]
- ## [name
- ## (class.class version.v6_0
- ## (modifier\compose class.public inheritance)
- ## (name.internal name) (list\map (|>> product.left parser.name ..constraint) parameters)
- ## super-class super-interfaces
- ## (list\map ..field-definition fields)
- ## (list) ## TODO: Add methods
- ## (row.row))]))
- _ (directive.lift-generation
- (generation.log! (format "Class " name)))]
- (wrap directive.no-requirements)))]))
-
-(def: #export bundle
- (Bundle Anchor (Bytecode Any) Definition)
- (<| (bundle.prefix "jvm")
- (|> bundle.empty
- ## TODO: Finish handling methods and un-comment.
- ## (dictionary.put "class" jvm::class)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
deleted file mode 100644
index 9e405eb78..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
+++ /dev/null
@@ -1,450 +0,0 @@
-(.module:
- [lux #*
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- [io (#+ IO)]
- ["." try]
- ["." exception (#+ exception:)]
- ["p" parser
- ["s" code (#+ Parser)]]]
- [data
- ["." product]
- ["." maybe]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary]]]
- [macro
- ["." code]]
- [math
- [number
- ["n" nat]]]
- ["." type (#+ :share)
- ["." check]]]
- ["." /// (#+ Extender)
- ["#." bundle]
- ["#." analysis]
- ["/#" // #_
- [analysis
- ["." module]
- [".A" type]]
- ["/#" // #_
- ["#." analysis
- [macro (#+ Expander)]
- ["#/." evaluation]]
- ["#." synthesis (#+ Synthesis)]
- ["#." generation (#+ Context)]
- ["#." directive (#+ Import Requirements Phase Operation Handler Bundle)]
- ["#." program (#+ Program)]
- [///
- ["." phase]
- [meta
- ["." archive (#+ Archive)]]]]]])
-
-(def: #export (custom [syntax handler])
- (All [anchor expression directive s]
- (-> [(Parser s)
- (-> Text
- (Phase anchor expression directive)
- Archive
- s
- (Operation anchor expression directive Requirements))]
- (Handler anchor expression directive)))
- (function (_ extension_name phase archive inputs)
- (case (s.run syntax inputs)
- (#try.Success inputs)
- (handler extension_name phase archive inputs)
-
- (#try.Failure error)
- (phase.throw ///.invalid_syntax [extension_name %.code inputs]))))
-
-(def: (context [module_id artifact_id])
- (-> Context Context)
- ## TODO: Find a better way that doesn't rely on clever tricks.
- [module_id (n.- (inc artifact_id) 0)])
-
-## TODO: Inline "evaluate!'" into "evaluate!" ASAP
-(def: (evaluate!' archive generate code//type codeS)
- (All [anchor expression directive]
- (-> Archive
- (/////generation.Phase anchor expression directive)
- Type
- Synthesis
- (Operation anchor expression directive [Type expression Any])))
- (/////directive.lift_generation
- (do phase.monad
- [module /////generation.module
- id /////generation.next
- codeG (generate archive codeS)
- module_id (/////generation.module_id module archive)
- codeV (/////generation.evaluate! (..context [module_id id]) codeG)]
- (wrap [code//type codeG codeV]))))
-
-(def: #export (evaluate! archive type codeC)
- (All [anchor expression directive]
- (-> Archive Type Code (Operation anchor expression directive [Type expression Any])))
- (do phase.monad
- [state (///.lift phase.get_state)
- #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state)
- synthesize (get@ [#/////directive.synthesis #/////directive.phase] state)
- generate (get@ [#/////directive.generation #/////directive.phase] state)]
- [_ codeA] (/////directive.lift_analysis
- (/////analysis.with_scope
- (typeA.with_fresh_env
- (typeA.with_type type
- (analyse archive codeC)))))
- codeS (/////directive.lift_synthesis
- (synthesize archive codeA))]
- (evaluate!' archive generate type codeS)))
-
-## TODO: Inline "definition'" into "definition" ASAP
-(def: (definition' archive generate [module name] code//type codeS)
- (All [anchor expression directive]
- (-> Archive
- (/////generation.Phase anchor expression directive)
- Name
- Type
- Synthesis
- (Operation anchor expression directive [Type expression Any])))
- (/////directive.lift_generation
- (do phase.monad
- [codeG (generate archive codeS)
- id (/////generation.learn name)
- module_id (phase.lift (archive.id module archive))
- [target_name value directive] (/////generation.define! [module_id id] codeG)
- _ (/////generation.save! id directive)]
- (wrap [code//type codeG value]))))
-
-(def: (definition archive name expected codeC)
- (All [anchor expression directive]
- (-> Archive Name (Maybe Type) Code
- (Operation anchor expression directive [Type expression Any])))
- (do {! phase.monad}
- [state (///.lift phase.get_state)
- #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state)
- synthesize (get@ [#/////directive.synthesis #/////directive.phase] state)
- generate (get@ [#/////directive.generation #/////directive.phase] state)]
- [_ code//type codeA] (/////directive.lift_analysis
- (/////analysis.with_scope
- (typeA.with_fresh_env
- (case expected
- #.None
- (do !
- [[code//type codeA] (typeA.with_inference
- (analyse archive codeC))
- code//type (typeA.with_env
- (check.clean code//type))]
- (wrap [code//type codeA]))
-
- (#.Some expected)
- (do !
- [codeA (typeA.with_type expected
- (analyse archive codeC))]
- (wrap [expected codeA]))))))
- codeS (/////directive.lift_synthesis
- (synthesize archive codeA))]
- (definition' archive generate name code//type codeS)))
-
-(template [<full> <partial> <learn>]
- [## TODO: Inline "<partial>" into "<full>" ASAP
- (def: (<partial> archive generate extension codeT codeS)
- (All [anchor expression directive]
- (-> Archive
- (/////generation.Phase anchor expression directive)
- Text
- Type
- Synthesis
- (Operation anchor expression directive [expression Any])))
- (do phase.monad
- [current_module (/////directive.lift_analysis
- (///.lift meta.current_module_name))]
- (/////directive.lift_generation
- (do phase.monad
- [codeG (generate archive codeS)
- module_id (phase.lift (archive.id current_module archive))
- id (<learn> extension)
- [target_name value directive] (/////generation.define! [module_id id] codeG)
- _ (/////generation.save! id directive)]
- (wrap [codeG value])))))
-
- (def: #export (<full> archive extension codeT codeC)
- (All [anchor expression directive]
- (-> Archive Text Type Code
- (Operation anchor expression directive [expression Any])))
- (do phase.monad
- [state (///.lift phase.get_state)
- #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state)
- synthesize (get@ [#/////directive.synthesis #/////directive.phase] state)
- generate (get@ [#/////directive.generation #/////directive.phase] state)]
- [_ codeA] (/////directive.lift_analysis
- (/////analysis.with_scope
- (typeA.with_fresh_env
- (typeA.with_type codeT
- (analyse archive codeC)))))
- codeS (/////directive.lift_synthesis
- (synthesize archive codeA))]
- (<partial> archive generate extension codeT codeS)))]
-
- [analyser analyser' /////generation.learn_analyser]
- [synthesizer synthesizer' /////generation.learn_synthesizer]
- [generator generator' /////generation.learn_generator]
- [directive directive' /////generation.learn_directive]
- )
-
-(def: (refresh expander host_analysis)
- (All [anchor expression directive]
- (-> Expander /////analysis.Bundle (Operation anchor expression directive Any)))
- (do phase.monad
- [[bundle state] phase.get_state
- #let [eval (/////analysis/evaluation.evaluator expander
- (get@ [#/////directive.synthesis #/////directive.state] state)
- (get@ [#/////directive.generation #/////directive.state] state)
- (get@ [#/////directive.generation #/////directive.phase] state))]]
- (phase.set_state [bundle
- (update@ [#/////directive.analysis #/////directive.state]
- (: (-> /////analysis.State+ /////analysis.State+)
- (|>> product.right
- [(///analysis.bundle eval host_analysis)]))
- state)])))
-
-(def: (announce_definition! short type)
- (All [anchor expression directive]
- (-> Text Type (Operation anchor expression directive Any)))
- (/////directive.lift_generation
- (/////generation.log! (format short " : " (%.type type)))))
-
-(def: (lux::def expander host_analysis)
- (-> Expander /////analysis.Bundle Handler)
- (function (_ extension_name phase archive inputsC+)
- (case inputsC+
- (^ (list [_ (#.Identifier ["" short_name])] valueC annotationsC [_ (#.Bit exported?)]))
- (do phase.monad
- [current_module (/////directive.lift_analysis
- (///.lift meta.current_module_name))
- #let [full_name [current_module short_name]]
- [type valueT value] (..definition archive full_name #.None valueC)
- [_ annotationsT annotations] (evaluate! archive Code annotationsC)
- _ (/////directive.lift_analysis
- (module.define short_name (#.Right [exported? type (:as Code annotations) value])))
- _ (..refresh expander host_analysis)
- _ (..announce_definition! short_name type)]
- (wrap /////directive.no_requirements))
-
- _
- (phase.throw ///.invalid_syntax [extension_name %.code inputsC+]))))
-
-(def: (def::type_tagged expander host_analysis)
- (-> Expander /////analysis.Bundle Handler)
- (..custom
- [($_ p.and s.local_identifier s.any s.any (s.tuple (p.some s.text)) s.bit)
- (function (_ extension_name phase archive [short_name valueC annotationsC tags exported?])
- (do phase.monad
- [current_module (/////directive.lift_analysis
- (///.lift meta.current_module_name))
- #let [full_name [current_module short_name]]
- [_ annotationsT annotations] (evaluate! archive Code annotationsC)
- #let [annotations (:as Code annotations)]
- [type valueT value] (..definition archive full_name (#.Some .Type) valueC)
- _ (/////directive.lift_analysis
- (do phase.monad
- [_ (module.define short_name (#.Right [exported? type annotations value]))]
- (module.declare_tags tags exported? (:as Type value))))
- _ (..refresh expander host_analysis)
- _ (..announce_definition! short_name type)]
- (wrap /////directive.no_requirements)))]))
-
-(def: imports
- (Parser (List Import))
- (|> (s.tuple (p.and s.text s.text))
- p.some
- s.tuple))
-
-(def: def::module
- Handler
- (..custom
- [($_ p.and s.any ..imports)
- (function (_ extension_name phase archive [annotationsC imports])
- (do {! phase.monad}
- [[_ annotationsT annotationsV] (evaluate! archive Code annotationsC)
- #let [annotationsV (:as Code annotationsV)]
- _ (/////directive.lift_analysis
- (do !
- [_ (monad.map ! (function (_ [module alias])
- (do !
- [_ (module.import module)]
- (case alias
- "" (wrap [])
- _ (module.alias alias module))))
- imports)]
- (module.set_annotations annotationsV)))]
- (wrap {#/////directive.imports imports
- #/////directive.referrals (list)})))]))
-
-(exception: #export (cannot_alias_an_alias {local Alias} {foreign Alias} {target Name})
- (exception.report
- ["Local alias" (%.name local)]
- ["Foreign alias" (%.name foreign)]
- ["Target definition" (%.name target)]))
-
-(def: (define_alias alias original)
- (-> Text Name (/////analysis.Operation Any))
- (do phase.monad
- [current_module (///.lift meta.current_module_name)
- constant (///.lift (meta.find_def original))]
- (case constant
- (#.Left de_aliased)
- (phase.throw ..cannot_alias_an_alias [[current_module alias] original de_aliased])
-
- (#.Right [exported? original_type original_annotations original_value])
- (module.define alias (#.Left original)))))
-
-(def: def::alias
- Handler
- (..custom
- [($_ p.and s.local_identifier s.identifier)
- (function (_ extension_name phase archive [alias def_name])
- (do phase.monad
- [_ (///.lift
- (phase.sub [(get@ [#/////directive.analysis #/////directive.state])
- (set@ [#/////directive.analysis #/////directive.state])]
- (define_alias alias def_name)))]
- (wrap /////directive.no_requirements)))]))
-
-(template [<description> <mame> <def_type> <type> <scope> <definer>]
- [(def: (<mame> [anchorT expressionT directiveT] extender)
- (All [anchor expression directive]
- (-> [Type Type Type] Extender
- (Handler anchor expression directive)))
- (function (handler extension_name phase archive inputsC+)
- (case inputsC+
- (^ (list nameC valueC))
- (do phase.monad
- [[_ _ name] (evaluate! archive Text nameC)
- [_ handlerV] (<definer> archive (:as Text name)
- (type <def_type>)
- valueC)
- _ (<| <scope>
- (///.install extender (:as Text name))
- (:share [anchor expression directive]
- (Handler anchor expression directive)
- handler
-
- <type>
- (:assume handlerV)))
- _ (/////directive.lift_generation
- (/////generation.log! (format <description> " " (%.text (:as Text name)))))]
- (wrap /////directive.no_requirements))
-
- _
- (phase.throw ///.invalid_syntax [extension_name %.code inputsC+]))))]
-
- ["Analysis"
- def::analysis
- /////analysis.Handler /////analysis.Handler
- /////directive.lift_analysis
- ..analyser]
- ["Synthesis"
- def::synthesis
- /////synthesis.Handler /////synthesis.Handler
- /////directive.lift_synthesis
- ..synthesizer]
- ["Generation"
- def::generation
- (/////generation.Handler anchorT expressionT directiveT) (/////generation.Handler anchor expression directive)
- /////directive.lift_generation
- ..generator]
- ["Directive"
- def::directive
- (/////directive.Handler anchorT expressionT directiveT) (/////directive.Handler anchor expression directive)
- (<|)
- ..directive]
- )
-
-## TODO; Both "prepare-program" and "define-program" exist only
-## because the old compiler couldn't handle a fully-inlined definition
-## for "def::program". Inline them ASAP.
-(def: (prepare_program archive analyse synthesize programC)
- (All [anchor expression directive output]
- (-> Archive
- /////analysis.Phase
- /////synthesis.Phase
- Code
- (Operation anchor expression directive Synthesis)))
- (do phase.monad
- [[_ programA] (/////directive.lift_analysis
- (/////analysis.with_scope
- (typeA.with_fresh_env
- (typeA.with_type (type (-> (List Text) (IO Any)))
- (analyse archive programC)))))]
- (/////directive.lift_synthesis
- (synthesize archive programA))))
-
-(def: (define_program archive module_id generate program programS)
- (All [anchor expression directive output]
- (-> Archive
- archive.ID
- (/////generation.Phase anchor expression directive)
- (Program expression directive)
- Synthesis
- (/////generation.Operation anchor expression directive Any)))
- (do phase.monad
- [programG (generate archive programS)
- artifact_id (/////generation.learn /////program.name)]
- (/////generation.save! artifact_id (program [module_id artifact_id] programG))))
-
-(def: (def::program program)
- (All [anchor expression directive]
- (-> (Program expression directive) (Handler anchor expression directive)))
- (function (handler extension_name phase archive inputsC+)
- (case inputsC+
- (^ (list programC))
- (do phase.monad
- [state (///.lift phase.get_state)
- #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state)
- synthesize (get@ [#/////directive.synthesis #/////directive.phase] state)
- generate (get@ [#/////directive.generation #/////directive.phase] state)]
- programS (prepare_program archive analyse synthesize programC)
- current_module (/////directive.lift_analysis
- (///.lift meta.current_module_name))
- module_id (phase.lift (archive.id current_module archive))
- _ (/////directive.lift_generation
- (define_program archive module_id generate program programS))]
- (wrap /////directive.no_requirements))
-
- _
- (phase.throw ///.invalid_syntax [extension_name %.code inputsC+]))))
-
-(def: (bundle::def expander host_analysis program anchorT,expressionT,directiveT extender)
- (All [anchor expression directive]
- (-> Expander
- /////analysis.Bundle
- (Program expression directive)
- [Type Type Type]
- Extender
- (Bundle anchor expression directive)))
- (<| (///bundle.prefix "def")
- (|> ///bundle.empty
- (dictionary.put "module" def::module)
- (dictionary.put "alias" def::alias)
- (dictionary.put "type tagged" (def::type_tagged expander host_analysis))
- (dictionary.put "analysis" (def::analysis anchorT,expressionT,directiveT extender))
- (dictionary.put "synthesis" (def::synthesis anchorT,expressionT,directiveT extender))
- (dictionary.put "generation" (def::generation anchorT,expressionT,directiveT extender))
- (dictionary.put "directive" (def::directive anchorT,expressionT,directiveT extender))
- (dictionary.put "program" (def::program program))
- )))
-
-(def: #export (bundle expander host_analysis program anchorT,expressionT,directiveT extender)
- (All [anchor expression directive]
- (-> Expander
- /////analysis.Bundle
- (Program expression directive)
- [Type Type Type]
- Extender
- (Bundle anchor expression directive)))
- (<| (///bundle.prefix "lux")
- (|> ///bundle.empty
- (dictionary.put "def" (lux::def expander host_analysis))
- (dictionary.merge (..bundle::def expander host_analysis program anchorT,expressionT,directiveT extender)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux
deleted file mode 100644
index dc81d4b18..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux
+++ /dev/null
@@ -1,17 +0,0 @@
-(.module:
- [lux #*
- [data
- [collection
- ["." dictionary]]]]
- ["." / #_
- ["#." common]
- ["#." host]
- [////
- [generation
- [common_lisp
- [runtime (#+ Bundle)]]]]])
-
-(def: #export bundle
- Bundle
- (dictionary.merge /common.bundle
- /host.bundle))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux
deleted file mode 100644
index d1ad7bd99..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux
+++ /dev/null
@@ -1,179 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["." try]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary]
- ["." set]
- ["." list ("#\." functor fold)]]]
- [math
- [number
- ["f" frac]]]
- ["@" target
- ["_" common_lisp (#+ Expression)]]]
- ["." //// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["." reference]
- ["//" common_lisp #_
- ["#." runtime (#+ Operation Phase Handler Bundle Generator)]
- ["#." case]]]
- [//
- ["." synthesis (#+ %synthesis)]
- ["." generation]
- [///
- ["#" phase]]]]])
-
-(def: #export (custom [parser handler])
- (All [s]
- (-> [(Parser s)
- (-> Text (Generator s))]
- Handler))
- (function (_ extension_name phase archive input)
- (case (<s>.run parser input)
- (#try.Success input')
- (handler extension_name phase archive input')
-
- (#try.Failure error)
- (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
-
-(template: (!unary function)
- (|>> list _.apply/* (|> (_.constant function))))
-
-## ## TODO: Get rid of this ASAP
-## (def: lux::syntax_char_case!
-## (..custom [($_ <>.and
-## <s>.any
-## <s>.any
-## (<>.some (<s>.tuple ($_ <>.and
-## (<s>.tuple (<>.many <s>.i64))
-## <s>.any))))
-## (function (_ extension_name phase archive [input else conditionals])
-## (do {! /////.monad}
-## [@input (\ ! map _.var (generation.gensym "input"))
-## inputG (phase archive input)
-## elseG (phase archive else)
-## conditionalsG (: (Operation (List [Expression Expression]))
-## (monad.map ! (function (_ [chars branch])
-## (do !
-## [branchG (phase archive branch)]
-## (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or)
-## branchG])))
-## conditionals))]
-## (wrap (_.let (list [@input inputG])
-## (list (list\fold (function (_ [test then] else)
-## (_.if test then else))
-## elseG
-## conditionalsG))))))]))
-
-(def: lux_procs
- Bundle
- (|> /.empty
- ## (/.install "syntax char case!" lux::syntax_char_case!)
- (/.install "is" (binary _.eq/2))
- ## (/.install "try" (unary //runtime.lux//try))
- ))
-
-## (def: (capped operation parameter subject)
-## (-> (-> Expression Expression Expression)
-## (-> Expression Expression Expression))
-## (//runtime.i64//64 (operation parameter subject)))
-
-(def: i64_procs
- Bundle
- (<| (/.prefix "i64")
- (|> /.empty
- (/.install "and" (binary _.logand/2))
- (/.install "or" (binary _.logior/2))
- (/.install "xor" (binary _.logxor/2))
- (/.install "left-shift" (binary _.ash/2))
- (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift)))
- (/.install "=" (binary _.=/2))
- (/.install "<" (binary _.</2))
- (/.install "+" (binary _.+/2))
- (/.install "-" (binary _.-/2))
- (/.install "*" (binary _.*/2))
- (/.install "/" (binary _.floor/2))
- (/.install "%" (binary _.rem/2))
- ## (/.install "f64" (unary (_.//2 (_.float +1.0))))
- (/.install "char" (unary (|>> _.code-char/1 _.string/1)))
- )))
-
-(def: f64_procs
- Bundle
- (<| (/.prefix "f64")
- (|> /.empty
- ## (/.install "=" (binary (product.uncurry _.=/2)))
- ## (/.install "<" (binary (product.uncurry _.</2)))
- ## (/.install "+" (binary (product.uncurry _.+/2)))
- ## (/.install "-" (binary (product.uncurry _.-/2)))
- ## (/.install "*" (binary (product.uncurry _.*/2)))
- ## (/.install "/" (binary (product.uncurry _.//2)))
- ## (/.install "%" (binary (product.uncurry _.rem/2)))
- ## (/.install "i64" (unary _.truncate/1))
- (/.install "encode" (unary _.write-to-string/1))
- ## (/.install "decode" (unary //runtime.f64//decode))
- )))
-
-(def: (text//index [offset sub text])
- (Trinary (Expression Any))
- (//runtime.text//index offset sub text))
-
-(def: (text//clip [offset length text])
- (Trinary (Expression Any))
- (//runtime.text//clip offset length text))
-
-(def: (text//char [index text])
- (Binary (Expression Any))
- (_.char-code/1 (_.char/2 [text index])))
-
-(def: text_procs
- Bundle
- (<| (/.prefix "text")
- (|> /.empty
- (/.install "=" (binary _.string=/2))
- ## (/.install "<" (binary (product.uncurry _.string<?/2)))
- (/.install "concat" (binary (function (_ [left right])
- (_.concatenate/3 [(_.symbol "string") left right]))))
- (/.install "index" (trinary ..text//index))
- (/.install "size" (unary _.length/1))
- (/.install "char" (binary ..text//char))
- (/.install "clip" (trinary ..text//clip))
- )))
-
-(def: (io//log! message)
- (Unary (Expression Any))
- (_.progn (list (_.write-line/1 message)
- //runtime.unit)))
-
-(def: io_procs
- Bundle
- (<| (/.prefix "io")
- (|> /.empty
- (/.install "log" (unary ..io//log!))
- (/.install "error" (unary _.error/1))
- )))
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "lux")
- (|> /.empty
- (dictionary.merge lux_procs)
- (dictionary.merge i64_procs)
- (dictionary.merge f64_procs)
- (dictionary.merge text_procs)
- (dictionary.merge io_procs)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux
deleted file mode 100644
index f6d164404..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux
+++ /dev/null
@@ -1,39 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- [collection
- ["." dictionary]
- ["." list]]
- [text
- ["%" format (#+ format)]]]
- [target
- ["_" common_lisp (#+ Var Expression)]]]
- ["." // #_
- ["#." common (#+ custom)]
- ["//#" /// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["." reference]
- ["//" common_lisp #_
- ["#." runtime (#+ Operation Phase Handler Bundle
- with_vars)]]]
- ["/#" // #_
- ["." generation]
- ["//#" /// #_
- ["#." phase]]]]]])
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "common_lisp")
- (|> /.empty
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js.lux
deleted file mode 100644
index 81d2fe57b..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js.lux
+++ /dev/null
@@ -1,17 +0,0 @@
-(.module:
- [lux #*
- [data
- [collection
- ["." dictionary]]]]
- ["." / #_
- ["#." common]
- ["#." host]
- [////
- [generation
- [js
- [runtime (#+ Bundle)]]]]])
-
-(def: #export bundle
- Bundle
- (dictionary.merge /common.bundle
- /host.bundle))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux
deleted file mode 100644
index deffe31d8..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux
+++ /dev/null
@@ -1,190 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- ["." product]
- [collection
- ["." list ("#\." functor)]
- ["." dictionary]]]
- [math
- [number
- ["f" frac]]]
- ["@" target
- ["_" js (#+ Literal Expression Statement)]]]
- ["." //// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["//" js #_
- ["#." runtime (#+ Operation Phase Handler Bundle Generator)]
- ["#." primitive]]]
- [//
- [synthesis (#+ %synthesis)]
- [///
- ["#" phase]]]]])
-
-(def: #export (custom [parser handler])
- (All [s]
- (-> [(Parser s)
- (-> Text (Generator s))]
- Handler))
- (function (_ extension_name phase archive input)
- (case (<s>.run parser input)
- (#try.Success input')
- (handler extension_name phase archive input')
-
- (#try.Failure error)
- (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
-
-## [Procedures]
-## [[Bits]]
-(template [<name> <op>]
- [(def: (<name> [paramG subjectG])
- (Binary Expression)
- (<op> subjectG (//runtime.i64//to_number paramG)))]
-
- [i64//left_shift //runtime.i64//left_shift]
- [i64//right_shift //runtime.i64//right_shift]
- )
-
-## [[Numbers]]
-(def: f64//decode
- (Unary Expression)
- (|>> list
- (_.apply/* (_.var "parseFloat"))
- _.return
- (_.closure (list))
- //runtime.lux//try))
-
-(def: i64//char
- (Unary Expression)
- (|>> //runtime.i64//to_number
- (list)
- (_.apply/* (_.var "String.fromCharCode"))))
-
-## [[Text]]
-(def: (text//concat [leftG rightG])
- (Binary Expression)
- (|> leftG (_.do "concat" (list rightG))))
-
-(def: (text//clip [startG endG subjectG])
- (Trinary Expression)
- (//runtime.text//clip startG endG subjectG))
-
-(def: (text//index [startG partG subjectG])
- (Trinary Expression)
- (//runtime.text//index startG partG subjectG))
-
-## [[IO]]
-(def: (io//log messageG)
- (Unary Expression)
- ($_ _.,
- (//runtime.io//log messageG)
- //runtime.unit))
-
-## TODO: Get rid of this ASAP
-(def: lux::syntax_char_case!
- (..custom [($_ <>.and
- <s>.any
- <s>.any
- (<>.some (<s>.tuple ($_ <>.and
- (<s>.tuple (<>.many <s>.i64))
- <s>.any))))
- (function (_ extension_name phase archive [input else conditionals])
- (do {! /////.monad}
- [inputG (phase archive input)
- elseG (phase archive else)
- conditionalsG (: (Operation (List [(List Literal)
- Statement]))
- (monad.map ! (function (_ [chars branch])
- (do !
- [branchG (phase archive branch)]
- (wrap [(list\map (|>> .int _.int) chars)
- (_.return branchG)])))
- conditionals))]
- (wrap (_.apply/* (_.closure (list)
- (_.switch (_.the //runtime.i64_low_field inputG)
- conditionalsG
- (#.Some (_.return elseG))))
- (list)))))]))
-
-## [Bundles]
-(def: lux_procs
- Bundle
- (|> /.empty
- (/.install "syntax char case!" lux::syntax_char_case!)
- (/.install "is" (binary (product.uncurry _.=)))
- (/.install "try" (unary //runtime.lux//try))))
-
-(def: i64_procs
- Bundle
- (<| (/.prefix "i64")
- (|> /.empty
- (/.install "and" (binary (product.uncurry //runtime.i64//and)))
- (/.install "or" (binary (product.uncurry //runtime.i64//or)))
- (/.install "xor" (binary (product.uncurry //runtime.i64//xor)))
- (/.install "left-shift" (binary i64//left_shift))
- (/.install "right-shift" (binary i64//right_shift))
- (/.install "=" (binary (product.uncurry //runtime.i64//=)))
- (/.install "<" (binary (product.uncurry //runtime.i64//<)))
- (/.install "+" (binary (product.uncurry //runtime.i64//+)))
- (/.install "-" (binary (product.uncurry //runtime.i64//-)))
- (/.install "*" (binary (product.uncurry //runtime.i64//*)))
- (/.install "/" (binary (product.uncurry //runtime.i64///)))
- (/.install "%" (binary (product.uncurry //runtime.i64//%)))
- (/.install "f64" (unary //runtime.i64//to_number))
- (/.install "char" (unary i64//char))
- )))
-
-(def: f64_procs
- Bundle
- (<| (/.prefix "f64")
- (|> /.empty
- (/.install "+" (binary (product.uncurry _.+)))
- (/.install "-" (binary (product.uncurry _.-)))
- (/.install "*" (binary (product.uncurry _.*)))
- (/.install "/" (binary (product.uncurry _./)))
- (/.install "%" (binary (product.uncurry _.%)))
- (/.install "=" (binary (product.uncurry _.=)))
- (/.install "<" (binary (product.uncurry _.<)))
- (/.install "i64" (unary //runtime.i64//from_number))
- (/.install "encode" (unary (_.do "toString" (list))))
- (/.install "decode" (unary f64//decode)))))
-
-(def: text_procs
- Bundle
- (<| (/.prefix "text")
- (|> /.empty
- (/.install "=" (binary (product.uncurry _.=)))
- (/.install "<" (binary (product.uncurry _.<)))
- (/.install "concat" (binary text//concat))
- (/.install "index" (trinary text//index))
- (/.install "size" (unary (|>> (_.the "length") //runtime.i64//from_number)))
- (/.install "char" (binary (product.uncurry //runtime.text//char)))
- (/.install "clip" (trinary text//clip))
- )))
-
-(def: io_procs
- Bundle
- (<| (/.prefix "io")
- (|> /.empty
- (/.install "log" (unary io//log))
- (/.install "error" (unary //runtime.io//error)))))
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "lux")
- (|> lux_procs
- (dictionary.merge i64_procs)
- (dictionary.merge f64_procs)
- (dictionary.merge text_procs)
- (dictionary.merge io_procs)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux
deleted file mode 100644
index 45fb3e5d2..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux
+++ /dev/null
@@ -1,159 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- [collection
- ["." dictionary]
- ["." list]]]
- [target
- ["_" js (#+ Var Expression)]]]
- ["." // #_
- ["#." common (#+ custom)]
- ["//#" /// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["//" js #_
- ["#." runtime (#+ Operation Phase Handler Bundle
- with_vars)]]]
- ["/#" // #_
- ["." generation]
- ["//#" /// #_
- ["#." phase]]]]]])
-
-(def: array::new
- (Unary Expression)
- (|>> (_.the //runtime.i64_low_field) list (_.new (_.var "Array"))))
-
-(def: array::length
- (Unary Expression)
- (|>> (_.the "length") //runtime.i64//from_number))
-
-(def: (array::read [indexG arrayG])
- (Binary Expression)
- (_.at (_.the //runtime.i64_low_field indexG)
- arrayG))
-
-(def: (array::write [indexG valueG arrayG])
- (Trinary Expression)
- (//runtime.array//write indexG valueG arrayG))
-
-(def: (array::delete [indexG arrayG])
- (Binary Expression)
- (//runtime.array//delete indexG arrayG))
-
-(def: array
- Bundle
- (<| (/.prefix "array")
- (|> /.empty
- (/.install "new" (unary array::new))
- (/.install "length" (unary array::length))
- (/.install "read" (binary array::read))
- (/.install "write" (trinary array::write))
- (/.install "delete" (binary array::delete))
- )))
-
-(def: object::new
- (custom
- [($_ <>.and <s>.any (<>.some <s>.any))
- (function (_ extension phase archive [constructorS inputsS])
- (do {! ////////phase.monad}
- [constructorG (phase archive constructorS)
- inputsG (monad.map ! (phase archive) inputsS)]
- (wrap (_.new constructorG inputsG))))]))
-
-(def: object::get
- Handler
- (custom
- [($_ <>.and <s>.text <s>.any)
- (function (_ extension phase archive [fieldS objectS])
- (do ////////phase.monad
- [objectG (phase archive objectS)]
- (wrap (_.the fieldS objectG))))]))
-
-(def: object::do
- Handler
- (custom
- [($_ <>.and <s>.text <s>.any (<>.some <s>.any))
- (function (_ extension phase archive [methodS objectS inputsS])
- (do {! ////////phase.monad}
- [objectG (phase archive objectS)
- inputsG (monad.map ! (phase archive) inputsS)]
- (wrap (_.do methodS inputsG objectG))))]))
-
-(template [<!> <?> <unit>]
- [(def: <!> (Nullary Expression) (function.constant <unit>))
- (def: <?> (Unary Expression) (_.= <unit>))]
-
- [object::null object::null? _.null]
- [object::undefined object::undefined? _.undefined]
- )
-
-(def: object
- Bundle
- (<| (/.prefix "object")
- (|> /.empty
- (/.install "new" object::new)
- (/.install "get" object::get)
- (/.install "do" object::do)
- (/.install "null" (nullary object::null))
- (/.install "null?" (unary object::null?))
- (/.install "undefined" (nullary object::undefined))
- (/.install "undefined?" (unary object::undefined?))
- )))
-
-(def: js::constant
- (custom
- [<s>.text
- (function (_ extension phase archive name)
- (\ ////////phase.monad wrap (_.var name)))]))
-
-(def: js::apply
- (custom
- [($_ <>.and <s>.any (<>.some <s>.any))
- (function (_ extension phase archive [abstractionS inputsS])
- (do {! ////////phase.monad}
- [abstractionG (phase archive abstractionS)
- inputsG (monad.map ! (phase archive) inputsS)]
- (wrap (_.apply/* abstractionG inputsG))))]))
-
-(def: js::function
- (custom
- [($_ <>.and <s>.i64 <s>.any)
- (function (_ extension phase archive [arity abstractionS])
- (do {! ////////phase.monad}
- [abstractionG (phase archive abstractionS)
- #let [variable (: (-> Text (Operation Var))
- (|>> generation.gensym
- (\ ! map _.var)))]
- g!inputs (monad.map ! (function (_ _) (variable "input"))
- (list.repeat (.nat arity) []))
- g!abstraction (variable "abstraction")]
- (wrap (_.closure g!inputs
- ($_ _.then
- (_.define g!abstraction abstractionG)
- (_.return (case (.nat arity)
- 0 (_.apply/1 g!abstraction //runtime.unit)
- 1 (_.apply/* g!abstraction g!inputs)
- _ (_.apply/1 g!abstraction (_.array g!inputs)))))))))]))
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "js")
- (|> /.empty
- (dictionary.merge ..array)
- (dictionary.merge ..object)
-
- (/.install "constant" js::constant)
- (/.install "apply" js::apply)
- (/.install "type-of" (unary _.type_of))
- (/.install "function" js::function)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux
deleted file mode 100644
index 93816d128..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux
+++ /dev/null
@@ -1,19 +0,0 @@
-(.module:
- [lux #*
- [data
- [collection
- ["." dictionary]]]]
- ["." / #_
- ["#." common]
- ["#." host]
- [////
- [generation
- [jvm
- [runtime (#+ Bundle)]]]]])
-
-(def: #export bundle
- Bundle
- ($_ dictionary.merge
- /common.bundle
- /host.bundle
- ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux
deleted file mode 100644
index 24f82d1ef..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux
+++ /dev/null
@@ -1,413 +0,0 @@
-(.module:
- [lux (#- Type)
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- ["." product]
- [number
- ["." i32]
- ["f" frac]]
- [collection
- ["." list ("#\." monad)]
- ["." dictionary]]]
- [target
- [jvm
- ["_" bytecode (#+ Label Bytecode) ("#\." monad)]
- [encoding
- ["." signed (#+ S4)]]
- ["." type (#+ Type)
- [category (#+ Primitive Class)]]]]]
- ["." ///// #_
- [generation
- [extension (#+ Nullary Unary Binary Trinary Variadic
- nullary unary binary trinary variadic)]
- ["///" jvm #_
- ["#." value]
- ["#." runtime (#+ Operation Phase Bundle Handler)]
- ["#." function #_
- ["#" abstract]]]]
- [extension
- ["#extension" /]
- ["#." bundle]]
- [//
- ["/#." synthesis (#+ Synthesis %synthesis)]
- [///
- ["#" phase]
- [meta
- [archive (#+ Archive)]]]]])
-
-(def: #export (custom [parser handler])
- (All [s]
- (-> [(Parser s)
- (-> Text Phase Archive s (Operation (Bytecode Any)))]
- Handler))
- (function (_ extension-name phase archive input)
- (case (<s>.run parser input)
- (#try.Success input')
- (handler extension-name phase archive input')
-
- (#try.Failure error)
- (/////.throw /////extension.invalid-syntax [extension-name //////synthesis.%synthesis input]))))
-
-(def: $Boolean (type.class "java.lang.Boolean" (list)))
-(def: $Double (type.class "java.lang.Double" (list)))
-(def: $Character (type.class "java.lang.Character" (list)))
-(def: $String (type.class "java.lang.String" (list)))
-(def: $CharSequence (type.class "java.lang.CharSequence" (list)))
-(def: $Object (type.class "java.lang.Object" (list)))
-(def: $PrintStream (type.class "java.io.PrintStream" (list)))
-(def: $System (type.class "java.lang.System" (list)))
-(def: $Error (type.class "java.lang.Error" (list)))
-
-(def: lux-int
- (Bytecode Any)
- ($_ _.compose
- _.i2l
- (///value.wrap type.long)))
-
-(def: jvm-int
- (Bytecode Any)
- ($_ _.compose
- (///value.unwrap type.long)
- _.l2i))
-
-(def: ensure-string
- (Bytecode Any)
- (_.checkcast $String))
-
-(def: (predicate bytecode)
- (-> (-> Label (Bytecode Any))
- (Bytecode Any))
- (do _.monad
- [@then _.new-label
- @end _.new-label]
- ($_ _.compose
- (bytecode @then)
- (_.getstatic $Boolean "FALSE" $Boolean)
- (_.goto @end)
- (_.set-label @then)
- (_.getstatic $Boolean "TRUE" $Boolean)
- (_.set-label @end)
- )))
-
-## TODO: Get rid of this ASAP
-(def: lux::syntax-char-case!
- (..custom [($_ <>.and
- <s>.any
- <s>.any
- (<>.some (<s>.tuple ($_ <>.and
- (<s>.tuple (<>.many <s>.i64))
- <s>.any))))
- (function (_ extension-name phase archive [inputS elseS conditionalsS])
- (do {! /////.monad}
- [@end ///runtime.forge-label
- inputG (phase archive inputS)
- elseG (phase archive elseS)
- conditionalsG+ (: (Operation (List [(List [S4 Label])
- (Bytecode Any)]))
- (monad.map ! (function (_ [chars branch])
- (do !
- [branchG (phase archive branch)
- @branch ///runtime.forge-label]
- (wrap [(list\map (function (_ char)
- [(try.assume (signed.s4 (.int char))) @branch])
- chars)
- ($_ _.compose
- (_.set-label @branch)
- branchG
- (_.goto @end))])))
- conditionalsS))
- #let [table (|> conditionalsG+
- (list\map product.left)
- list\join)
- conditionalsG (|> conditionalsG+
- (list\map product.right)
- (monad.seq _.monad))]]
- (wrap (do _.monad
- [@else _.new-label]
- ($_ _.compose
- inputG (///value.unwrap type.long) _.l2i
- (_.lookupswitch @else table)
- conditionalsG
- (_.set-label @else)
- elseG
- (_.set-label @end)
- )))))]))
-
-(def: (lux::is [referenceG sampleG])
- (Binary (Bytecode Any))
- ($_ _.compose
- referenceG
- sampleG
- (..predicate _.if-acmpeq)))
-
-(def: (lux::try riskyG)
- (Unary (Bytecode Any))
- ($_ _.compose
- riskyG
- (_.checkcast ///function.class)
- ///runtime.try))
-
-(def: bundle::lux
- Bundle
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "syntax char case!" ..lux::syntax-char-case!)
- (/////bundle.install "is" (binary ..lux::is))
- (/////bundle.install "try" (unary ..lux::try))))
-
-(template [<name> <op>]
- [(def: (<name> [maskG inputG])
- (Binary (Bytecode Any))
- ($_ _.compose
- inputG (///value.unwrap type.long)
- maskG (///value.unwrap type.long)
- <op> (///value.wrap type.long)))]
-
- [i64::and _.land]
- [i64::or _.lor]
- [i64::xor _.lxor]
- )
-
-(template [<name> <op>]
- [(def: (<name> [shiftG inputG])
- (Binary (Bytecode Any))
- ($_ _.compose
- inputG (///value.unwrap type.long)
- shiftG ..jvm-int
- <op> (///value.wrap type.long)))]
-
- [i64::left-shift _.lshl]
- [i64::right-shift _.lushr]
- )
-
-(template [<name> <type> <op>]
- [(def: (<name> [paramG subjectG])
- (Binary (Bytecode Any))
- ($_ _.compose
- subjectG (///value.unwrap <type>)
- paramG (///value.unwrap <type>)
- <op> (///value.wrap <type>)))]
-
- [i64::+ type.long _.ladd]
- [i64::- type.long _.lsub]
- [i64::* type.long _.lmul]
- [i64::/ type.long _.ldiv]
- [i64::% type.long _.lrem]
-
- [f64::+ type.double _.dadd]
- [f64::- type.double _.dsub]
- [f64::* type.double _.dmul]
- [f64::/ type.double _.ddiv]
- [f64::% type.double _.drem]
- )
-
-(template [<eq> <lt> <type> <cmp>]
- [(template [<name> <reference>]
- [(def: (<name> [paramG subjectG])
- (Binary (Bytecode Any))
- ($_ _.compose
- subjectG (///value.unwrap <type>)
- paramG (///value.unwrap <type>)
- <cmp>
- <reference>
- (..predicate _.if-icmpeq)))]
-
- [<eq> _.iconst-0]
- [<lt> _.iconst-m1])]
-
- [i64::= i64::< type.long _.lcmp]
- [f64::= f64::< type.double _.dcmpg]
- )
-
-(def: (to-string class from)
- (-> (Type Class) (Type Primitive) (Bytecode Any))
- (_.invokestatic class "toString" (type.method [(list from) ..$String (list)])))
-
-(template [<name> <prepare> <transform>]
- [(def: (<name> inputG)
- (Unary (Bytecode Any))
- ($_ _.compose
- inputG
- <prepare>
- <transform>))]
-
- [i64::f64
- (///value.unwrap type.long)
- ($_ _.compose
- _.l2d
- (///value.wrap type.double))]
-
- [i64::char
- (///value.unwrap type.long)
- ($_ _.compose
- _.l2i
- _.i2c
- (..to-string ..$Character type.char))]
-
- [f64::i64
- (///value.unwrap type.double)
- ($_ _.compose
- _.d2l
- (///value.wrap type.long))]
-
- [f64::encode
- (///value.unwrap type.double)
- (..to-string ..$Double type.double)]
-
- [f64::decode
- ..ensure-string
- ///runtime.decode-frac]
- )
-
-(def: bundle::i64
- Bundle
- (<| (/////bundle.prefix "i64")
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "and" (binary ..i64::and))
- (/////bundle.install "or" (binary ..i64::or))
- (/////bundle.install "xor" (binary ..i64::xor))
- (/////bundle.install "left-shift" (binary ..i64::left-shift))
- (/////bundle.install "right-shift" (binary ..i64::right-shift))
- (/////bundle.install "=" (binary ..i64::=))
- (/////bundle.install "<" (binary ..i64::<))
- (/////bundle.install "+" (binary ..i64::+))
- (/////bundle.install "-" (binary ..i64::-))
- (/////bundle.install "*" (binary ..i64::*))
- (/////bundle.install "/" (binary ..i64::/))
- (/////bundle.install "%" (binary ..i64::%))
- (/////bundle.install "f64" (unary ..i64::f64))
- (/////bundle.install "char" (unary ..i64::char)))))
-
-(def: bundle::f64
- Bundle
- (<| (/////bundle.prefix "f64")
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "+" (binary ..f64::+))
- (/////bundle.install "-" (binary ..f64::-))
- (/////bundle.install "*" (binary ..f64::*))
- (/////bundle.install "/" (binary ..f64::/))
- (/////bundle.install "%" (binary ..f64::%))
- (/////bundle.install "=" (binary ..f64::=))
- (/////bundle.install "<" (binary ..f64::<))
- (/////bundle.install "i64" (unary ..f64::i64))
- (/////bundle.install "encode" (unary ..f64::encode))
- (/////bundle.install "decode" (unary ..f64::decode)))))
-
-(def: (text::size inputG)
- (Unary (Bytecode Any))
- ($_ _.compose
- inputG
- ..ensure-string
- (_.invokevirtual ..$String "length" (type.method [(list) type.int (list)]))
- ..lux-int))
-
-(def: no-op (Bytecode Any) (_\wrap []))
-
-(template [<name> <pre-subject> <pre-param> <op> <post>]
- [(def: (<name> [paramG subjectG])
- (Binary (Bytecode Any))
- ($_ _.compose
- subjectG <pre-subject>
- paramG <pre-param>
- <op> <post>))]
-
- [text::= ..no-op ..no-op
- (_.invokevirtual ..$Object "equals" (type.method [(list ..$Object) type.boolean (list)]))
- (///value.wrap type.boolean)]
- [text::< ..ensure-string ..ensure-string
- (_.invokevirtual ..$String "compareTo" (type.method [(list ..$String) type.int (list)]))
- (..predicate _.iflt)]
- [text::char ..ensure-string ..jvm-int
- (_.invokevirtual ..$String "charAt" (type.method [(list type.int) type.char (list)]))
- ..lux-int]
- )
-
-(def: (text::concat [leftG rightG])
- (Binary (Bytecode Any))
- ($_ _.compose
- leftG ..ensure-string
- rightG ..ensure-string
- (_.invokevirtual ..$String "concat" (type.method [(list ..$String) ..$String (list)]))))
-
-(def: (text::clip [startG endG subjectG])
- (Trinary (Bytecode Any))
- ($_ _.compose
- subjectG ..ensure-string
- startG ..jvm-int
- endG ..jvm-int
- (_.invokevirtual ..$String "substring" (type.method [(list type.int type.int) ..$String (list)]))))
-
-(def: index-method (type.method [(list ..$String type.int) type.int (list)]))
-(def: (text::index [startG partG textG])
- (Trinary (Bytecode Any))
- (do _.monad
- [@not-found _.new-label
- @end _.new-label]
- ($_ _.compose
- textG ..ensure-string
- partG ..ensure-string
- startG ..jvm-int
- (_.invokevirtual ..$String "indexOf" index-method)
- _.dup
- _.iconst-m1
- (_.if-icmpeq @not-found)
- ..lux-int
- ///runtime.some-injection
- (_.goto @end)
- (_.set-label @not-found)
- _.pop
- ///runtime.none-injection
- (_.set-label @end))))
-
-(def: bundle::text
- Bundle
- (<| (/////bundle.prefix "text")
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "=" (binary ..text::=))
- (/////bundle.install "<" (binary ..text::<))
- (/////bundle.install "concat" (binary ..text::concat))
- (/////bundle.install "index" (trinary ..text::index))
- (/////bundle.install "size" (unary ..text::size))
- (/////bundle.install "char" (binary ..text::char))
- (/////bundle.install "clip" (trinary ..text::clip)))))
-
-(def: string-method (type.method [(list ..$String) type.void (list)]))
-(def: (io::log messageG)
- (Unary (Bytecode Any))
- ($_ _.compose
- (_.getstatic ..$System "out" ..$PrintStream)
- messageG
- ..ensure-string
- (_.invokevirtual ..$PrintStream "println" ..string-method)
- ///runtime.unit))
-
-(def: (io::error messageG)
- (Unary (Bytecode Any))
- ($_ _.compose
- (_.new ..$Error)
- _.dup
- messageG
- ..ensure-string
- (_.invokespecial ..$Error "<init>" ..string-method)
- _.athrow))
-
-(def: bundle::io
- Bundle
- (<| (/////bundle.prefix "io")
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "log" (unary ..io::log))
- (/////bundle.install "error" (unary ..io::error)))))
-
-(def: #export bundle
- Bundle
- (<| (/////bundle.prefix "lux")
- (|> bundle::lux
- (dictionary.merge ..bundle::i64)
- (dictionary.merge ..bundle::f64)
- (dictionary.merge ..bundle::text)
- (dictionary.merge ..bundle::io))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
deleted file mode 100644
index 03ec04853..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
+++ /dev/null
@@ -1,1105 +0,0 @@
-(.module:
- [lux (#- Type)
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<t>" text]
- ["<s>" synthesis (#+ Parser)]]]
- [data
- ["." product]
- ["." maybe]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [number
- ["." i32]]
- [collection
- ["." list ("#\." monad)]
- ["." dictionary (#+ Dictionary)]
- ["." set]
- ["." row]]
- ["." format #_
- ["#" binary]]]
- [target
- [jvm
- ["." version]
- ["." modifier ("#\." monoid)]
- ["." method (#+ Method)]
- ["." class (#+ Class)]
- [constant
- [pool (#+ Resource)]]
- [encoding
- ["." name]]
- ["_" bytecode (#+ Label Bytecode) ("#\." monad)
- ["__" instruction (#+ Primitive-Array-Type)]]
- ["." type (#+ Type Typed Argument)
- ["." category (#+ Void Value' Value Return' Return Primitive Object Array Var Parameter)]
- ["." box]
- ["." reflection]
- ["." signature]
- ["." parser]]]]]
- ["." // #_
- [common (#+ custom)]
- ["///#" //// #_
- [generation
- [extension (#+ Nullary Unary Binary Trinary Variadic
- nullary unary binary trinary variadic)]
- ["///" jvm
- ["#." runtime (#+ Operation Bundle Phase Handler)]
- ["#." reference]
- [function
- [field
- [variable
- ["." foreign]]]]]]
- [extension
- ["#." bundle]
- [analysis
- ["/" jvm]]]
- ["/#" // #_
- [analysis (#+ Environment)]
- ["#." synthesis (#+ Synthesis Path %synthesis)]
- ["#." generation]
- [///
- ["#" phase]
- [reference
- ["#." variable (#+ Variable)]]
- [meta
- ["." archive (#+ Archive)]]]]]])
-
-(template [<name> <0> <1>]
- [(def: <name>
- (Bytecode Any)
- ($_ _.compose
- <0>
- <1>))]
-
- [l2s _.l2i _.i2s]
- [l2b _.l2i _.i2b]
- [l2c _.l2i _.i2c]
- )
-
-(template [<conversion> <name>]
- [(def: (<name> inputG)
- (Unary (Bytecode Any))
- (if (is? _.nop <conversion>)
- inputG
- ($_ _.compose
- inputG
- <conversion>)))]
-
- [_.d2f conversion::double-to-float]
- [_.d2i conversion::double-to-int]
- [_.d2l conversion::double-to-long]
- [_.f2d conversion::float-to-double]
- [_.f2i conversion::float-to-int]
- [_.f2l conversion::float-to-long]
- [_.i2b conversion::int-to-byte]
- [_.i2c conversion::int-to-char]
- [_.i2d conversion::int-to-double]
- [_.i2f conversion::int-to-float]
- [_.i2l conversion::int-to-long]
- [_.i2s conversion::int-to-short]
- [_.l2d conversion::long-to-double]
- [_.l2f conversion::long-to-float]
- [_.l2i conversion::long-to-int]
- [..l2s conversion::long-to-short]
- [..l2b conversion::long-to-byte]
- [..l2c conversion::long-to-char]
- [_.i2b conversion::char-to-byte]
- [_.i2s conversion::char-to-short]
- [_.nop conversion::char-to-int]
- [_.i2l conversion::char-to-long]
- [_.i2l conversion::byte-to-long]
- [_.i2l conversion::short-to-long]
- )
-
-(def: bundle::conversion
- Bundle
- (<| (/////bundle.prefix "conversion")
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "double-to-float" (unary conversion::double-to-float))
- (/////bundle.install "double-to-int" (unary conversion::double-to-int))
- (/////bundle.install "double-to-long" (unary conversion::double-to-long))
- (/////bundle.install "float-to-double" (unary conversion::float-to-double))
- (/////bundle.install "float-to-int" (unary conversion::float-to-int))
- (/////bundle.install "float-to-long" (unary conversion::float-to-long))
- (/////bundle.install "int-to-byte" (unary conversion::int-to-byte))
- (/////bundle.install "int-to-char" (unary conversion::int-to-char))
- (/////bundle.install "int-to-double" (unary conversion::int-to-double))
- (/////bundle.install "int-to-float" (unary conversion::int-to-float))
- (/////bundle.install "int-to-long" (unary conversion::int-to-long))
- (/////bundle.install "int-to-short" (unary conversion::int-to-short))
- (/////bundle.install "long-to-double" (unary conversion::long-to-double))
- (/////bundle.install "long-to-float" (unary conversion::long-to-float))
- (/////bundle.install "long-to-int" (unary conversion::long-to-int))
- (/////bundle.install "long-to-short" (unary conversion::long-to-short))
- (/////bundle.install "long-to-byte" (unary conversion::long-to-byte))
- (/////bundle.install "long-to-char" (unary conversion::long-to-char))
- (/////bundle.install "char-to-byte" (unary conversion::char-to-byte))
- (/////bundle.install "char-to-short" (unary conversion::char-to-short))
- (/////bundle.install "char-to-int" (unary conversion::char-to-int))
- (/////bundle.install "char-to-long" (unary conversion::char-to-long))
- (/////bundle.install "byte-to-long" (unary conversion::byte-to-long))
- (/////bundle.install "short-to-long" (unary conversion::short-to-long))
- )))
-
-(template [<name> <op>]
- [(def: (<name> [xG yG])
- (Binary (Bytecode Any))
- ($_ _.compose
- xG
- yG
- <op>))]
-
- [int::+ _.iadd]
- [int::- _.isub]
- [int::* _.imul]
- [int::/ _.idiv]
- [int::% _.irem]
- [int::and _.iand]
- [int::or _.ior]
- [int::xor _.ixor]
- [int::shl _.ishl]
- [int::shr _.ishr]
- [int::ushr _.iushr]
-
- [long::+ _.ladd]
- [long::- _.lsub]
- [long::* _.lmul]
- [long::/ _.ldiv]
- [long::% _.lrem]
- [long::and _.land]
- [long::or _.lor]
- [long::xor _.lxor]
- [long::shl _.lshl]
- [long::shr _.lshr]
- [long::ushr _.lushr]
-
- [float::+ _.fadd]
- [float::- _.fsub]
- [float::* _.fmul]
- [float::/ _.fdiv]
- [float::% _.frem]
-
- [double::+ _.dadd]
- [double::- _.dsub]
- [double::* _.dmul]
- [double::/ _.ddiv]
- [double::% _.drem]
- )
-
-(def: $Boolean (type.class box.boolean (list)))
-(def: falseG (_.getstatic ..$Boolean "FALSE" ..$Boolean))
-(def: trueG (_.getstatic ..$Boolean "TRUE" ..$Boolean))
-
-(template [<name> <op>]
- [(def: (<name> [xG yG])
- (Binary (Bytecode Any))
- (do _.monad
- [@then _.new-label
- @end _.new-label]
- ($_ _.compose
- xG
- yG
- (<op> @then)
- falseG
- (_.goto @end)
- (_.set-label @then)
- trueG
- (_.set-label @end))))]
-
- [int::= _.if-icmpeq]
- [int::< _.if-icmplt]
-
- [char::= _.if-icmpeq]
- [char::< _.if-icmplt]
- )
-
-(template [<name> <op> <reference>]
- [(def: (<name> [xG yG])
- (Binary (Bytecode Any))
- (do _.monad
- [@then _.new-label
- @end _.new-label]
- ($_ _.compose
- xG
- yG
- <op>
- (_.int (i32.i32 (.i64 <reference>)))
- (_.if-icmpeq @then)
- falseG
- (_.goto @end)
- (_.set-label @then)
- trueG
- (_.set-label @end))))]
-
- [long::= _.lcmp +0]
- [long::< _.lcmp -1]
-
- [float::= _.fcmpg +0]
- [float::< _.fcmpg -1]
-
- [double::= _.dcmpg +0]
- [double::< _.dcmpg -1]
- )
-
-(def: bundle::int
- Bundle
- (<| (/////bundle.prefix (reflection.reflection reflection.int))
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "+" (binary int::+))
- (/////bundle.install "-" (binary int::-))
- (/////bundle.install "*" (binary int::*))
- (/////bundle.install "/" (binary int::/))
- (/////bundle.install "%" (binary int::%))
- (/////bundle.install "=" (binary int::=))
- (/////bundle.install "<" (binary int::<))
- (/////bundle.install "and" (binary int::and))
- (/////bundle.install "or" (binary int::or))
- (/////bundle.install "xor" (binary int::xor))
- (/////bundle.install "shl" (binary int::shl))
- (/////bundle.install "shr" (binary int::shr))
- (/////bundle.install "ushr" (binary int::ushr))
- )))
-
-(def: bundle::long
- Bundle
- (<| (/////bundle.prefix (reflection.reflection reflection.long))
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "+" (binary long::+))
- (/////bundle.install "-" (binary long::-))
- (/////bundle.install "*" (binary long::*))
- (/////bundle.install "/" (binary long::/))
- (/////bundle.install "%" (binary long::%))
- (/////bundle.install "=" (binary long::=))
- (/////bundle.install "<" (binary long::<))
- (/////bundle.install "and" (binary long::and))
- (/////bundle.install "or" (binary long::or))
- (/////bundle.install "xor" (binary long::xor))
- (/////bundle.install "shl" (binary long::shl))
- (/////bundle.install "shr" (binary long::shr))
- (/////bundle.install "ushr" (binary long::ushr))
- )))
-
-(def: bundle::float
- Bundle
- (<| (/////bundle.prefix (reflection.reflection reflection.float))
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "+" (binary float::+))
- (/////bundle.install "-" (binary float::-))
- (/////bundle.install "*" (binary float::*))
- (/////bundle.install "/" (binary float::/))
- (/////bundle.install "%" (binary float::%))
- (/////bundle.install "=" (binary float::=))
- (/////bundle.install "<" (binary float::<))
- )))
-
-(def: bundle::double
- Bundle
- (<| (/////bundle.prefix (reflection.reflection reflection.double))
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "+" (binary double::+))
- (/////bundle.install "-" (binary double::-))
- (/////bundle.install "*" (binary double::*))
- (/////bundle.install "/" (binary double::/))
- (/////bundle.install "%" (binary double::%))
- (/////bundle.install "=" (binary double::=))
- (/////bundle.install "<" (binary double::<))
- )))
-
-(def: bundle::char
- Bundle
- (<| (/////bundle.prefix (reflection.reflection reflection.char))
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "=" (binary char::=))
- (/////bundle.install "<" (binary char::<))
- )))
-
-(template [<name> <category> <parser>]
- [(def: #export <name>
- (Parser (Type <category>))
- (<t>.embed <parser> <s>.text))]
-
- [var Var parser.var]
- [class category.Class parser.class]
- [object Object parser.object]
- [value Value parser.value]
- [return Return parser.return]
- )
-
-(exception: #export (not-an-object-array {arrayJT (Type Array)})
- (exception.report
- ["JVM Type" (|> arrayJT type.signature signature.signature)]))
-
-(def: #export object-array
- (Parser (Type Object))
- (do <>.monad
- [arrayJT (<t>.embed parser.array <s>.text)]
- (case (parser.array? arrayJT)
- (#.Some elementJT)
- (case (parser.object? elementJT)
- (#.Some elementJT)
- (wrap elementJT)
-
- #.None
- (<>.fail (exception.construct ..not-an-object-array arrayJT)))
-
- #.None
- (undefined))))
-
-(def: (primitive-array-length-handler jvm-primitive)
- (-> (Type Primitive) Handler)
- (..custom
- [<s>.any
- (function (_ extension-name generate archive arrayS)
- (do //////.monad
- [arrayG (generate archive arrayS)]
- (wrap ($_ _.compose
- arrayG
- (_.checkcast (type.array jvm-primitive))
- _.arraylength))))]))
-
-(def: array::length::object
- Handler
- (..custom
- [($_ <>.and ..object-array <s>.any)
- (function (_ extension-name generate archive [elementJT arrayS])
- (do //////.monad
- [arrayG (generate archive arrayS)]
- (wrap ($_ _.compose
- arrayG
- (_.checkcast (type.array elementJT))
- _.arraylength))))]))
-
-(def: (new-primitive-array-handler jvm-primitive)
- (-> Primitive-Array-Type Handler)
- (..custom
- [<s>.any
- (function (_ extension-name generate archive [lengthS])
- (do //////.monad
- [lengthG (generate archive lengthS)]
- (wrap ($_ _.compose
- lengthG
- (_.newarray jvm-primitive)))))]))
-
-(def: array::new::object
- Handler
- (..custom
- [($_ <>.and ..object <s>.any)
- (function (_ extension-name generate archive [objectJT lengthS])
- (do //////.monad
- [lengthG (generate archive lengthS)]
- (wrap ($_ _.compose
- lengthG
- (_.anewarray objectJT)))))]))
-
-(def: (read-primitive-array-handler jvm-primitive loadG)
- (-> (Type Primitive) (Bytecode Any) Handler)
- (..custom
- [($_ <>.and <s>.any <s>.any)
- (function (_ extension-name generate archive [idxS arrayS])
- (do //////.monad
- [arrayG (generate archive arrayS)
- idxG (generate archive idxS)]
- (wrap ($_ _.compose
- arrayG
- (_.checkcast (type.array jvm-primitive))
- idxG
- loadG))))]))
-
-(def: array::read::object
- Handler
- (..custom
- [($_ <>.and ..object-array <s>.any <s>.any)
- (function (_ extension-name generate archive [elementJT idxS arrayS])
- (do //////.monad
- [arrayG (generate archive arrayS)
- idxG (generate archive idxS)]
- (wrap ($_ _.compose
- arrayG
- (_.checkcast (type.array elementJT))
- idxG
- _.aaload))))]))
-
-(def: (write-primitive-array-handler jvm-primitive storeG)
- (-> (Type Primitive) (Bytecode Any) Handler)
- (..custom
- [($_ <>.and <s>.any <s>.any <s>.any)
- (function (_ extension-name generate archive [idxS valueS arrayS])
- (do //////.monad
- [arrayG (generate archive arrayS)
- idxG (generate archive idxS)
- valueG (generate archive valueS)]
- (wrap ($_ _.compose
- arrayG
- (_.checkcast (type.array jvm-primitive))
- _.dup
- idxG
- valueG
- storeG))))]))
-
-(def: array::write::object
- Handler
- (..custom
- [($_ <>.and ..object-array <s>.any <s>.any <s>.any)
- (function (_ extension-name generate archive [elementJT idxS valueS arrayS])
- (do //////.monad
- [arrayG (generate archive arrayS)
- idxG (generate archive idxS)
- valueG (generate archive valueS)]
- (wrap ($_ _.compose
- arrayG
- (_.checkcast (type.array elementJT))
- _.dup
- idxG
- valueG
- _.aastore))))]))
-
-(def: bundle::array
- Bundle
- (<| (/////bundle.prefix "array")
- (|> /////bundle.empty
- (dictionary.merge (<| (/////bundle.prefix "length")
- (|> /////bundle.empty
- (/////bundle.install (reflection.reflection reflection.boolean) (primitive-array-length-handler type.boolean))
- (/////bundle.install (reflection.reflection reflection.byte) (primitive-array-length-handler type.byte))
- (/////bundle.install (reflection.reflection reflection.short) (primitive-array-length-handler type.short))
- (/////bundle.install (reflection.reflection reflection.int) (primitive-array-length-handler type.int))
- (/////bundle.install (reflection.reflection reflection.long) (primitive-array-length-handler type.long))
- (/////bundle.install (reflection.reflection reflection.float) (primitive-array-length-handler type.float))
- (/////bundle.install (reflection.reflection reflection.double) (primitive-array-length-handler type.double))
- (/////bundle.install (reflection.reflection reflection.char) (primitive-array-length-handler type.char))
- (/////bundle.install "object" array::length::object))))
- (dictionary.merge (<| (/////bundle.prefix "new")
- (|> /////bundle.empty
- (/////bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler __.t-boolean))
- (/////bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler __.t-byte))
- (/////bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler __.t-short))
- (/////bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler __.t-int))
- (/////bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler __.t-long))
- (/////bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler __.t-float))
- (/////bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler __.t-double))
- (/////bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler __.t-char))
- (/////bundle.install "object" array::new::object))))
- (dictionary.merge (<| (/////bundle.prefix "read")
- (|> /////bundle.empty
- (/////bundle.install (reflection.reflection reflection.boolean) (read-primitive-array-handler type.boolean _.baload))
- (/////bundle.install (reflection.reflection reflection.byte) (read-primitive-array-handler type.byte _.baload))
- (/////bundle.install (reflection.reflection reflection.short) (read-primitive-array-handler type.short _.saload))
- (/////bundle.install (reflection.reflection reflection.int) (read-primitive-array-handler type.int _.iaload))
- (/////bundle.install (reflection.reflection reflection.long) (read-primitive-array-handler type.long _.laload))
- (/////bundle.install (reflection.reflection reflection.float) (read-primitive-array-handler type.float _.faload))
- (/////bundle.install (reflection.reflection reflection.double) (read-primitive-array-handler type.double _.daload))
- (/////bundle.install (reflection.reflection reflection.char) (read-primitive-array-handler type.char _.caload))
- (/////bundle.install "object" array::read::object))))
- (dictionary.merge (<| (/////bundle.prefix "write")
- (|> /////bundle.empty
- (/////bundle.install (reflection.reflection reflection.boolean) (write-primitive-array-handler type.boolean _.bastore))
- (/////bundle.install (reflection.reflection reflection.byte) (write-primitive-array-handler type.byte _.bastore))
- (/////bundle.install (reflection.reflection reflection.short) (write-primitive-array-handler type.short _.sastore))
- (/////bundle.install (reflection.reflection reflection.int) (write-primitive-array-handler type.int _.iastore))
- (/////bundle.install (reflection.reflection reflection.long) (write-primitive-array-handler type.long _.lastore))
- (/////bundle.install (reflection.reflection reflection.float) (write-primitive-array-handler type.float _.fastore))
- (/////bundle.install (reflection.reflection reflection.double) (write-primitive-array-handler type.double _.dastore))
- (/////bundle.install (reflection.reflection reflection.char) (write-primitive-array-handler type.char _.castore))
- (/////bundle.install "object" array::write::object))))
- )))
-
-(def: (object::null _)
- (Nullary (Bytecode Any))
- _.aconst-null)
-
-(def: (object::null? objectG)
- (Unary (Bytecode Any))
- (do _.monad
- [@then _.new-label
- @end _.new-label]
- ($_ _.compose
- objectG
- (_.ifnull @then)
- ..falseG
- (_.goto @end)
- (_.set-label @then)
- ..trueG
- (_.set-label @end))))
-
-(def: (object::synchronized [monitorG exprG])
- (Binary (Bytecode Any))
- ($_ _.compose
- monitorG
- _.dup
- _.monitorenter
- exprG
- _.swap
- _.monitorexit))
-
-(def: (object::throw exceptionG)
- (Unary (Bytecode Any))
- ($_ _.compose
- exceptionG
- _.athrow))
-
-(def: $Class (type.class "java.lang.Class" (list)))
-(def: $String (type.class "java.lang.String" (list)))
-
-(def: object::class
- Handler
- (..custom
- [<s>.text
- (function (_ extension-name generate archive [class])
- (do //////.monad
- []
- (wrap ($_ _.compose
- (_.string class)
- (_.invokestatic ..$Class "forName" (type.method [(list ..$String) ..$Class (list)]))))))]))
-
-(def: object::instance?
- Handler
- (..custom
- [($_ <>.and <s>.text <s>.any)
- (function (_ extension-name generate archive [class objectS])
- (do //////.monad
- [objectG (generate archive objectS)]
- (wrap ($_ _.compose
- objectG
- (_.instanceof (type.class class (list)))
- (_.invokestatic ..$Boolean "valueOf" (type.method [(list type.boolean) ..$Boolean (list)]))))))]))
-
-(def: reflection
- (All [category]
- (-> (Type (<| Return' Value' category)) Text))
- (|>> type.reflection reflection.reflection))
-
-(def: object::cast
- Handler
- (..custom
- [($_ <>.and <s>.text <s>.text <s>.any)
- (function (_ extension-name generate archive [from to valueS])
- (do //////.monad
- [valueG (generate archive valueS)]
- (wrap (`` (cond (~~ (template [<object> <type> <unwrap>]
- [(and (text\= (..reflection <type>)
- from)
- (text\= <object>
- to))
- (let [$<object> (type.class <object> (list))]
- ($_ _.compose
- valueG
- (_.invokestatic $<object> "valueOf" (type.method [(list <type>) $<object> (list)]))))
-
- (and (text\= <object>
- from)
- (text\= (..reflection <type>)
- to))
- (let [$<object> (type.class <object> (list))]
- ($_ _.compose
- valueG
- (_.checkcast $<object>)
- (_.invokevirtual $<object> <unwrap> (type.method [(list) <type> (list)]))))]
-
- [box.boolean type.boolean "booleanValue"]
- [box.byte type.byte "byteValue"]
- [box.short type.short "shortValue"]
- [box.int type.int "intValue"]
- [box.long type.long "longValue"]
- [box.float type.float "floatValue"]
- [box.double type.double "doubleValue"]
- [box.char type.char "charValue"]))
- ## else
- valueG)))))]))
-
-(def: bundle::object
- Bundle
- (<| (/////bundle.prefix "object")
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "null" (nullary object::null))
- (/////bundle.install "null?" (unary object::null?))
- (/////bundle.install "synchronized" (binary object::synchronized))
- (/////bundle.install "throw" (unary object::throw))
- (/////bundle.install "class" object::class)
- (/////bundle.install "instance?" object::instance?)
- (/////bundle.install "cast" object::cast)
- )))
-
-(def: primitives
- (Dictionary Text (Type Primitive))
- (|> (list [(reflection.reflection reflection.boolean) type.boolean]
- [(reflection.reflection reflection.byte) type.byte]
- [(reflection.reflection reflection.short) type.short]
- [(reflection.reflection reflection.int) type.int]
- [(reflection.reflection reflection.long) type.long]
- [(reflection.reflection reflection.float) type.float]
- [(reflection.reflection reflection.double) type.double]
- [(reflection.reflection reflection.char) type.char])
- (dictionary.from-list text.hash)))
-
-(def: get::static
- Handler
- (..custom
- [($_ <>.and <s>.text <s>.text <s>.text)
- (function (_ extension-name generate archive [class field unboxed])
- (do //////.monad
- [#let [$class (type.class class (list))]]
- (case (dictionary.get unboxed ..primitives)
- (#.Some primitive)
- (wrap (_.getstatic $class field primitive))
-
- #.None
- (wrap (_.getstatic $class field (type.class unboxed (list)))))))]))
-
-(def: unitG (_.string //////synthesis.unit))
-
-(def: put::static
- Handler
- (..custom
- [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
- (function (_ extension-name generate archive [class field unboxed valueS])
- (do //////.monad
- [valueG (generate archive valueS)
- #let [$class (type.class class (list))]]
- (case (dictionary.get unboxed ..primitives)
- (#.Some primitive)
- (wrap ($_ _.compose
- valueG
- (_.putstatic $class field primitive)
- ..unitG))
-
- #.None
- (wrap ($_ _.compose
- valueG
- (_.checkcast $class)
- (_.putstatic $class field $class)
- ..unitG)))))]))
-
-(def: get::virtual
- Handler
- (..custom
- [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
- (function (_ extension-name generate archive [class field unboxed objectS])
- (do //////.monad
- [objectG (generate archive objectS)
- #let [$class (type.class class (list))
- getG (case (dictionary.get unboxed ..primitives)
- (#.Some primitive)
- (_.getfield $class field primitive)
-
- #.None
- (_.getfield $class field (type.class unboxed (list))))]]
- (wrap ($_ _.compose
- objectG
- (_.checkcast $class)
- getG))))]))
-
-(def: put::virtual
- Handler
- (..custom
- [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any)
- (function (_ extension-name generate archive [class field unboxed valueS objectS])
- (do //////.monad
- [valueG (generate archive valueS)
- objectG (generate archive objectS)
- #let [$class (type.class class (list))
- putG (case (dictionary.get unboxed ..primitives)
- (#.Some primitive)
- (_.putfield $class field primitive)
-
- #.None
- (let [$unboxed (type.class unboxed (list))]
- ($_ _.compose
- (_.checkcast $unboxed)
- (_.putfield $class field $unboxed))))]]
- (wrap ($_ _.compose
- objectG
- (_.checkcast $class)
- _.dup
- valueG
- putG))))]))
-
-(type: Input (Typed Synthesis))
-
-(def: input
- (Parser Input)
- (<s>.tuple (<>.and ..value <s>.any)))
-
-(def: (generate-input generate archive [valueT valueS])
- (-> Phase Archive Input (Operation (Typed (Bytecode Any))))
- (do //////.monad
- [valueG (generate archive valueS)]
- (case (type.primitive? valueT)
- (#.Right valueT)
- (wrap [valueT valueG])
-
- (#.Left valueT)
- (wrap [valueT ($_ _.compose
- valueG
- (_.checkcast valueT))]))))
-
-(def: (prepare-output outputT)
- (-> (Type Return) (Bytecode Any))
- (case (type.void? outputT)
- (#.Right outputT)
- ..unitG
-
- (#.Left outputT)
- (\ _.monad wrap [])))
-
-(def: invoke::static
- Handler
- (..custom
- [($_ <>.and ..class <s>.text ..return (<>.some ..input))
- (function (_ extension-name generate archive [class method outputT inputsTS])
- (do {! //////.monad}
- [inputsTG (monad.map ! (generate-input generate archive) inputsTS)]
- (wrap ($_ _.compose
- (monad.map _.monad product.right inputsTG)
- (_.invokestatic class method (type.method [(list\map product.left inputsTG) outputT (list)]))
- (prepare-output outputT)))))]))
-
-(template [<name> <invoke>]
- [(def: <name>
- Handler
- (..custom
- [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input))
- (function (_ extension-name generate archive [class method outputT objectS inputsTS])
- (do {! //////.monad}
- [objectG (generate archive objectS)
- inputsTG (monad.map ! (generate-input generate archive) inputsTS)]
- (wrap ($_ _.compose
- objectG
- (_.checkcast class)
- (monad.map _.monad product.right inputsTG)
- (<invoke> class method (type.method [(list\map product.left inputsTG) outputT (list)]))
- (prepare-output outputT)))))]))]
-
- [invoke::virtual _.invokevirtual]
- [invoke::special _.invokespecial]
- [invoke::interface _.invokeinterface]
- )
-
-(def: invoke::constructor
- Handler
- (..custom
- [($_ <>.and ..class (<>.some ..input))
- (function (_ extension-name generate archive [class inputsTS])
- (do {! //////.monad}
- [inputsTG (monad.map ! (generate-input generate archive) inputsTS)]
- (wrap ($_ _.compose
- (_.new class)
- _.dup
- (monad.map _.monad product.right inputsTG)
- (_.invokespecial class "<init>" (type.method [(list\map product.left inputsTG) type.void (list)]))))))]))
-
-(def: bundle::member
- Bundle
- (<| (/////bundle.prefix "member")
- (|> (: Bundle /////bundle.empty)
- (dictionary.merge (<| (/////bundle.prefix "get")
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "static" get::static)
- (/////bundle.install "virtual" get::virtual))))
- (dictionary.merge (<| (/////bundle.prefix "put")
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "static" put::static)
- (/////bundle.install "virtual" put::virtual))))
- (dictionary.merge (<| (/////bundle.prefix "invoke")
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "static" invoke::static)
- (/////bundle.install "virtual" invoke::virtual)
- (/////bundle.install "special" invoke::special)
- (/////bundle.install "interface" invoke::interface)
- (/////bundle.install "constructor" invoke::constructor))))
- )))
-
-(def: annotation-parameter
- (Parser (/.Annotation-Parameter Synthesis))
- (<s>.tuple (<>.and <s>.text <s>.any)))
-
-(def: annotation
- (Parser (/.Annotation Synthesis))
- (<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter))))
-
-(def: argument
- (Parser Argument)
- (<s>.tuple (<>.and <s>.text ..value)))
-
-(def: overriden-method-definition
- (Parser [(Environment Synthesis) (/.Overriden-Method Synthesis)])
- (<s>.tuple (do <>.monad
- [_ (<s>.text! /.overriden-tag)
- ownerT ..class
- name <s>.text
- strict-fp? <s>.bit
- annotations (<s>.tuple (<>.some ..annotation))
- vars (<s>.tuple (<>.some ..var))
- self-name <s>.text
- arguments (<s>.tuple (<>.some ..argument))
- returnT ..return
- exceptionsT (<s>.tuple (<>.some ..class))
- [environment body] (<s>.function 1
- (<s>.tuple <s>.any))]
- (wrap [environment
- [ownerT name
- strict-fp? annotations vars
- self-name arguments returnT exceptionsT
- body]]))))
-
-(def: (normalize-path normalize)
- (-> (-> Synthesis Synthesis)
- (-> Path Path))
- (function (recur path)
- (case path
- (^ (//////synthesis.path/then bodyS))
- (//////synthesis.path/then (normalize bodyS))
-
- (^template [<tag>]
- [(^ (<tag> leftP rightP))
- (<tag> (recur leftP) (recur rightP))])
- ([#//////synthesis.Alt]
- [#//////synthesis.Seq])
-
- (^template [<tag>]
- [(^ (<tag> value))
- path])
- ([#//////synthesis.Pop]
- [#//////synthesis.Bind]
- [#//////synthesis.Access])
-
- _
- (undefined))))
-
-(def: (normalize-method-body mapping)
- (-> (Dictionary Variable Variable) Synthesis Synthesis)
- (function (recur body)
- (case body
- (^template [<tag>]
- [(^ (<tag> value))
- body])
- ([#//////synthesis.Primitive]
- [//////synthesis.constant])
-
- (^ (//////synthesis.variant [lefts right? sub]))
- (//////synthesis.variant [lefts right? (recur sub)])
-
- (^ (//////synthesis.tuple members))
- (//////synthesis.tuple (list\map recur members))
-
- (^ (//////synthesis.variable var))
- (|> mapping
- (dictionary.get var)
- (maybe.default var)
- //////synthesis.variable)
-
- (^ (//////synthesis.branch/case [inputS pathS]))
- (//////synthesis.branch/case [(recur inputS) (normalize-path recur pathS)])
-
- (^ (//////synthesis.branch/let [inputS register outputS]))
- (//////synthesis.branch/let [(recur inputS) register (recur outputS)])
-
- (^ (//////synthesis.branch/if [testS thenS elseS]))
- (//////synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)])
-
- (^ (//////synthesis.branch/get [path recordS]))
- (//////synthesis.branch/get [path (recur recordS)])
-
- (^ (//////synthesis.loop/scope [offset initsS+ bodyS]))
- (//////synthesis.loop/scope [offset (list\map recur initsS+) (recur bodyS)])
-
- (^ (//////synthesis.loop/recur updatesS+))
- (//////synthesis.loop/recur (list\map recur updatesS+))
-
- (^ (//////synthesis.function/abstraction [environment arity bodyS]))
- (//////synthesis.function/abstraction [(list\map (function (_ local)
- (case local
- (^ (//////synthesis.variable local))
- (|> mapping
- (dictionary.get local)
- (maybe.default local)
- //////synthesis.variable)
-
- _
- local))
- environment)
- arity
- bodyS])
-
- (^ (//////synthesis.function/apply [functionS inputsS+]))
- (//////synthesis.function/apply [(recur functionS) (list\map recur inputsS+)])
-
- (#//////synthesis.Extension [name inputsS+])
- (#//////synthesis.Extension [name (list\map recur inputsS+)]))))
-
-(def: $Object (type.class "java.lang.Object" (list)))
-
-(def: (anonymous-init-method env)
- (-> (Environment Synthesis) (Type category.Method))
- (type.method [(list.repeat (list.size env) ..$Object)
- type.void
- (list)]))
-
-(def: (with-anonymous-init class env super-class inputsTG)
- (-> (Type category.Class) (Environment Synthesis) (Type category.Class) (List (Typed (Bytecode Any))) (Resource Method))
- (let [store-capturedG (|> env
- list.size
- list.indices
- (monad.map _.monad (.function (_ register)
- ($_ _.compose
- (_.aload 0)
- (_.aload (inc register))
- (_.putfield class (///reference.foreign-name register) $Object)))))]
- (method.method method.public "<init>" (anonymous-init-method env)
- (list)
- (#.Some ($_ _.compose
- (_.aload 0)
- (monad.map _.monad product.right inputsTG)
- (_.invokespecial super-class "<init>" (type.method [(list\map product.left inputsTG) type.void (list)]))
- store-capturedG
- _.return)))))
-
-(def: (anonymous-instance generate archive class env)
- (-> Phase Archive (Type category.Class) (Environment Synthesis) (Operation (Bytecode Any)))
- (do {! //////.monad}
- [captureG+ (monad.map ! (generate archive) env)]
- (wrap ($_ _.compose
- (_.new class)
- _.dup
- (monad.seq _.monad captureG+)
- (_.invokespecial class "<init>" (anonymous-init-method env))))))
-
-(def: (returnG returnT)
- (-> (Type Return) (Bytecode Any))
- (case (type.void? returnT)
- (#.Right returnT)
- _.return
-
- (#.Left returnT)
- (case (type.primitive? returnT)
- (#.Left returnT)
- ($_ _.compose
- (_.checkcast returnT)
- _.areturn)
-
- (#.Right returnT)
- (cond (or (\ type.equivalence = type.boolean returnT)
- (\ type.equivalence = type.byte returnT)
- (\ type.equivalence = type.short returnT)
- (\ type.equivalence = type.int returnT)
- (\ type.equivalence = type.char returnT))
- _.ireturn
-
- (\ type.equivalence = type.long returnT)
- _.lreturn
-
- (\ type.equivalence = type.float returnT)
- _.freturn
-
- ## (\ type.equivalence = type.double returnT)
- _.dreturn))))
-
-(def: class::anonymous
- Handler
- (..custom
- [($_ <>.and
- ..class
- (<s>.tuple (<>.some ..class))
- (<s>.tuple (<>.some ..input))
- (<s>.tuple (<>.some ..overriden-method-definition)))
- (function (_ extension-name generate archive [super-class super-interfaces
- inputsTS
- overriden-methods])
- (do {! //////.monad}
- [[context _] (//////generation.with-new-context archive (wrap []))
- #let [[module-id artifact-id] context
- anonymous-class-name (///runtime.class-name context)
- class (type.class anonymous-class-name (list))
- total-environment (|> overriden-methods
- ## Get all the environments.
- (list\map product.left)
- ## Combine them.
- list\join
- ## Remove duplicates.
- (set.from-list //////synthesis.hash)
- set.to-list)
- global-mapping (|> total-environment
- ## Give them names as "foreign" variables.
- list.enumeration
- (list\map (function (_ [id capture])
- [capture (#//////variable.Foreign id)]))
- (dictionary.from-list //////variable.hash))
- normalized-methods (list\map (function (_ [environment
- [ownerT name
- strict-fp? annotations vars
- self-name arguments returnT exceptionsT
- body]])
- (let [local-mapping (|> environment
- list.enumeration
- (list\map (function (_ [foreign-id capture])
- [(#//////variable.Foreign foreign-id)
- (|> global-mapping
- (dictionary.get capture)
- maybe.assume)]))
- (dictionary.from-list //////variable.hash))]
- [ownerT name
- strict-fp? annotations vars
- self-name arguments returnT exceptionsT
- (normalize-method-body local-mapping body)]))
- overriden-methods)]
- inputsTI (monad.map ! (generate-input generate archive) inputsTS)
- method-definitions (monad.map ! (function (_ [ownerT name
- strict-fp? annotations vars
- self-name arguments returnT exceptionsT
- bodyS])
- (do !
- [bodyG (//////generation.with-context artifact-id
- (generate archive bodyS))]
- (wrap (method.method ($_ modifier\compose
- method.public
- method.final
- (if strict-fp?
- method.strict
- modifier\identity))
- name
- (type.method [(list\map product.right arguments)
- returnT
- exceptionsT])
- (list)
- (#.Some ($_ _.compose
- bodyG
- (returnG returnT)))))))
- normalized-methods)
- bytecode (<| (\ ! map (format.run class.writer))
- //////.lift
- (class.class version.v6_0 ($_ modifier\compose class.public class.final)
- (name.internal anonymous-class-name)
- (name.internal (..reflection super-class))
- (list\map (|>> ..reflection name.internal) super-interfaces)
- (foreign.variables total-environment)
- (list& (..with-anonymous-init class total-environment super-class inputsTI)
- method-definitions)
- (row.row)))
- _ (//////generation.execute! [anonymous-class-name bytecode])
- _ (//////generation.save! (%.nat artifact-id) [anonymous-class-name bytecode])]
- (anonymous-instance generate archive class total-environment)))]))
-
-(def: bundle::class
- Bundle
- (<| (/////bundle.prefix "class")
- (|> (: Bundle /////bundle.empty)
- (/////bundle.install "anonymous" class::anonymous)
- )))
-
-(def: #export bundle
- Bundle
- (<| (/////bundle.prefix "jvm")
- (|> ..bundle::conversion
- (dictionary.merge ..bundle::int)
- (dictionary.merge ..bundle::long)
- (dictionary.merge ..bundle::float)
- (dictionary.merge ..bundle::double)
- (dictionary.merge ..bundle::char)
- (dictionary.merge ..bundle::array)
- (dictionary.merge ..bundle::object)
- (dictionary.merge ..bundle::member)
- (dictionary.merge ..bundle::class)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux
deleted file mode 100644
index ab0d0d555..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux
+++ /dev/null
@@ -1,17 +0,0 @@
-(.module:
- [lux #*
- [data
- [collection
- ["." dictionary]]]]
- ["." / #_
- ["#." common]
- ["#." host]
- [////
- [generation
- [lua
- [runtime (#+ Bundle)]]]]])
-
-(def: #export bundle
- Bundle
- (dictionary.merge /common.bundle
- /host.bundle))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux
deleted file mode 100644
index b22dd6d53..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux
+++ /dev/null
@@ -1,180 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["." try]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary]
- ["." list ("#\." functor fold)]]]
- [math
- [number
- ["f" frac]]]
- ["@" target
- ["_" lua (#+ Expression)]]]
- ["." //// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["//" lua #_
- ["#." runtime (#+ Operation Phase Handler Bundle Generator)]]]
- [//
- [synthesis (#+ %synthesis)]
- ["." generation]
- [///
- ["#" phase]]]]])
-
-(def: #export (custom [parser handler])
- (All [s]
- (-> [(Parser s)
- (-> Text (Generator s))]
- Handler))
- (function (_ extension_name phase archive input)
- (case (<s>.run parser input)
- (#try.Success input')
- (handler extension_name phase archive input')
-
- (#try.Failure error)
- (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
-
-(template: (!unary function)
- (|>> list _.apply/* (|> (_.var function))))
-
-## TODO: Get rid of this ASAP
-(def: lux::syntax_char_case!
- (..custom [($_ <>.and
- <s>.any
- <s>.any
- (<>.some (<s>.tuple ($_ <>.and
- (<s>.tuple (<>.many <s>.i64))
- <s>.any))))
- (function (_ extension_name phase archive [input else conditionals])
- (do {! /////.monad}
- [inputG (phase archive input)
- elseG (phase archive else)
- @input (\ ! map _.var (generation.gensym "input"))
- conditionalsG (: (Operation (List [Expression Expression]))
- (monad.map ! (function (_ [chars branch])
- (do !
- [branchG (phase archive branch)]
- (wrap [(|> chars
- (list\map (|>> .int _.int (_.= @input)))
- (list\fold (function (_ clause total)
- (if (is? _.nil total)
- clause
- (_.or clause total)))
- _.nil))
- branchG])))
- conditionals))
- #let [closure (_.closure (list @input)
- (list\fold (function (_ [test then] else)
- (_.if test (_.return then) else))
- (_.return elseG)
- conditionalsG))]]
- (wrap (_.apply/1 closure inputG))))]))
-
-(def: lux_procs
- Bundle
- (|> /.empty
- (/.install "syntax char case!" lux::syntax_char_case!)
- (/.install "is" (binary (product.uncurry _.=)))
- (/.install "try" (unary //runtime.lux//try))))
-
-(def: i64_procs
- Bundle
- (<| (/.prefix "i64")
- (|> /.empty
- (/.install "and" (binary (product.uncurry _.bit_and)))
- (/.install "or" (binary (product.uncurry _.bit_or)))
- (/.install "xor" (binary (product.uncurry _.bit_xor)))
- (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift)))
- (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift)))
- (/.install "=" (binary (product.uncurry _.=)))
- (/.install "+" (binary (product.uncurry _.+)))
- (/.install "-" (binary (product.uncurry _.-)))
- (/.install "<" (binary (product.uncurry _.<)))
- (/.install "*" (binary (product.uncurry _.*)))
- (/.install "/" (binary (product.uncurry //runtime.i64//division)))
- (/.install "%" (binary (product.uncurry //runtime.i64//remainder)))
- (/.install "f64" (unary (_./ (_.float +1.0))))
- (/.install "char" (unary (_.apply/1 (_.var "utf8.char"))))
- )))
-
-(def: f64//decode
- (Unary Expression)
- (|>> list _.apply/* (|> (_.var "tonumber")) _.return (_.closure (list)) //runtime.lux//try))
-
-(def: f64_procs
- Bundle
- (<| (/.prefix "f64")
- (|> /.empty
- (/.install "+" (binary (product.uncurry _.+)))
- (/.install "-" (binary (product.uncurry _.-)))
- (/.install "*" (binary (product.uncurry _.*)))
- (/.install "/" (binary (product.uncurry _./)))
- (/.install "%" (binary (product.uncurry (function.flip (_.apply/2 (_.var "math.fmod"))))))
- (/.install "=" (binary (product.uncurry _.=)))
- (/.install "<" (binary (product.uncurry _.<)))
- (/.install "i64" (unary (!unary "math.floor")))
- (/.install "encode" (unary (_.apply/2 (_.var "string.format") (_.string "%.17g"))))
- (/.install "decode" (unary ..f64//decode)))))
-
-(def: (text//char [paramO subjectO])
- (Binary Expression)
- (//runtime.text//char (_.+ (_.int +1) paramO) subjectO))
-
-(def: (text//clip [paramO extraO subjectO])
- (Trinary Expression)
- (//runtime.text//clip subjectO paramO extraO))
-
-(def: (text//index [startO partO textO])
- (Trinary Expression)
- (//runtime.text//index textO partO startO))
-
-(def: text_procs
- Bundle
- (<| (/.prefix "text")
- (|> /.empty
- (/.install "=" (binary (product.uncurry _.=)))
- (/.install "<" (binary (product.uncurry _.<)))
- (/.install "concat" (binary (product.uncurry (function.flip _.concat))))
- (/.install "index" (trinary ..text//index))
- (/.install "size" (unary //runtime.text//size))
- ## TODO: Use version below once the Lua compiler becomes self-hosted.
- ## (/.install "size" (unary (for {@.lua (!unary "utf8.len")}
- ## (!unary "string.len"))))
- (/.install "char" (binary ..text//char))
- (/.install "clip" (trinary ..text//clip))
- )))
-
-(def: (io//log! messageO)
- (Unary Expression)
- (|> (_.apply/* (list messageO) (_.var "print"))
- (_.or //runtime.unit)))
-
-(def: io_procs
- Bundle
- (<| (/.prefix "io")
- (|> /.empty
- (/.install "log" (unary ..io//log!))
- (/.install "error" (unary (!unary "error"))))))
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "lux")
- (|> lux_procs
- (dictionary.merge i64_procs)
- (dictionary.merge f64_procs)
- (dictionary.merge text_procs)
- (dictionary.merge io_procs)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux
deleted file mode 100644
index c9c5acec8..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux
+++ /dev/null
@@ -1,199 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- [collection
- ["." dictionary]
- ["." list]]
- [text
- ["%" format (#+ format)]]]
- [target
- ["_" lua (#+ Var Expression)]]]
- ["." // #_
- ["#." common (#+ custom)]
- ["//#" /// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["." reference]
- ["//" lua #_
- ["#." runtime (#+ Operation Phase Handler Bundle
- with_vars)]]]
- ["/#" // #_
- ["." generation]
- ["//#" /// #_
- ["#." phase]]]]]])
-
-(def: array::new
- (Unary Expression)
- (|>> ["n"] list _.table))
-
-(def: array::length
- (Unary Expression)
- (_.the "n"))
-
-(def: (array::read [indexG arrayG])
- (Binary Expression)
- (_.nth (_.+ (_.int +1) indexG) arrayG))
-
-(def: (array::write [indexG valueG arrayG])
- (Trinary Expression)
- (//runtime.array//write indexG valueG arrayG))
-
-(def: (array::delete [indexG arrayG])
- (Binary Expression)
- (//runtime.array//write indexG _.nil arrayG))
-
-(def: array
- Bundle
- (<| (/.prefix "array")
- (|> /.empty
- (/.install "new" (unary array::new))
- (/.install "length" (unary array::length))
- (/.install "read" (binary array::read))
- (/.install "write" (trinary array::write))
- (/.install "delete" (binary array::delete))
- )))
-
-(def: object::get
- Handler
- (custom
- [($_ <>.and <s>.text <s>.any)
- (function (_ extension phase archive [fieldS objectS])
- (do ////////phase.monad
- [objectG (phase archive objectS)]
- (wrap (_.the fieldS objectG))))]))
-
-(def: object::do
- Handler
- (custom
- [($_ <>.and <s>.text <s>.any (<>.some <s>.any))
- (function (_ extension phase archive [methodS objectS inputsS])
- (do {! ////////phase.monad}
- [objectG (phase archive objectS)
- inputsG (monad.map ! (phase archive) inputsS)]
- (wrap (_.do methodS inputsG objectG))))]))
-
-(template [<!> <?> <unit>]
- [(def: <!> (Nullary Expression) (function.constant <unit>))
- (def: <?> (Unary Expression) (_.= <unit>))]
-
- [object::nil object::nil? _.nil]
- )
-
-(def: object
- Bundle
- (<| (/.prefix "object")
- (|> /.empty
- (/.install "get" object::get)
- (/.install "do" object::do)
- (/.install "nil" (nullary object::nil))
- (/.install "nil?" (unary object::nil?))
- )))
-
-(def: $input
- (_.var "input"))
-
-(def: utf8::encode
- (custom
- [<s>.any
- (function (_ extension phase archive inputS)
- (do {! ////////phase.monad}
- [inputG (phase archive inputS)]
- (wrap (_.apply/1 (<| (_.closure (list $input))
- (_.return (|> (_.var "string.byte")
- (_.apply/* (list $input (_.int +1) (_.length $input)))
- (_.apply/1 (_.var "table.pack")))))
- inputG))))]))
-
-(def: utf8::decode
- (custom
- [<s>.any
- (function (_ extension phase archive inputS)
- (do {! ////////phase.monad}
- [inputG (phase archive inputS)]
- (wrap (|> inputG
- (_.apply/1 (_.var "table.unpack"))
- (_.apply/1 (_.var "string.char"))))))]))
-
-(def: utf8
- Bundle
- (<| (/.prefix "utf8")
- (|> /.empty
- (/.install "encode" utf8::encode)
- (/.install "decode" utf8::decode)
- )))
-
-(def: lua::constant
- (custom
- [<s>.text
- (function (_ extension phase archive name)
- (\ ////////phase.monad wrap (_.var name)))]))
-
-(def: lua::apply
- (custom
- [($_ <>.and <s>.any (<>.some <s>.any))
- (function (_ extension phase archive [abstractionS inputsS])
- (do {! ////////phase.monad}
- [abstractionG (phase archive abstractionS)
- inputsG (monad.map ! (phase archive) inputsS)]
- (wrap (_.apply/* inputsG abstractionG))))]))
-
-(def: lua::power
- (custom
- [($_ <>.and <s>.any <s>.any)
- (function (_ extension phase archive [powerS baseS])
- (do {! ////////phase.monad}
- [powerG (phase archive powerS)
- baseG (phase archive baseS)]
- (wrap (_.^ powerG baseG))))]))
-
-(def: lua::import
- (custom
- [<s>.text
- (function (_ extension phase archive module)
- (\ ////////phase.monad wrap
- (_.require/1 (_.string module))))]))
-
-(def: lua::function
- (custom
- [($_ <>.and <s>.i64 <s>.any)
- (function (_ extension phase archive [arity abstractionS])
- (do {! ////////phase.monad}
- [abstractionG (phase archive abstractionS)
- #let [variable (: (-> Text (Operation Var))
- (|>> generation.gensym
- (\ ! map _.var)))]
- g!inputs (monad.map ! (function (_ _)
- (variable "input"))
- (list.repeat (.nat arity) []))]
- (wrap (<| (_.closure g!inputs)
- _.statement
- (case (.nat arity)
- 0 (_.apply/1 abstractionG //runtime.unit)
- 1 (_.apply/* g!inputs abstractionG)
- _ (_.apply/1 abstractionG (_.array g!inputs)))))))]))
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "lua")
- (|> /.empty
- (dictionary.merge ..array)
- (dictionary.merge ..object)
- (dictionary.merge ..utf8)
-
- (/.install "constant" lua::constant)
- (/.install "apply" lua::apply)
- (/.install "power" lua::power)
- (/.install "import" lua::import)
- (/.install "function" lua::function)
- (/.install "script universe" (nullary (function.constant (_.bool reference.universe))))
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php.lux
deleted file mode 100644
index 2f2d75c31..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php.lux
+++ /dev/null
@@ -1,17 +0,0 @@
-(.module:
- [lux #*
- [data
- [collection
- ["." dictionary]]]]
- ["." / #_
- ["#." common]
- ["#." host]
- [////
- [generation
- [php
- [runtime (#+ Bundle)]]]]])
-
-(def: #export bundle
- Bundle
- (dictionary.merge /common.bundle
- /host.bundle))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux
deleted file mode 100644
index ce4ab223c..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux
+++ /dev/null
@@ -1,191 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["." try]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary]
- ["." set]
- ["." list ("#\." functor fold)]]]
- [math
- [number
- ["f" frac]]]
- ["@" target
- ["_" php (#+ Expression)]]]
- ["." //// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["." reference]
- ["//" php #_
- ["#." runtime (#+ Operation Phase Handler Bundle Generator)]
- ["#." case]]]
- [//
- ["." synthesis (#+ %synthesis)]
- ["." generation]
- [///
- ["#" phase]]]]])
-
-(def: #export (custom [parser handler])
- (All [s]
- (-> [(Parser s)
- (-> Text (Generator s))]
- Handler))
- (function (_ extension_name phase archive input)
- (case (<s>.run parser input)
- (#try.Success input')
- (handler extension_name phase archive input')
-
- (#try.Failure error)
- (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
-
-(template: (!unary function)
- (|>> list _.apply/* (|> (_.constant function))))
-
-## TODO: Get rid of this ASAP
-(def: lux::syntax_char_case!
- (..custom [($_ <>.and
- <s>.any
- <s>.any
- (<>.some (<s>.tuple ($_ <>.and
- (<s>.tuple (<>.many <s>.i64))
- <s>.any))))
- (function (_ extension_name phase archive [input else conditionals])
- (do {! /////.monad}
- [inputG (phase archive input)
- [[context_module context_artifact] elseG] (generation.with_new_context archive
- (phase archive else))
- @input (\ ! map _.var (generation.gensym "input"))
- conditionalsG (: (Operation (List [Expression Expression]))
- (monad.map ! (function (_ [chars branch])
- (do !
- [branchG (phase archive branch)]
- (wrap [(|> chars
- (list\map (|>> .int _.int (_.=== @input)))
- (list\fold (function (_ clause total)
- (if (is? _.null total)
- clause
- (_.or clause total)))
- _.null))
- branchG])))
- conditionals))
- #let [foreigns (|> conditionals
- (list\map (|>> product.right synthesis.path/then //case.dependencies))
- (list& (//case.dependencies (synthesis.path/then else)))
- list.concat
- (set.from_list _.hash)
- set.to_list)
- @expression (_.constant (reference.artifact [context_module context_artifact]))
- directive (_.define_function @expression (list& (_.parameter @input) (list\map _.reference foreigns))
- (list\fold (function (_ [test then] else)
- (_.if test (_.return then) else))
- (_.return elseG)
- conditionalsG))]
- _ (generation.execute! directive)
- _ (generation.save! context_artifact directive)]
- (wrap (_.apply/* (list& inputG foreigns) @expression))))]))
-
-(def: lux_procs
- Bundle
- (|> /.empty
- (/.install "syntax char case!" lux::syntax_char_case!)
- (/.install "is" (binary (product.uncurry _.===)))
- (/.install "try" (unary //runtime.lux//try))
- ))
-
-(def: (left_shift [parameter subject])
- (Binary Expression)
- (_.bit_shl (_.% (_.int +64) parameter) subject))
-
-(def: i64_procs
- Bundle
- (<| (/.prefix "i64")
- (|> /.empty
- (/.install "and" (binary (product.uncurry _.bit_and)))
- (/.install "or" (binary (product.uncurry _.bit_or)))
- (/.install "xor" (binary (product.uncurry _.bit_xor)))
- (/.install "left-shift" (binary ..left_shift))
- (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift)))
- (/.install "=" (binary (product.uncurry _.==)))
- (/.install "<" (binary (product.uncurry _.<)))
- (/.install "+" (binary (product.uncurry //runtime.i64//+)))
- (/.install "-" (binary (product.uncurry //runtime.i64//-)))
- (/.install "*" (binary (product.uncurry //runtime.i64//*)))
- (/.install "/" (binary (function (_ [parameter subject])
- (_.intdiv/2 [subject parameter]))))
- (/.install "%" (binary (product.uncurry _.%)))
- (/.install "f64" (unary (_./ (_.float +1.0))))
- (/.install "char" (unary //runtime.i64//char))
- )))
-
-(def: (f64//% [parameter subject])
- (Binary Expression)
- (_.fmod/2 [subject parameter]))
-
-(def: (f64//encode subject)
- (Unary Expression)
- (_.number_format/2 [subject (_.int +17)]))
-
-(def: f64_procs
- Bundle
- (<| (/.prefix "f64")
- (|> /.empty
- (/.install "=" (binary (product.uncurry _.==)))
- (/.install "<" (binary (product.uncurry _.<)))
- (/.install "+" (binary (product.uncurry _.+)))
- (/.install "-" (binary (product.uncurry _.-)))
- (/.install "*" (binary (product.uncurry _.*)))
- (/.install "/" (binary (product.uncurry _./)))
- (/.install "%" (binary ..f64//%))
- (/.install "i64" (unary _.intval/1))
- (/.install "encode" (unary ..f64//encode))
- (/.install "decode" (unary //runtime.f64//decode)))))
-
-(def: (text//clip [paramO extraO subjectO])
- (Trinary Expression)
- (//runtime.text//clip paramO extraO subjectO))
-
-(def: (text//index [startO partO textO])
- (Trinary Expression)
- (//runtime.text//index textO partO startO))
-
-(def: text_procs
- Bundle
- (<| (/.prefix "text")
- (|> /.empty
- (/.install "=" (binary (product.uncurry _.==)))
- (/.install "<" (binary (product.uncurry _.<)))
- (/.install "concat" (binary (product.uncurry (function.flip _.concat))))
- (/.install "index" (trinary ..text//index))
- (/.install "size" (unary //runtime.text//size))
- (/.install "char" (binary (product.uncurry //runtime.text//char)))
- (/.install "clip" (trinary ..text//clip))
- )))
-
-(def: io_procs
- Bundle
- (<| (/.prefix "io")
- (|> /.empty
- (/.install "log" (unary //runtime.io//log!))
- (/.install "error" (unary //runtime.io//throw!)))))
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "lux")
- (|> /.empty
- (dictionary.merge lux_procs)
- (dictionary.merge i64_procs)
- (dictionary.merge f64_procs)
- (dictionary.merge text_procs)
- (dictionary.merge io_procs))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux
deleted file mode 100644
index d93fd04ff..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux
+++ /dev/null
@@ -1,142 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- [collection
- ["." dictionary]
- ["." list]]
- [text
- ["%" format (#+ format)]]]
- [target
- ["_" php (#+ Var Expression)]]]
- ["." // #_
- ["#." common (#+ custom)]
- ["//#" /// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["." reference]
- ["//" php #_
- ["#." runtime (#+ Operation Phase Handler Bundle
- with_vars)]]]
- ["/#" // #_
- ["." generation]
- ["//#" /// #_
- ["#." phase]]]]]])
-
-(def: (array::new size)
- (Unary Expression)
- (//runtime.tuple//make size (_.array_fill/3 [(_.int +0) size _.null])))
-
-(def: (array::read [indexG arrayG])
- (Binary Expression)
- (_.nth indexG arrayG))
-
-(def: (array::write [indexG valueG arrayG])
- (Trinary Expression)
- (//runtime.array//write indexG valueG arrayG))
-
-(def: (array::delete [indexG arrayG])
- (Binary Expression)
- (//runtime.array//write indexG _.null arrayG))
-
-(def: array
- Bundle
- (<| (/.prefix "array")
- (|> /.empty
- (/.install "new" (unary array::new))
- (/.install "length" (unary //runtime.array//length))
- (/.install "read" (binary array::read))
- (/.install "write" (trinary array::write))
- (/.install "delete" (binary array::delete))
- )))
-
-(def: object::new
- (custom
- [($_ <>.and <s>.text (<>.some <s>.any))
- (function (_ extension phase archive [constructor inputsS])
- (do {! ////////phase.monad}
- [inputsG (monad.map ! (phase archive) inputsS)]
- (wrap (_.new (_.constant constructor) inputsG))))]))
-
-(def: object::get
- Handler
- (custom
- [($_ <>.and <s>.text <s>.any)
- (function (_ extension phase archive [fieldS objectS])
- (do ////////phase.monad
- [objectG (phase archive objectS)]
- (wrap (_.the fieldS objectG))))]))
-
-(def: object::do
- Handler
- (custom
- [($_ <>.and <s>.text <s>.any (<>.some <s>.any))
- (function (_ extension phase archive [methodS objectS inputsS])
- (do {! ////////phase.monad}
- [objectG (phase archive objectS)
- inputsG (monad.map ! (phase archive) inputsS)]
- (wrap (_.do methodS inputsG objectG))))]))
-
-(template [<!> <?> <unit>]
- [(def: <!> (Nullary Expression) (function.constant <unit>))
- (def: <?> (Unary Expression) (_.=== <unit>))]
-
- [object::null object::null? _.null]
- )
-
-(def: object
- Bundle
- (<| (/.prefix "object")
- (|> /.empty
- (/.install "new" object::new)
- (/.install "get" object::get)
- (/.install "do" object::do)
- (/.install "null" (nullary object::null))
- (/.install "null?" (unary object::null?))
- )))
-
-(def: php::constant
- (custom
- [<s>.text
- (function (_ extension phase archive name)
- (\ ////////phase.monad wrap (_.constant name)))]))
-
-(def: php::apply
- (custom
- [($_ <>.and <s>.any (<>.some <s>.any))
- (function (_ extension phase archive [abstractionS inputsS])
- (do {! ////////phase.monad}
- [abstractionG (phase archive abstractionS)
- inputsG (monad.map ! (phase archive) inputsS)]
- (wrap (_.apply/* inputsG abstractionG))))]))
-
-(def: php::pack
- (custom
- [($_ <>.and <s>.any <s>.any)
- (function (_ extension phase archive [formatS dataS])
- (do {! ////////phase.monad}
- [formatG (phase archive formatS)
- dataG (phase archive dataS)]
- (wrap (_.pack/2 [formatG (_.splat dataG)]))))]))
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "php")
- (|> /.empty
- (dictionary.merge ..array)
- (dictionary.merge ..object)
-
- (/.install "constant" php::constant)
- (/.install "apply" php::apply)
- (/.install "pack" php::pack)
- (/.install "script universe" (nullary (function.constant (_.bool reference.universe))))
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python.lux
deleted file mode 100644
index 5639551c6..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python.lux
+++ /dev/null
@@ -1,17 +0,0 @@
-(.module:
- [lux #*
- [data
- [collection
- ["." dictionary]]]]
- ["." / #_
- ["#." common]
- ["#." host]
- [////
- [generation
- [python
- [runtime (#+ Bundle)]]]]])
-
-(def: #export bundle
- Bundle
- (dictionary.merge /common.bundle
- /host.bundle))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux
deleted file mode 100644
index 61a154efc..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux
+++ /dev/null
@@ -1,170 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["." try]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary]
- ["." list ("#\." functor fold)]]]
- [math
- [number
- ["f" frac]]]
- [target
- ["_" python (#+ Expression)]]]
- ["." //// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["//" python #_
- ["#." runtime (#+ Operation Phase Handler Bundle Generator)]]]
- [//
- [synthesis (#+ %synthesis)]
- ["." generation]
- [///
- ["#" phase]]]]])
-
-(def: #export (custom [parser handler])
- (All [s]
- (-> [(Parser s)
- (-> Text (Generator s))]
- Handler))
- (function (_ extension_name phase archive input)
- (case (<s>.run parser input)
- (#try.Success input')
- (handler extension_name phase archive input')
-
- (#try.Failure error)
- (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
-
-## TODO: Get rid of this ASAP
-(def: lux::syntax_char_case!
- (..custom [($_ <>.and
- <s>.any
- <s>.any
- (<>.some (<s>.tuple ($_ <>.and
- (<s>.tuple (<>.many <s>.i64))
- <s>.any))))
- (function (_ extension_name phase archive [input else conditionals])
- (do {! /////.monad}
- [inputG (phase archive input)
- elseG (phase archive else)
- @input (\ ! map _.var (generation.gensym "input"))
- conditionalsG (: (Operation (List [(Expression Any)
- (Expression Any)]))
- (monad.map ! (function (_ [chars branch])
- (do !
- [branchG (phase archive branch)]
- (wrap [(|> chars
- (list\map (|>> .int _.int (_.= @input)))
- (list\fold (function (_ clause total)
- (if (is? _.none total)
- clause
- (_.or clause total)))
- _.none))
- branchG])))
- conditionals))
- #let [closure (_.lambda (list @input)
- (list\fold (function (_ [test then] else)
- (_.? test then else))
- elseG
- conditionalsG))]]
- (wrap (_.apply/* closure (list inputG)))))]))
-
-(def: lux_procs
- Bundle
- (|> /.empty
- (/.install "syntax char case!" lux::syntax_char_case!)
- (/.install "is" (binary (product.uncurry _.is)))
- (/.install "try" (unary //runtime.lux::try))))
-
-(def: (capped operation parameter subject)
- (-> (-> (Expression Any) (Expression Any) (Expression Any))
- (-> (Expression Any) (Expression Any) (Expression Any)))
- (//runtime.i64::64 (operation parameter subject)))
-
-(def: i64_procs
- Bundle
- (<| (/.prefix "i64")
- (|> /.empty
- (/.install "and" (binary (product.uncurry //runtime.i64::and)))
- (/.install "or" (binary (product.uncurry //runtime.i64::or)))
- (/.install "xor" (binary (product.uncurry //runtime.i64::xor)))
- (/.install "left-shift" (binary (product.uncurry //runtime.i64::left_shift)))
- (/.install "right-shift" (binary (product.uncurry //runtime.i64::right_shift)))
-
- (/.install "<" (binary (product.uncurry _.<)))
- (/.install "=" (binary (product.uncurry _.=)))
- (/.install "+" (binary (product.uncurry (..capped _.+))))
- (/.install "-" (binary (product.uncurry (..capped _.-))))
- (/.install "*" (binary (product.uncurry (..capped _.*))))
- (/.install "/" (binary (product.uncurry //runtime.i64::division)))
- (/.install "%" (binary (product.uncurry //runtime.i64::remainder)))
- (/.install "f64" (unary _.float/1))
- (/.install "char" (unary //runtime.i64::char))
- )))
-
-(def: f64_procs
- Bundle
- (<| (/.prefix "f64")
- (|> /.empty
- (/.install "+" (binary (product.uncurry _.+)))
- (/.install "-" (binary (product.uncurry _.-)))
- (/.install "*" (binary (product.uncurry _.*)))
- (/.install "/" (binary (product.uncurry //runtime.f64::/)))
- (/.install "%" (binary (function (_ [parameter subject])
- (|> (_.__import__/1 (_.unicode "math"))
- (_.do "fmod" (list subject parameter))))))
- (/.install "=" (binary (product.uncurry _.=)))
- (/.install "<" (binary (product.uncurry _.<)))
- (/.install "i64" (unary _.int/1))
- (/.install "encode" (unary _.repr/1))
- (/.install "decode" (unary //runtime.f64::decode)))))
-
-(def: (text::clip [paramO extraO subjectO])
- (Trinary (Expression Any))
- (//runtime.text::clip paramO extraO subjectO))
-
-(def: (text::index [startO partO textO])
- (Trinary (Expression Any))
- (//runtime.text::index startO partO textO))
-
-(def: text_procs
- Bundle
- (<| (/.prefix "text")
- (|> /.empty
- (/.install "=" (binary (product.uncurry _.=)))
- (/.install "<" (binary (product.uncurry _.<)))
- (/.install "concat" (binary (product.uncurry (function.flip _.+))))
- (/.install "index" (trinary ..text::index))
- (/.install "size" (unary _.len/1))
- (/.install "char" (binary (product.uncurry //runtime.text::char)))
- (/.install "clip" (trinary ..text::clip))
- )))
-
-(def: io_procs
- Bundle
- (<| (/.prefix "io")
- (|> /.empty
- (/.install "log" (unary //runtime.io::log!))
- (/.install "error" (unary //runtime.io::throw!)))))
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "lux")
- (|> lux_procs
- (dictionary.merge i64_procs)
- (dictionary.merge f64_procs)
- (dictionary.merge text_procs)
- (dictionary.merge io_procs)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux
deleted file mode 100644
index a46bbb9cc..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux
+++ /dev/null
@@ -1,164 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- [collection
- ["." dictionary]
- ["." list]]]
- [target
- ["_" python (#+ Expression SVar)]]]
- ["." // #_
- ["#." common (#+ custom)]
- ["//#" /// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["//" python #_
- ["#." runtime (#+ Operation Phase Handler Bundle
- with_vars)]]]
- ["/#" // #_
- ["." generation]
- ["//#" /// #_
- ["#." phase]]]]]])
-
-(def: (array::new size)
- (Unary (Expression Any))
- (|> (list _.none)
- _.list
- (_.* size)))
-
-(def: array::length
- (Unary (Expression Any))
- (|>> _.len/1 //runtime.i64::64))
-
-(def: (array::read [indexG arrayG])
- (Binary (Expression Any))
- (_.nth indexG arrayG))
-
-(def: (array::write [indexG valueG arrayG])
- (Trinary (Expression Any))
- (//runtime.array::write indexG valueG arrayG))
-
-(def: (array::delete [indexG arrayG])
- (Binary (Expression Any))
- (//runtime.array::write indexG _.none arrayG))
-
-(def: array
- Bundle
- (<| (/.prefix "array")
- (|> /.empty
- (/.install "new" (unary array::new))
- (/.install "length" (unary array::length))
- (/.install "read" (binary array::read))
- (/.install "write" (trinary array::write))
- (/.install "delete" (binary array::delete))
- )))
-
-(def: object::get
- Handler
- (custom
- [($_ <>.and <s>.text <s>.any)
- (function (_ extension phase archive [fieldS objectS])
- (do ////////phase.monad
- [objectG (phase archive objectS)]
- (wrap (_.the fieldS objectG))))]))
-
-(def: object::do
- Handler
- (custom
- [($_ <>.and <s>.text <s>.any (<>.some <s>.any))
- (function (_ extension phase archive [methodS objectS inputsS])
- (do {! ////////phase.monad}
- [objectG (phase archive objectS)
- inputsG (monad.map ! (phase archive) inputsS)]
- (wrap (_.do methodS inputsG objectG))))]))
-
-(template [<!> <?> <unit>]
- [(def: <!> (Nullary (Expression Any)) (function.constant <unit>))
- (def: <?> (Unary (Expression Any)) (_.= <unit>))]
-
- [object::none object::none? _.none]
- )
-
-(def: object
- Bundle
- (<| (/.prefix "object")
- (|> /.empty
- (/.install "get" object::get)
- (/.install "do" object::do)
- (/.install "none" (nullary object::none))
- (/.install "none?" (unary object::none?))
- )))
-
-(def: python::constant
- (custom
- [<s>.text
- (function (_ extension phase archive name)
- (do ////////phase.monad
- []
- (wrap (_.var name))))]))
-
-(def: python::import
- (custom
- [<s>.text
- (function (_ extension phase archive module)
- (do ////////phase.monad
- []
- (wrap (_.apply/* (_.var "__import__") (list (_.string module))))))]))
-
-(def: python::apply
- (custom
- [($_ <>.and <s>.any (<>.some <s>.any))
- (function (_ extension phase archive [abstractionS inputsS])
- (do {! ////////phase.monad}
- [abstractionG (phase archive abstractionS)
- inputsG (monad.map ! (phase archive) inputsS)]
- (wrap (_.apply/* abstractionG inputsG))))]))
-
-(def: python::function
- (custom
- [($_ <>.and <s>.i64 <s>.any)
- (function (_ extension phase archive [arity abstractionS])
- (do {! ////////phase.monad}
- [abstractionG (phase archive abstractionS)
- #let [variable (: (-> Text (Operation SVar))
- (|>> generation.gensym
- (\ ! map _.var)))]
- g!inputs (monad.map ! (function (_ _) (variable "input"))
- (list.repeat (.nat arity) []))]
- (wrap (_.lambda g!inputs
- (case (.nat arity)
- 0 (_.apply/1 abstractionG //runtime.unit)
- 1 (_.apply/* abstractionG g!inputs)
- _ (_.apply/1 abstractionG (_.list g!inputs)))))))]))
-
-(def: python::exec
- (custom
- [($_ <>.and <s>.any <s>.any)
- (function (_ extension phase archive [codeS globalsS])
- (do {! ////////phase.monad}
- [codeG (phase archive codeS)
- globalsG (phase archive globalsS)]
- (wrap (//runtime.lux::exec codeG globalsG))))]))
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "python")
- (|> /.empty
- (dictionary.merge ..array)
- (dictionary.merge ..object)
-
- (/.install "constant" python::constant)
- (/.install "import" python::import)
- (/.install "apply" python::apply)
- (/.install "function" python::function)
- (/.install "exec" python::exec)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux
deleted file mode 100644
index cd0f6b7cc..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux
+++ /dev/null
@@ -1,17 +0,0 @@
-(.module:
- [lux #*
- [data
- [collection
- ["." dictionary]]]]
- ["." / #_
- ["#." common]
- ["#." host]
- [////
- [generation
- [r
- [runtime (#+ Bundle)]]]]])
-
-(def: #export bundle
- Bundle
- (dictionary.merge /common.bundle
- /host.bundle))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux
deleted file mode 100644
index d9178d8c2..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux
+++ /dev/null
@@ -1,178 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["." try]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary]
- ["." set]
- ["." list ("#\." functor fold)]]]
- [math
- [number
- ["f" frac]]]
- ["@" target
- ["_" r (#+ Expression)]]]
- ["." //// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["." reference]
- ["//" r #_
- ["#." runtime (#+ Operation Phase Handler Bundle Generator)]
- ["#." case]]]
- [//
- ["." synthesis (#+ %synthesis)]
- ["." generation]
- [///
- ["#" phase]]]]])
-
-(def: #export (custom [parser handler])
- (All [s]
- (-> [(Parser s)
- (-> Text (Generator s))]
- Handler))
- (function (_ extension_name phase archive input)
- (case (<s>.run parser input)
- (#try.Success input')
- (handler extension_name phase archive input')
-
- (#try.Failure error)
- (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
-
-## (template: (!unary function)
-## (|>> list _.apply/* (|> (_.constant function))))
-
-## ## ## TODO: Get rid of this ASAP
-## ## (def: lux::syntax_char_case!
-## ## (..custom [($_ <>.and
-## ## <s>.any
-## ## <s>.any
-## ## (<>.some (<s>.tuple ($_ <>.and
-## ## (<s>.tuple (<>.many <s>.i64))
-## ## <s>.any))))
-## ## (function (_ extension_name phase archive [input else conditionals])
-## ## (do {! /////.monad}
-## ## [@input (\ ! map _.var (generation.gensym "input"))
-## ## inputG (phase archive input)
-## ## elseG (phase archive else)
-## ## conditionalsG (: (Operation (List [Expression Expression]))
-## ## (monad.map ! (function (_ [chars branch])
-## ## (do !
-## ## [branchG (phase archive branch)]
-## ## (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or)
-## ## branchG])))
-## ## conditionals))]
-## ## (wrap (_.let (list [@input inputG])
-## ## (list (list\fold (function (_ [test then] else)
-## ## (_.if test then else))
-## ## elseG
-## ## conditionalsG))))))]))
-
-## (def: lux_procs
-## Bundle
-## (|> /.empty
-## ## (/.install "syntax char case!" lux::syntax_char_case!)
-## (/.install "is" (binary _.eq/2))
-## ## (/.install "try" (unary //runtime.lux//try))
-## ))
-
-## ## (def: (capped operation parameter subject)
-## ## (-> (-> Expression Expression Expression)
-## ## (-> Expression Expression Expression))
-## ## (//runtime.i64//64 (operation parameter subject)))
-
-(def: i64_procs
- Bundle
- (<| (/.prefix "i64")
- (|> /.empty
- ## (/.install "and" (binary _.logand/2))
- ## (/.install "or" (binary _.logior/2))
- ## (/.install "xor" (binary _.logxor/2))
- ## (/.install "left-shift" (binary _.ash/2))
- ## (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift)))
- ## (/.install "=" (binary _.=/2))
- ## (/.install "<" (binary _.</2))
- ## (/.install "+" (binary _.+/2))
- ## (/.install "-" (binary _.-/2))
- ## (/.install "*" (binary _.*/2))
- ## (/.install "/" (binary _.floor/2))
- ## (/.install "%" (binary _.rem/2))
- ## (/.install "f64" (unary (_.//2 (_.float +1.0))))
- (/.install "char" (unary (|>> //runtime.i64_low _.intToUtf8/1)))
- )))
-
-## (def: f64_procs
-## Bundle
-## (<| (/.prefix "f64")
-## (|> /.empty
-## ## (/.install "=" (binary (product.uncurry _.=/2)))
-## ## (/.install "<" (binary (product.uncurry _.</2)))
-## ## (/.install "+" (binary (product.uncurry _.+/2)))
-## ## (/.install "-" (binary (product.uncurry _.-/2)))
-## ## (/.install "*" (binary (product.uncurry _.*/2)))
-## ## (/.install "/" (binary (product.uncurry _.//2)))
-## ## (/.install "%" (binary (product.uncurry _.rem/2)))
-## ## (/.install "i64" (unary _.truncate/1))
-## (/.install "encode" (unary _.write-to-string/1))
-## ## (/.install "decode" (unary //runtime.f64//decode))
-## )))
-
-## (def: (text//index [offset sub text])
-## (Trinary (Expression Any))
-## (//runtime.text//index offset sub text))
-
-## (def: (text//clip [offset length text])
-## (Trinary (Expression Any))
-## (//runtime.text//clip offset length text))
-
-## (def: (text//char [index text])
-## (Binary (Expression Any))
-## (_.char-code/1 (_.char/2 [text index])))
-
-(def: text_procs
- Bundle
- (<| (/.prefix "text")
- (|> /.empty
- ## (/.install "=" (binary _.string=/2))
- ## (/.install "<" (binary (product.uncurry _.string<?/2)))
- (/.install "concat" (binary _.paste/2))
- ## (/.install "index" (trinary ..text//index))
- ## (/.install "size" (unary _.length/1))
- ## (/.install "char" (binary ..text//char))
- ## (/.install "clip" (trinary ..text//clip))
- )))
-
-## (def: (io//log! message)
-## (Unary (Expression Any))
-## (_.progn (list (_.write-line/1 message)
-## //runtime.unit)))
-
-## (def: io_procs
-## Bundle
-## (<| (/.prefix "io")
-## (|> /.empty
-## (/.install "log" (unary ..io//log!))
-## (/.install "error" (unary _.error/1))
-## )))
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "lux")
- (|> /.empty
- ## (dictionary.merge lux_procs)
- (dictionary.merge i64_procs)
- ## (dictionary.merge f64_procs)
- (dictionary.merge text_procs)
- ## (dictionary.merge io_procs)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux
deleted file mode 100644
index 2d9148dda..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux
+++ /dev/null
@@ -1,39 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- [collection
- ["." dictionary]
- ["." list]]
- [text
- ["%" format (#+ format)]]]
- [target
- ["_" r (#+ Var Expression)]]]
- ["." // #_
- ["#." common (#+ custom)]
- ["//#" /// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["." reference]
- ["//" r #_
- ["#." runtime (#+ Operation Phase Handler Bundle
- with_vars)]]]
- ["/#" // #_
- ["." generation]
- ["//#" /// #_
- ["#." phase]]]]]])
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "r")
- (|> /.empty
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux
deleted file mode 100644
index 12bcfc9b1..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux
+++ /dev/null
@@ -1,17 +0,0 @@
-(.module:
- [lux #*
- [data
- [collection
- ["." dictionary]]]]
- ["." / #_
- ["#." common]
- ["#." host]
- [////
- [generation
- [ruby
- [runtime (#+ Bundle)]]]]])
-
-(def: #export bundle
- Bundle
- (dictionary.merge /common.bundle
- /host.bundle))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux
deleted file mode 100644
index 030b3b239..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux
+++ /dev/null
@@ -1,185 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["." try]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary]
- ["." list ("#\." functor fold)]]]
- [math
- [number
- ["f" frac]]]
- [target
- ["_" ruby (#+ Expression)]]]
- ["." //// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["//" ruby #_
- ["#." runtime (#+ Operation Phase Handler Bundle Generator)]]]
- [//
- [synthesis (#+ %synthesis)]
- ["." generation]
- [///
- ["#" phase]]]]])
-
-(def: #export (custom [parser handler])
- (All [s]
- (-> [(Parser s)
- (-> Text (Generator s))]
- Handler))
- (function (_ extension_name phase archive input)
- (case (<s>.run parser input)
- (#try.Success input')
- (handler extension_name phase archive input')
-
- (#try.Failure error)
- (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
-
-## TODO: Get rid of this ASAP
-(def: lux::syntax_char_case!
- (..custom [($_ <>.and
- <s>.any
- <s>.any
- (<>.some (<s>.tuple ($_ <>.and
- (<s>.tuple (<>.many <s>.i64))
- <s>.any))))
- (function (_ extension_name phase archive [input else conditionals])
- (do {! /////.monad}
- [inputG (phase archive input)
- elseG (phase archive else)
- @input (\ ! map _.local (generation.gensym "input"))
- conditionalsG (: (Operation (List [Expression Expression]))
- (monad.map ! (function (_ [chars branch])
- (do !
- [branchG (phase archive branch)]
- (wrap [(|> chars
- (list\map (|>> .int _.int (_.= @input)))
- (list\fold (function (_ clause total)
- (if (is? _.nil total)
- clause
- (_.or clause total)))
- _.nil))
- branchG])))
- conditionals))
- #let [closure (_.lambda #.None (list @input)
- (list\fold (function (_ [test then] else)
- (_.if test (_.return then) else))
- (_.return elseG)
- conditionalsG))]]
- (wrap (_.apply_lambda/* (list inputG) closure))))]))
-
-(def: lux_procs
- Bundle
- (|> /.empty
- (/.install "syntax char case!" lux::syntax_char_case!)
- (/.install "is" (binary (function (_ [reference subject])
- (_.do "equal?" (list reference) subject))))
- (/.install "try" (unary //runtime.lux//try))))
-
-(def: (capped operation parameter subject)
- (-> (-> Expression Expression Expression)
- (-> Expression Expression Expression))
- (//runtime.i64//64 (operation parameter subject)))
-
-(def: i64_procs
- Bundle
- (<| (/.prefix "i64")
- (|> /.empty
- (/.install "and" (binary (product.uncurry //runtime.i64//and)))
- (/.install "or" (binary (product.uncurry //runtime.i64//or)))
- (/.install "xor" (binary (product.uncurry //runtime.i64//xor)))
- (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift)))
- (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift)))
-
- (/.install "<" (binary (product.uncurry _.<)))
- (/.install "=" (binary (product.uncurry _.=)))
- (/.install "+" (binary (product.uncurry (..capped _.+))))
- (/.install "-" (binary (product.uncurry (..capped _.-))))
- (/.install "*" (binary (product.uncurry (..capped _.*))))
- (/.install "/" (binary (product.uncurry //runtime.i64//division)))
- (/.install "%" (binary (function (_ [parameter subject])
- (_.do "remainder" (list parameter) subject))))
-
- (/.install "f64" (unary (_./ (_.float +1.0))))
- (/.install "char" (unary (_.do "chr" (list (_.string "UTF-8")))))
- )))
-
-(def: f64_procs
- Bundle
- (<| (/.prefix "f64")
- (|> /.empty
- (/.install "+" (binary (product.uncurry _.+)))
- (/.install "-" (binary (product.uncurry _.-)))
- (/.install "*" (binary (product.uncurry _.*)))
- (/.install "/" (binary (product.uncurry _./)))
- (/.install "%" (binary (function (_ [parameter subject])
- (_.do "remainder" (list parameter) subject))))
- (/.install "=" (binary (product.uncurry _.=)))
- (/.install "<" (binary (product.uncurry _.<)))
- (/.install "i64" (unary (_.do "floor" (list))))
- (/.install "encode" (unary (_.do "to_s" (list))))
- (/.install "decode" (unary //runtime.f64//decode)))))
-
-(def: (text//char [subjectO paramO])
- (Binary Expression)
- (//runtime.text//char subjectO paramO))
-
-(def: (text//clip [paramO extraO subjectO])
- (Trinary Expression)
- (//runtime.text//clip paramO extraO subjectO))
-
-(def: (text//index [startO partO textO])
- (Trinary Expression)
- (//runtime.text//index textO partO startO))
-
-(def: text_procs
- Bundle
- (<| (/.prefix "text")
- (|> /.empty
- (/.install "=" (binary (product.uncurry _.=)))
- (/.install "<" (binary (product.uncurry _.<)))
- (/.install "concat" (binary (product.uncurry (function.flip _.+))))
- (/.install "index" (trinary text//index))
- (/.install "size" (unary (_.the "length")))
- (/.install "char" (binary (product.uncurry //runtime.text//char)))
- (/.install "clip" (trinary text//clip))
- )))
-
-(def: (io//log! messageG)
- (Unary Expression)
- (|> (_.print/2 messageG (_.string text.new_line))
- (_.or //runtime.unit)))
-
-(def: io//error!
- (Unary Expression)
- _.raise)
-
-(def: io_procs
- Bundle
- (<| (/.prefix "io")
- (|> /.empty
- (/.install "log" (unary ..io//log!))
- (/.install "error" (unary ..io//error!))
- )))
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "lux")
- (|> lux_procs
- (dictionary.merge ..i64_procs)
- (dictionary.merge ..f64_procs)
- (dictionary.merge ..text_procs)
- (dictionary.merge ..io_procs)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux
deleted file mode 100644
index 206034cd7..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux
+++ /dev/null
@@ -1,135 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- [collection
- ["." dictionary]
- ["." list]]
- [text
- ["%" format (#+ format)]]]
- [target
- ["_" ruby (#+ Var Expression)]]]
- ["." // #_
- ["#." common (#+ custom)]
- ["//#" /// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["." reference]
- ["//" ruby #_
- ["#." runtime (#+ Operation Phase Handler Bundle
- with_vars)]]]
- ["/#" // #_
- ["." generation]
- ["//#" /// #_
- ["#." phase]]]]]])
-
-(def: (array::new [size])
- (Unary Expression)
- (_.do "new" (list size) (_.local "Array")))
-
-(def: array::length
- (Unary Expression)
- (_.the "size"))
-
-(def: (array::read [indexG arrayG])
- (Binary Expression)
- (_.nth indexG arrayG))
-
-(def: (array::write [indexG valueG arrayG])
- (Trinary Expression)
- (//runtime.array//write indexG valueG arrayG))
-
-(def: (array::delete [indexG arrayG])
- (Binary Expression)
- (//runtime.array//write indexG _.nil arrayG))
-
-(def: array
- Bundle
- (<| (/.prefix "array")
- (|> /.empty
- (/.install "new" (unary array::new))
- (/.install "length" (unary array::length))
- (/.install "read" (binary array::read))
- (/.install "write" (trinary array::write))
- (/.install "delete" (binary array::delete))
- )))
-
-(def: object::get
- Handler
- (custom
- [($_ <>.and <s>.text <s>.any)
- (function (_ extension phase archive [fieldS objectS])
- (do ////////phase.monad
- [objectG (phase archive objectS)]
- (wrap (_.the fieldS objectG))))]))
-
-(def: object::do
- Handler
- (custom
- [($_ <>.and <s>.text <s>.any (<>.some <s>.any))
- (function (_ extension phase archive [methodS objectS inputsS])
- (do {! ////////phase.monad}
- [objectG (phase archive objectS)
- inputsG (monad.map ! (phase archive) inputsS)]
- (wrap (_.do methodS inputsG objectG))))]))
-
-(template [<!> <?> <unit>]
- [(def: <!> (Nullary Expression) (function.constant <unit>))
- (def: <?> (Unary Expression) (_.= <unit>))]
-
- [object::nil object::nil? _.nil]
- )
-
-(def: object
- Bundle
- (<| (/.prefix "object")
- (|> /.empty
- (/.install "get" object::get)
- (/.install "do" object::do)
- (/.install "nil" (nullary object::nil))
- (/.install "nil?" (unary object::nil?))
- )))
-
-(def: ruby::constant
- (custom
- [<s>.text
- (function (_ extension phase archive name)
- (\ ////////phase.monad wrap (_.local name)))]))
-
-(def: ruby::apply
- (custom
- [($_ <>.and <s>.any (<>.some <s>.any))
- (function (_ extension phase archive [abstractionS inputsS])
- (do {! ////////phase.monad}
- [abstractionG (phase archive abstractionS)
- inputsG (monad.map ! (phase archive) inputsS)]
- (wrap (_.apply/* inputsG abstractionG))))]))
-
-(def: ruby::import
- (custom
- [<s>.text
- (function (_ extension phase archive module)
- (\ ////////phase.monad wrap
- (_.require/1 (_.string module))))]))
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "ruby")
- (|> /.empty
- (dictionary.merge ..array)
- (dictionary.merge ..object)
-
- (/.install "constant" ruby::constant)
- (/.install "apply" ruby::apply)
- (/.install "import" ruby::import)
- (/.install "script universe" (nullary (function.constant (_.bool reference.universe))))
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux
deleted file mode 100644
index 945e90e57..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux
+++ /dev/null
@@ -1,17 +0,0 @@
-(.module:
- [lux #*
- [data
- [collection
- ["." dictionary]]]]
- ["." / #_
- ["#." common]
- ["#." host]
- [////
- [generation
- [scheme
- [runtime (#+ Bundle)]]]]])
-
-(def: #export bundle
- Bundle
- (dictionary.merge /common.bundle
- /host.bundle))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux
deleted file mode 100644
index 4f1258794..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux
+++ /dev/null
@@ -1,174 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["." try]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary]
- ["." set]
- ["." list ("#\." functor fold)]]]
- [math
- [number
- ["f" frac]]]
- ["@" target
- ["_" scheme (#+ Expression)]]]
- ["." //// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["." reference]
- ["//" scheme #_
- ["#." runtime (#+ Operation Phase Handler Bundle Generator)]
- ["#." case]]]
- [//
- ["." synthesis (#+ %synthesis)]
- ["." generation]
- [///
- ["#" phase]]]]])
-
-(def: #export (custom [parser handler])
- (All [s]
- (-> [(Parser s)
- (-> Text (Generator s))]
- Handler))
- (function (_ extension_name phase archive input)
- (case (<s>.run parser input)
- (#try.Success input')
- (handler extension_name phase archive input')
-
- (#try.Failure error)
- (/////.throw extension.invalid_syntax [extension_name %synthesis input]))))
-
-(template: (!unary function)
- (|>> list _.apply/* (|> (_.constant function))))
-
-## TODO: Get rid of this ASAP
-(def: lux::syntax_char_case!
- (..custom [($_ <>.and
- <s>.any
- <s>.any
- (<>.some (<s>.tuple ($_ <>.and
- (<s>.tuple (<>.many <s>.i64))
- <s>.any))))
- (function (_ extension_name phase archive [input else conditionals])
- (do {! /////.monad}
- [@input (\ ! map _.var (generation.gensym "input"))
- inputG (phase archive input)
- elseG (phase archive else)
- conditionalsG (: (Operation (List [Expression Expression]))
- (monad.map ! (function (_ [chars branch])
- (do !
- [branchG (phase archive branch)]
- (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or)
- branchG])))
- conditionals))]
- (wrap (_.let (list [@input inputG])
- (list\fold (function (_ [test then] else)
- (_.if test then else))
- elseG
- conditionalsG)))))]))
-
-(def: lux_procs
- Bundle
- (|> /.empty
- (/.install "syntax char case!" lux::syntax_char_case!)
- (/.install "is" (binary (product.uncurry _.eq?/2)))
- (/.install "try" (unary //runtime.lux//try))
- ))
-
-(def: (capped operation parameter subject)
- (-> (-> Expression Expression Expression)
- (-> Expression Expression Expression))
- (//runtime.i64//64 (operation parameter subject)))
-
-(def: i64_procs
- Bundle
- (<| (/.prefix "i64")
- (|> /.empty
- (/.install "and" (binary (product.uncurry //runtime.i64//and)))
- (/.install "or" (binary (product.uncurry //runtime.i64//or)))
- (/.install "xor" (binary (product.uncurry //runtime.i64//xor)))
- (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift)))
- (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift)))
- (/.install "=" (binary (product.uncurry _.=/2)))
- (/.install "<" (binary (product.uncurry _.</2)))
- (/.install "+" (binary (product.uncurry (..capped _.+/2))))
- (/.install "-" (binary (product.uncurry (..capped _.-/2))))
- (/.install "*" (binary (product.uncurry (..capped _.*/2))))
- (/.install "/" (binary (product.uncurry //runtime.i64//division)))
- (/.install "%" (binary (product.uncurry _.remainder/2)))
- (/.install "f64" (unary (_.//2 (_.float +1.0))))
- (/.install "char" (unary (|>> _.integer->char/1 (_.make-string/2 (_.int +1)))))
- )))
-
-(def: f64_procs
- Bundle
- (<| (/.prefix "f64")
- (|> /.empty
- (/.install "=" (binary (product.uncurry _.=/2)))
- (/.install "<" (binary (product.uncurry _.</2)))
- (/.install "+" (binary (product.uncurry _.+/2)))
- (/.install "-" (binary (product.uncurry _.-/2)))
- (/.install "*" (binary (product.uncurry _.*/2)))
- (/.install "/" (binary (product.uncurry _.//2)))
- (/.install "%" (binary (product.uncurry _.remainder/2)))
- (/.install "i64" (unary _.truncate/1))
- (/.install "encode" (unary _.number->string/1))
- (/.install "decode" (unary //runtime.f64//decode)))))
-
-(def: (text//index [offset sub text])
- (Trinary Expression)
- (//runtime.text//index offset sub text))
-
-(def: (text//clip [paramO extraO subjectO])
- (Trinary Expression)
- (//runtime.text//clip paramO extraO subjectO))
-
-(def: text_procs
- Bundle
- (<| (/.prefix "text")
- (|> /.empty
- (/.install "=" (binary (product.uncurry _.string=?/2)))
- (/.install "<" (binary (product.uncurry _.string<?/2)))
- (/.install "concat" (binary (product.uncurry _.string-append/2)))
- (/.install "index" (trinary ..text//index))
- (/.install "size" (unary _.string-length/1))
- (/.install "char" (binary (product.uncurry //runtime.text//char)))
- (/.install "clip" (trinary ..text//clip))
- )))
-
-(def: (io//log! message)
- (Unary Expression)
- (_.begin (list (_.display/1 message)
- (_.display/1 (_.string text.new_line))
- //runtime.unit)))
-
-(def: io_procs
- Bundle
- (<| (/.prefix "io")
- (|> /.empty
- (/.install "log" (unary ..io//log!))
- (/.install "error" (unary _.raise/1))
- )))
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "lux")
- (|> /.empty
- (dictionary.merge lux_procs)
- (dictionary.merge i64_procs)
- (dictionary.merge f64_procs)
- (dictionary.merge text_procs)
- (dictionary.merge io_procs)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux
deleted file mode 100644
index 6072d29e5..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux
+++ /dev/null
@@ -1,108 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<s>" synthesis (#+ Parser)]]]
- [data
- [collection
- ["." dictionary]
- ["." list]]
- [text
- ["%" format (#+ format)]]]
- [target
- ["_" scheme (#+ Var Expression)]]]
- ["." // #_
- ["#." common (#+ custom)]
- ["//#" /// #_
- ["/" bundle]
- ["/#" // #_
- ["." extension]
- [generation
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- ["." reference]
- ["//" scheme #_
- ["#." runtime (#+ Operation Phase Handler Bundle
- with_vars)]]]
- ["/#" // #_
- ["." generation]
- ["//#" /// #_
- ["#." phase]]]]]])
-
-(def: (array::new size)
- (Unary Expression)
- (_.make-vector/2 size _.nil))
-
-(def: array::length
- (Unary Expression)
- _.vector-length/1)
-
-(def: (array::read [indexG arrayG])
- (Binary Expression)
- (_.vector-ref/2 arrayG indexG))
-
-(def: (array::write [indexG valueG arrayG])
- (Trinary Expression)
- (//runtime.array//write indexG valueG arrayG))
-
-(def: (array::delete [indexG arrayG])
- (Binary Expression)
- (//runtime.array//write indexG _.nil arrayG))
-
-(def: array
- Bundle
- (<| (/.prefix "array")
- (|> /.empty
- (/.install "new" (unary array::new))
- (/.install "length" (unary array::length))
- (/.install "read" (binary array::read))
- (/.install "write" (trinary array::write))
- (/.install "delete" (binary array::delete))
- )))
-
-(template [<!> <?> <unit>]
- [(def: <!> (Nullary Expression) (function.constant <unit>))
- (def: <?> (Unary Expression) (_.eq?/2 <unit>))]
-
- [object::nil object::nil? _.nil]
- )
-
-(def: object
- Bundle
- (<| (/.prefix "object")
- (|> /.empty
- (/.install "nil" (nullary object::nil))
- (/.install "nil?" (unary object::nil?))
- )))
-
-(def: scheme::constant
- (custom
- [<s>.text
- (function (_ extension phase archive name)
- (do ////////phase.monad
- []
- (wrap (_.var name))))]))
-
-(def: scheme::apply
- (custom
- [($_ <>.and <s>.any (<>.some <s>.any))
- (function (_ extension phase archive [abstractionS inputsS])
- (do {! ////////phase.monad}
- [abstractionG (phase archive abstractionS)
- inputsG (monad.map ! (phase archive) inputsS)]
- (wrap (_.apply/* inputsG abstractionG))))]))
-
-(def: #export bundle
- Bundle
- (<| (/.prefix "scheme")
- (|> /.empty
- (dictionary.merge ..array)
- (dictionary.merge ..object)
-
- (/.install "constant" scheme::constant)
- (/.install "apply" scheme::apply)
- (/.install "script universe" (nullary (function.constant (_.bool reference.universe))))
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/synthesis.lux
deleted file mode 100644
index 40fb4f89e..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/synthesis.lux
+++ /dev/null
@@ -1,10 +0,0 @@
-(.module:
- [lux #*]
- [//
- ["." bundle]
- [///
- [synthesis (#+ Bundle)]]])
-
-(def: #export bundle
- Bundle
- bundle.empty)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux
deleted file mode 100644
index 7b81d9d4a..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux
+++ /dev/null
@@ -1,56 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]]
- ["." / #_
- [runtime (#+ Phase)]
- ["#." primitive]
- ["#." structure]
- ["#." reference]
- ["#." case]
- ["#." loop]
- ["#." function]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- ["#." extension]
- ["/#" // #_
- [analysis (#+)]
- ["#." synthesis]
- ["//#" /// #_
- ["#." phase ("#\." monad)]
- [reference (#+)
- [variable (#+)]]]]]]])
-
-(def: #export (generate archive synthesis)
- Phase
- (case synthesis
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (//////phase\wrap (<generator> value))])
- ([////synthesis.bit /primitive.bit]
- [////synthesis.i64 /primitive.i64]
- [////synthesis.f64 /primitive.f64]
- [////synthesis.text /primitive.text])
-
- (#////synthesis.Reference value)
- (//reference.reference /reference.system archive value)
-
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (<generator> generate archive value)])
- ([////synthesis.variant /structure.variant]
- [////synthesis.tuple /structure.tuple]
- [////synthesis.branch/let /case.let]
- [////synthesis.branch/if /case.if]
- [////synthesis.branch/get /case.get]
- [////synthesis.function/apply /function.apply]
-
- [////synthesis.branch/case /case.case]
- [////synthesis.loop/scope /loop.scope]
- [////synthesis.loop/recur /loop.recur]
- [////synthesis.function/abstraction /function.function])
-
- (#////synthesis.Extension extension)
- (///extension.apply archive generate extension)
- ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux
deleted file mode 100644
index 2896e0030..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux
+++ /dev/null
@@ -1,261 +0,0 @@
-(.module:
- [lux (#- case let if)
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." exception (#+ exception:)]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold monoid)]
- ["." set]]]
- [math
- [number
- ["n" nat]]]
- [target
- ["_" common_lisp (#+ Expression Var/1)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." reference]
- ["#." primitive]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- ["#." synthesis #_
- ["#/." case]]
- ["/#" // #_
- ["#." synthesis (#+ Member Synthesis Path)]
- ["#." generation]
- ["//#" /// #_
- [reference
- ["#." variable (#+ Register)]]
- ["#." phase ("#\." monad)]
- [meta
- [archive (#+ Archive)]]]]]]])
-
-(def: #export register
- (-> Register Var/1)
- (|>> (///reference.local //reference.system) :assume))
-
-(def: #export capture
- (-> Register Var/1)
- (|>> (///reference.foreign //reference.system) :assume))
-
-(def: #export (let expression archive [valueS register bodyS])
- (Generator [Synthesis Register Synthesis])
- (do ///////phase.monad
- [valueG (expression archive valueS)
- bodyG (expression archive bodyS)]
- (wrap (_.let (list [(..register register) valueG])
- (list bodyG)))))
-
-(def: #export (if expression archive [testS thenS elseS])
- (Generator [Synthesis Synthesis Synthesis])
- (do ///////phase.monad
- [testG (expression archive testS)
- thenG (expression archive thenS)
- elseG (expression archive elseS)]
- (wrap (_.if testG thenG elseG))))
-
-(def: #export (get expression archive [pathP valueS])
- (Generator [(List Member) Synthesis])
- (do ///////phase.monad
- [valueG (expression archive valueS)]
- (wrap (list\fold (function (_ side source)
- (.let [method (.case side
- (^template [<side> <accessor>]
- [(<side> lefts)
- (<accessor> (_.int (.int lefts)))])
- ([#.Left //runtime.tuple//left]
- [#.Right //runtime.tuple//right]))]
- (method source)))
- valueG
- pathP))))
-
-(def: @savepoint (_.var "lux_pm_savepoint"))
-(def: @cursor (_.var "lux_pm_cursor"))
-(def: @temp (_.var "lux_pm_temp"))
-(def: @variant (_.var "lux_pm_variant"))
-
-(def: (push! value)
- (-> (Expression Any) (Expression Any))
- (_.setq @cursor (_.cons/2 [value @cursor])))
-
-(def: pop!
- (Expression Any)
- (_.setq @cursor (_.cdr/1 @cursor)))
-
-(def: peek
- (Expression Any)
- (_.car/1 @cursor))
-
-(def: save!
- (Expression Any)
- (_.setq @savepoint (_.cons/2 [@cursor @savepoint])))
-
-(def: restore!
- (List (Expression Any))
- (list (_.setq @cursor (_.car/1 @savepoint))
- (_.setq @savepoint (_.cdr/1 @savepoint))))
-
-(def: (multi_pop! pops)
- (-> Nat (Expression Any))
- (_.setq @cursor (_.nthcdr/2 [(_.int (.int pops)) @cursor])))
-
-(template [<name> <flag> <prep>]
- [(def: (<name> @fail simple? idx next!)
- (-> _.Tag Bit Nat (Maybe (Expression Any)) (Expression Any))
- (.let [<failure_condition> (_.eq/2 [@variant @temp])]
- (_.let (list [@variant ..peek])
- (list& (_.setq @temp (|> idx <prep> .int _.int (//runtime.sum//get @variant <flag>)))
- (.if simple?
- (_.when <failure_condition>
- (_.go @fail))
- (_.if <failure_condition>
- (_.go @fail)
- (..push! @temp)))
- (.case next!
- (#.Some next!)
- (list next!)
-
- #.None
- (list))))))]
-
- [left_choice _.nil (<|)]
- [right_choice (_.string "") inc]
- )
-
-(def: (alternation @otherwise pre! post!)
- (-> _.Tag (Expression Any) (Expression Any) (Expression Any))
- (_.tagbody ($_ list\compose
- (list ..save!
- pre!
- @otherwise)
- ..restore!
- (list post!))))
-
-(def: (pattern_matching' expression archive)
- (Generator [Var/1 _.Tag _.Tag Path])
- (function (recur [$output @done @fail pathP])
- (.case pathP
- (^ (/////synthesis.path/then bodyS))
- (\ ///////phase.monad map
- (function (_ outputV)
- (_.progn (list (_.setq $output outputV)
- (_.go @done))))
- (expression archive bodyS))
-
- #/////synthesis.Pop
- (///////phase\wrap ..pop!)
-
- (#/////synthesis.Bind register)
- (///////phase\wrap (_.setq (..register register) ..peek))
-
- (#/////synthesis.Bit_Fork when thenP elseP)
- (do {! ///////phase.monad}
- [then! (recur [$output @done @fail thenP])
- else! (.case elseP
- (#.Some elseP)
- (recur [$output @done @fail elseP])
-
- #.None
- (wrap (_.go @fail)))]
- (wrap (.if when
- (_.if ..peek
- then!
- else!)
- (_.if ..peek
- else!
- then!))))
-
- (^template [<tag> <format> <=>]
- [(<tag> cons)
- (do {! ///////phase.monad}
- [clauses (monad.map ! (function (_ [match then])
- (do !
- [then! (recur [$output @done @fail then])]
- (wrap [(<=> [(|> match <format>)
- ..peek])
- then!])))
- (#.Cons cons))]
- (wrap (list\fold (function (_ [when then] else)
- (_.if when then else))
- (_.go @fail)
- clauses)))])
- ([#/////synthesis.I64_Fork //primitive.i64 _.=/2]
- [#/////synthesis.F64_Fork //primitive.f64 _.=/2]
- [#/////synthesis.Text_Fork //primitive.text _.string=/2])
-
- (^template [<complex> <simple> <choice>]
- [(^ (<complex> idx))
- (///////phase\wrap (<choice> @fail false idx #.None))
-
- (^ (<simple> idx nextP))
- (|> nextP
- [$output @done @fail] recur
- (\ ///////phase.monad map (|>> #.Some (<choice> @fail true idx))))])
- ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice]
- [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice])
-
- (^ (/////synthesis.member/left 0))
- (///////phase\wrap (..push! (_.elt/2 [..peek (_.int +0)])))
-
- (^template [<pm> <getter>]
- [(^ (<pm> lefts))
- (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))])
- ([/////synthesis.member/left //runtime.tuple//left]
- [/////synthesis.member/right //runtime.tuple//right])
-
- (^ (/////synthesis.!multi_pop nextP))
- (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)]
- (do ///////phase.monad
- [next! (recur [$output @done @fail nextP'])]
- (///////phase\wrap (_.progn (list (..multi_pop! (n.+ 2 extra_pops))
- next!)))))
-
- (^ (/////synthesis.path/alt preP postP))
- (do {! ///////phase.monad}
- [@otherwise (\ ! map (|>> %.nat (format "lux_case_otherwise") _.tag) /////generation.next)
- pre! (recur [$output @done @otherwise preP])
- post! (recur [$output @done @fail postP])]
- (wrap (..alternation @otherwise pre! post!)))
-
- (^ (/////synthesis.path/seq preP postP))
- (do ///////phase.monad
- [pre! (recur [$output @done @fail preP])
- post! (recur [$output @done @fail postP])]
- (wrap (_.progn (list pre! post!)))))))
-
-(def: (pattern_matching $output expression archive pathP)
- (-> Var/1 (Generator Path))
- (do {! ///////phase.monad}
- [@done (\ ! map (|>> %.nat (format "lux_case_done") _.tag) /////generation.next)
- @fail (\ ! map (|>> %.nat (format "lux_case_fail") _.tag) /////generation.next)
- pattern_matching! (pattern_matching' expression archive [$output @done @fail pathP])]
- (wrap (_.tagbody
- (list pattern_matching!
- @fail
- (_.error/1 (_.string ////synthesis/case.pattern_matching_error))
- @done)))))
-
-(def: #export (case expression archive [valueS pathP])
- (Generator [Synthesis Path])
- (do {! ///////phase.monad}
- [initG (expression archive valueS)
- $output (\ ! map (|>> %.nat (format "lux_case_output") _.var) /////generation.next)
- pattern_matching! (pattern_matching $output expression archive pathP)
- #let [storage (|> pathP
- ////synthesis/case.storage
- (get@ #////synthesis/case.bindings)
- set.to_list
- (list\map (function (_ register)
- [(..register register)
- _.nil])))]]
- (wrap (_.let (list& [@cursor (_.list/* (list initG))]
- [@savepoint (_.list/* (list))]
- [@temp _.nil]
- [$output _.nil]
- storage)
- (list pattern_matching!
- $output)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux
deleted file mode 100644
index 3bc0a0887..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux
+++ /dev/null
@@ -1,13 +0,0 @@
-(.module:
- [lux #*
- [data
- [collection
- ["." dictionary]]]]
- [//
- [runtime (#+ Bundle)]]
- [/
- ["." common]])
-
-(def: #export bundle
- Bundle
- common.bundle)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux
deleted file mode 100644
index 574995de9..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux
+++ /dev/null
@@ -1,136 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]]
- [data
- ["." product]
- [number
- ["f" frac]]
- [collection
- ["." dictionary]]]
- [target
- ["_" common-lisp (#+ Expression)]]]
- ["." /// #_
- ["#." runtime (#+ Operation Phase Handler Bundle)]
- ["#." primitive]
- [//
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- [//
- [extension
- ["." bundle]]]]])
-
-(def: lux-procs
- Bundle
- (|> bundle.empty
- (bundle.install "is" (binary (product.uncurry _.eq)))
- (bundle.install "try" (unary ///runtime.lux//try))))
-
-(def: (i64//left-shift [paramG subjectG])
- (Binary (Expression Any))
- (_.ash (_.rem (_.int +64) paramG) subjectG))
-
-(def: (i64//arithmetic-right-shift [paramG subjectG])
- (Binary (Expression Any))
- (_.ash (|> paramG (_.rem (_.int +64)) (_.* (_.int -1)))
- subjectG))
-
-(def: (i64//logic-right-shift [paramG subjectG])
- (Binary (Expression Any))
- (///runtime.i64//logic-right-shift (_.rem (_.int +64) paramG) subjectG))
-
-(def: i64-procs
- Bundle
- (<| (bundle.prefix "i64")
- (|> bundle.empty
- (bundle.install "and" (binary (product.uncurry _.logand)))
- (bundle.install "or" (binary (product.uncurry _.logior)))
- (bundle.install "xor" (binary (product.uncurry _.logxor)))
- (bundle.install "left-shift" (binary i64//left-shift))
- (bundle.install "logical-right-shift" (binary i64//logic-right-shift))
- (bundle.install "arithmetic-right-shift" (binary i64//arithmetic-right-shift))
- (bundle.install "=" (binary (product.uncurry _.=)))
- (bundle.install "<" (binary (product.uncurry _.<)))
- (bundle.install "+" (binary (product.uncurry _.+)))
- (bundle.install "-" (binary (product.uncurry _.-)))
- (bundle.install "*" (binary (product.uncurry _.*)))
- (bundle.install "/" (binary (product.uncurry _.floor)))
- (bundle.install "%" (binary (product.uncurry _.rem)))
- (bundle.install "f64" (unary (function (_ value)
- (_.coerce/2 [value (_.symbol "double-float")]))))
- (bundle.install "char" (unary (|>> _.code-char/1 _.string/1)))
- )))
-
-(def: f64-procs
- Bundle
- (<| (bundle.prefix "f64")
- (|> bundle.empty
- (bundle.install "+" (binary (product.uncurry _.+)))
- (bundle.install "-" (binary (product.uncurry _.-)))
- (bundle.install "*" (binary (product.uncurry _.*)))
- (bundle.install "/" (binary (product.uncurry _./)))
- (bundle.install "%" (binary (product.uncurry _.mod)))
- (bundle.install "=" (binary (product.uncurry _.=)))
- (bundle.install "<" (binary (product.uncurry _.<)))
- (bundle.install "i64" (unary _.floor/1))
- (bundle.install "encode" (unary _.write-to-string/1))
- (bundle.install "decode" (unary (let [@temp (_.var "temp")]
- (function (_ input)
- (_.let (list [@temp (_.read-from-string/1 input)])
- (_.if (_.equal (_.symbol "DOUBLE-FLOAT")
- (_.type-of/1 @temp))
- (///runtime.some @temp)
- ///runtime.none)))))))))
-
-(def: (text//< [paramG subjectG])
- (Binary (Expression Any))
- (|> (_.string< paramG subjectG)
- _.null/1
- _.not/1))
-
-(def: (text//clip [paramO extraO subjectO])
- (Trinary (Expression Any))
- (///runtime.text//clip subjectO paramO extraO))
-
-(def: (text//index [startO partO textO])
- (Trinary (Expression Any))
- (///runtime.text//index textO partO startO))
-
-(def: text-procs
- Bundle
- (<| (bundle.prefix "text")
- (|> bundle.empty
- (bundle.install "=" (binary (product.uncurry _.string=)))
- (bundle.install "<" (binary text//<))
- (bundle.install "concat" (binary _.concatenate/2|string))
- (bundle.install "index" (trinary text//index))
- (bundle.install "size" (unary _.length/1))
- (bundle.install "char" (binary (|>> _.char/2 _.char-int/1)))
- (bundle.install "clip" (trinary text//clip))
- )))
-
-(def: (void code)
- (-> (Expression Any) (Expression Any))
- ($_ _.progn
- code
- ///runtime.unit))
-
-(def: io-procs
- Bundle
- (<| (bundle.prefix "io")
- (|> bundle.empty
- (bundle.install "log" (unary (|>> _.print/1 ..void)))
- (bundle.install "error" (unary _.error/1))
- )))
-
-(def: #export bundle
- Bundle
- (<| (bundle.prefix "lux")
- (|> lux-procs
- (dictionary.merge i64-procs)
- (dictionary.merge f64-procs)
- (dictionary.merge text-procs)
- (dictionary.merge io-procs)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux
deleted file mode 100644
index 2a5896e92..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux
+++ /dev/null
@@ -1,102 +0,0 @@
-(.module:
- [lux (#- function)
- [abstract
- ["." monad (#+ do)]]
- [control
- pipe]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [target
- ["_" common_lisp (#+ Expression Var/1)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." reference]
- ["#." case]
- ["/#" // #_
- ["#." reference]
- ["//#" /// #_
- [analysis (#+ Variant Tuple Abstraction Application Analysis)]
- [synthesis (#+ Synthesis)]
- ["#." generation (#+ Context)]
- ["//#" /// #_
- [arity (#+ Arity)]
- ["#." phase ("#\." monad)]
- [reference
- [variable (#+ Register Variable)]]]]]])
-
-(def: #export (apply expression archive [functionS argsS+])
- (Generator (Application Synthesis))
- (do {! ///////phase.monad}
- [functionG (expression archive functionS)
- argsG+ (monad.map ! (expression archive) argsS+)]
- (wrap (_.funcall/+ [functionG argsG+]))))
-
-(def: capture
- (-> Register Var/1)
- (|>> (///reference.foreign //reference.system) :assume))
-
-(def: (with_closure inits function_definition)
- (-> (List (Expression Any)) (Expression Any) (Operation (Expression Any)))
- (case inits
- #.Nil
- (\ ///////phase.monad wrap function_definition)
-
- _
- (do {! ///////phase.monad}
- [@closure (\ ! map _.var (/////generation.gensym "closure"))]
- (wrap (_.labels (list [@closure [(|> (list.enumeration inits)
- (list\map (|>> product.left ..capture))
- _.args)
- function_definition]])
- (_.funcall/+ [(_.function/1 @closure) inits]))))))
-
-(def: input
- (|>> inc //case.register))
-
-(def: #export (function expression archive [environment arity bodyS])
- (Generator (Abstraction Synthesis))
- (do {! ///////phase.monad}
- [@scope (\ ! map (|>> %.nat (format "function_scope") _.tag) /////generation.next)
- @output (\ ! map (|>> %.nat (format "loop_output") _.var) /////generation.next)
- [function_name bodyG] (/////generation.with_new_context archive
- (/////generation.with_anchor [@scope 1]
- (expression archive bodyS)))
- closureG+ (monad.map ! (expression archive) environment)
- #let [@curried (_.var "curried")
- @missing (_.var "missing")
- arityG (|> arity .int _.int)
- @num_args (_.var "num_args")
- @self (_.var (///reference.artifact function_name))
- initialize_self! [(//case.register 0) (_.function/1 @self)]
- initialize! [(|> (list.indices arity)
- (list\map ..input)
- _.args)
- @curried]]]
- (with_closure closureG+
- (_.labels (list [@self [(_.args& (list) @curried)
- (_.let (list [@num_args (_.length/1 @curried)])
- (list (_.cond (list [(_.=/2 [arityG @num_args])
- (_.let (list [@output _.nil]
- initialize_self!)
- (list (_.destructuring-bind initialize!
- (list (_.tagbody
- (list @scope
- (_.setq @output bodyG)))
- @output))))]
-
- [(_.>/2 [arityG @num_args])
- (let [arity_inputs (_.subseq/3 [@curried (_.int +0) arityG])
- extra_inputs (_.subseq/3 [@curried arityG @num_args])]
- (_.apply/2 [(_.apply/2 [(_.function/1 @self)
- arity_inputs])
- extra_inputs]))])
- ## (|> @num_args (_.< arityG))
- (_.lambda (_.args& (list) @missing)
- (_.apply/2 [(_.function/1 @self)
- (_.append/2 [@curried @missing])])))))]])
- (_.function/1 @self)))
- ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux
deleted file mode 100644
index 7256e926d..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux
+++ /dev/null
@@ -1,69 +0,0 @@
-(.module:
- [lux (#- Scope)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]]]
- [math
- [number
- ["n" nat]]]
- [target
- ["_" common_lisp (#+ Expression)]]]
- ["." // #_
- [runtime (#+ Operation Phase Generator)]
- ["#." case]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- [synthesis
- ["." case]]
- ["/#" // #_
- ["."synthesis (#+ Scope Synthesis)]
- ["#." generation]
- ["//#" /// #_
- ["#." phase]
- [meta
- [archive (#+ Archive)]]
- [reference
- [variable (#+ Register)]]]]]]])
-
-(def: #export (scope expression archive [start initsS+ bodyS])
- (Generator (Scope Synthesis))
- (case initsS+
- ## function/false/non-independent loop
- #.Nil
- (expression archive bodyS)
-
- ## true loop
- _
- (do {! ///////phase.monad}
- [@scope (\ ! map (|>> %.nat (format "loop_scope") _.tag) /////generation.next)
- @output (\ ! map (|>> %.nat (format "loop_output") _.var) /////generation.next)
- initsG+ (monad.map ! (expression archive) initsS+)
- bodyG (/////generation.with_anchor [@scope start]
- (expression archive bodyS))]
- (wrap (_.let (|> initsG+
- list.enumeration
- (list\map (function (_ [idx init])
- [(|> idx (n.+ start) //case.register)
- init]))
- (list& [@output _.nil]))
- (list (_.tagbody (list @scope
- (_.setq @output bodyG)))
- @output))))))
-
-(def: #export (recur expression archive argsS+)
- (Generator (List Synthesis))
- (do {! ///////phase.monad}
- [[tag offset] /////generation.anchor
- argsO+ (monad.map ! (expression archive) argsS+)
- #let [bindings (|> argsO+
- list.enumeration
- (list\map (|>> product.left (n.+ offset) //case.register))
- _.args)]]
- (wrap (_.progn (list (_.multiple-value-setq bindings (_.values/* argsO+))
- (_.go tag))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux
deleted file mode 100644
index 9357156f2..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux
+++ /dev/null
@@ -1,20 +0,0 @@
-(.module:
- [lux (#- i64)
- [target
- ["_" common_lisp (#+ Expression)]]])
-
-(def: #export bit
- (-> Bit (Expression Any))
- _.bool)
-
-(def: #export i64
- (-> (I64 Any) (Expression Any))
- (|>> .int _.int))
-
-(def: #export f64
- (-> Frac (Expression Any))
- _.double)
-
-(def: #export text
- (-> Text (Expression Any))
- _.string)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux
deleted file mode 100644
index 2e4488b00..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux
+++ /dev/null
@@ -1,12 +0,0 @@
-(.module:
- [lux #*
- [target
- ["_" common_lisp (#+ Expression)]]]
- [///
- [reference (#+ System)]])
-
-(implementation: #export system
- (System (Expression Any))
-
- (def: constant _.var)
- (def: variable _.var))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux
deleted file mode 100644
index fd7ffc48b..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux
+++ /dev/null
@@ -1,292 +0,0 @@
-(.module:
- [lux (#- Location inc)
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<.>" code]]]
- [data
- ["." product]
- ["." text ("#\." hash)
- ["%" format (#+ format)]
- ["." encoding]]
- [collection
- ["." list ("#\." functor monoid)]
- ["." row]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number (#+ hex)
- ["." i64]]]
- ["@" target
- ["_" common_lisp (#+ Expression Computation Literal)]]]
- ["." /// #_
- ["#." reference]
- ["//#" /// #_
- [analysis (#+ Variant)]
- ["#." synthesis (#+ Synthesis)]
- ["#." generation]
- ["//#" ///
- ["#." phase]
- [reference
- [variable (#+ Register)]]
- [meta
- [archive (#+ Output Archive)
- ["." artifact (#+ Registry)]]]]]])
-
-(def: module_id
- 0)
-
-(template [<name> <base>]
- [(type: #export <name>
- (<base> [_.Tag Register] (Expression Any) (Expression Any)))]
-
- [Operation /////generation.Operation]
- [Phase /////generation.Phase]
- [Handler /////generation.Handler]
- [Bundle /////generation.Bundle]
- )
-
-(type: #export (Generator i)
- (-> Phase Archive i (Operation (Expression Any))))
-
-(def: #export unit
- (_.string /////synthesis.unit))
-
-(def: (flag value)
- (-> Bit Literal)
- (if value
- (_.string "")
- _.nil))
-
-(def: (variant' tag last? value)
- (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any))
- (_.list/* (list tag last? value)))
-
-(def: #export (variant [lefts right? value])
- (-> (Variant (Expression Any)) (Computation Any))
- (variant' (_.int (.int lefts)) (flag right?) value))
-
-(def: #export none
- (Computation Any)
- (|> ..unit [0 #0] ..variant))
-
-(def: #export some
- (-> (Expression Any) (Computation Any))
- (|>> [1 #1] ..variant))
-
-(def: #export left
- (-> (Expression Any) (Computation Any))
- (|>> [0 #0] ..variant))
-
-(def: #export right
- (-> (Expression Any) (Computation Any))
- (|>> [1 #1] ..variant))
-
-(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
- body)
- (do {! meta.monad}
- [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
- (wrap (list (` (let [(~+ (|> vars
- (list.zip/2 ids)
- (list\map (function (_ [id var])
- (list (code.local_identifier var)
- (` (_.var (~ (code.text (format "v" (%.nat id)))))))))
- list.concat))]
- (~ body)))))))
-
-(syntax: (runtime: {declaration (<>.or <code>.local_identifier
- (<code>.form (<>.and <code>.local_identifier
- (<>.some <code>.local_identifier))))}
- code)
- (do meta.monad
- [runtime_id meta.count]
- (macro.with_gensyms [g!_]
- (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id]))
- runtime_name (` (_.var (~ (code.text (%.code runtime)))))]
- (case declaration
- (#.Left name)
- (let [g!name (code.local_identifier name)
- code_nameC (code.local_identifier (format "@" name))]
- (wrap (list (` (def: #export (~ g!name)
- _.Var/1
- (~ runtime_name)))
-
- (` (def: (~ code_nameC)
- (_.Expression Any)
- (_.defparameter (~ runtime_name) (~ code)))))))
-
- (#.Right [name inputs])
- (let [g!name (code.local_identifier name)
- code_nameC (code.local_identifier (format "@" name))
-
- inputsC (list\map code.local_identifier inputs)
- inputs_typesC (list\map (function.constant (` (_.Expression Any)))
- inputs)]
- (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
- (-> (~+ inputs_typesC) (_.Computation Any))
- (_.call/* (~ runtime_name) (list (~+ inputsC)))))
-
- (` (def: (~ code_nameC)
- (_.Expression Any)
- (..with_vars [(~+ inputsC)]
- (_.defun (~ runtime_name) (_.args (list (~+ inputsC)))
- (~ code)))))))))))))
-
-(runtime: (lux//try op)
- (with_vars [error]
- (_.handler-case
- (list [(_.bool true) error
- (..left (_.format/3 [_.nil (_.string "~A") error]))])
- (..right (_.funcall/+ [op (list ..unit)])))))
-
-## TODO: Use Common Lisp's swiss-army loop macro instead.
-(runtime: (lux//program_args inputs)
- (with_vars [loop input tail]
- (_.labels (list [loop [(_.args (list input tail))
- (_.if (_.null/1 input)
- tail
- (_.funcall/+ [(_.function/1 loop)
- (list (_.cdr/1 input)
- (..some (_.vector/* (list (_.car/1 input) tail))))]))]])
- (_.funcall/+ [(_.function/1 loop)
- (list (_.reverse/1 inputs)
- ..none)]))))
-
-(def: runtime//lux
- (List (Expression Any))
- (list @lux//try
- @lux//program_args))
-
-(def: last_index
- (|>> _.length/1 [(_.int +1)] _.-/2))
-
-(with_expansions [<recur> (as_is ($_ _.then
- (_.; (_.set lefts (_.-/2 [last_index_right lefts])))
- (_.; (_.set tuple (_.nth last_index_right tuple)))))]
- (template: (!recur <side>)
- (<side> (_.-/2 [last_index_right lefts])
- (_.elt/2 [tuple last_index_right])))
-
- (runtime: (tuple//left lefts tuple)
- (with_vars [last_index_right]
- (_.let (list [last_index_right (..last_index tuple)])
- (list (_.if (_.>/2 [lefts last_index_right])
- ## No need for recursion
- (_.elt/2 [tuple lefts])
- ## Needs recursion
- (!recur tuple//left))))))
-
- (runtime: (tuple//right lefts tuple)
- (with_vars [last_index_right right_index]
- (_.let (list [last_index_right (..last_index tuple)]
- [right_index (_.+/2 [(_.int +1) lefts])])
- (list (_.cond (list [(_.=/2 [last_index_right right_index])
- (_.elt/2 [tuple right_index])]
- [(_.>/2 [last_index_right right_index])
- ## Needs recursion.
- (!recur tuple//right)])
- (_.subseq/3 [tuple right_index (_.length/1 tuple)])))))))
-
-## TODO: Find a way to extract parts of the sum without "nth", which
-## does a linear search, and is thus expensive.
-(runtime: (sum//get sum wantsLast wantedTag)
- (with_vars [sum_tag sum_flag]
- (let [no_match! (_.return sum)
- sum_value (_.nth/2 [(_.int +2) sum])
- test_recursion! (_.if sum_flag
- ## Must iterate.
- (_.progn (list (_.setq wantedTag (_.-/2 [sum_tag wantedTag]))
- (_.setq sum sum_value)))
- no_match!)]
- (_.while (_.bool true)
- (_.let (list [sum_tag (_.nth/2 [(_.int +0) sum])]
- [sum_flag (_.nth/2 [(_.int +1) sum])])
- (list (_.cond (list [(_.=/2 [sum_tag wantedTag])
- (_.if (_.equal/2 [wantsLast sum_flag])
- (_.return sum_value)
- test_recursion!)]
-
- [(_.>/2 [sum_tag wantedTag])
- test_recursion!]
-
- [(_.and (_.</2 [sum_tag wantedTag])
- wantsLast)
- (_.return (variant' (_.-/2 [wantedTag sum_tag]) sum_flag sum_value))])
-
- no_match!)))))))
-
-(def: runtime//adt
- (List (Expression Any))
- (list @tuple//left
- @tuple//right
- @sum//get))
-
-(runtime: (i64//right_shift shift input)
- (_.if (_.=/2 [(_.int +0) shift])
- input
- (let [anti_shift (_.-/2 [shift (_.int +64)])
- mask (|> (_.int +1)
- [anti_shift] _.ash/2
- [(_.int +1)] _.-/2)]
- (|> input
- [(_.*/2 [(_.int -1) shift])] _.ash/2
- [mask] _.logand/2))))
-
-(def: runtime//i64
- (List (Expression Any))
- (list @i64//right_shift))
-
-(runtime: (text//clip offset length text)
- (_.subseq/3 [text offset (_.+/2 [offset length])]))
-
-(runtime: (text//index offset sub text)
- (with_vars [index]
- (_.let (list [index (_.search/3 [sub text offset])])
- (list (_.if index
- (..some index)
- ..none)))))
-
-(def: runtime//text
- (List (Expression Any))
- (list @text//index
- @text//clip))
-
-(runtime: (io//exit code)
- (_.progn (list (_.conditional+ (list "sbcl")
- (_.call/* (_.var "sb-ext:quit") (list code)))
- (_.conditional+ (list "clisp")
- (_.call/* (_.var "ext:exit") (list code)))
- (_.conditional+ (list "ccl")
- (_.call/* (_.var "ccl:quit") (list code)))
- (_.conditional+ (list "allegro")
- (_.call/* (_.var "excl:exit") (list code)))
- (_.call/* (_.var "cl-user::quit") (list code)))))
-
-(def: runtime//io
- (List (Expression Any))
- (list @io//exit))
-
-(def: runtime
- (_.progn ($_ list\compose
- runtime//adt
- runtime//lux
- runtime//i64
- runtime//text
- runtime//io)))
-
-(def: #export generate
- (Operation [Registry Output])
- (do ///////phase.monad
- [_ (/////generation.execute! ..runtime)
- _ (/////generation.save! (%.nat ..module_id) ..runtime)]
- (wrap [(|> artifact.empty
- artifact.resource
- product.right)
- (row.row [(%.nat ..module_id)
- (|> ..runtime
- _.code
- (\ encoding.utf8 encode))])])))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux
deleted file mode 100644
index 566fc148e..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux
+++ /dev/null
@@ -1,36 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [target
- ["_" common_lisp (#+ Expression)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." primitive]
- ["///#" //// #_
- [analysis (#+ Variant Tuple)]
- ["#." synthesis (#+ Synthesis)]
- ["//#" /// #_
- ["#." phase ("#\." monad)]]]])
-
-(def: #export (tuple expression archive elemsS+)
- (Generator (Tuple Synthesis))
- (case elemsS+
- #.Nil
- (///////phase\wrap (//primitive.text /////synthesis.unit))
-
- (#.Cons singletonS #.Nil)
- (expression archive singletonS)
-
- _
- (|> elemsS+
- (monad.map ///////phase.monad (expression archive))
- (///////phase\map _.vector/*))))
-
-(def: #export (variant expression archive [lefts right? valueS])
- (Generator (Variant Synthesis))
- (let [tag (if right?
- (inc lefts)
- lefts)]
- (///////phase\map (|>> [tag right?] //runtime.variant)
- (expression archive valueS))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/extension.lux
deleted file mode 100644
index 051b6357b..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/extension.lux
+++ /dev/null
@@ -1,65 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- [parser
- ["s" code]]]
- [data
- [collection
- ["." list ("#\." functor)]]]
- ["." meta]
- ["." macro (#+ with_gensyms)
- ["." code]
- [syntax (#+ syntax:)]]]
- ["." /// #_
- ["#." extension]
- [//
- [synthesis (#+ Synthesis)]
- ["." generation]
- [///
- ["#" phase]]]])
-
-(syntax: (Vector {size s.nat} elemT)
- (wrap (list (` [(~+ (list.repeat size elemT))]))))
-
-(type: #export (Nullary of) (-> (Vector 0 of) of))
-(type: #export (Unary of) (-> (Vector 1 of) of))
-(type: #export (Binary of) (-> (Vector 2 of) of))
-(type: #export (Trinary of) (-> (Vector 3 of) of))
-(type: #export (Variadic of) (-> (List of) of))
-
-(syntax: (arity: {arity s.nat} {name s.local_identifier} type)
- (with_gensyms [g!_ g!extension g!name g!phase g!archive g!inputs g!of g!anchor g!expression g!directive]
- (do {! meta.monad}
- [g!input+ (monad.seq ! (list.repeat arity (macro.gensym "input")))]
- (wrap (list (` (def: #export ((~ (code.local_identifier name)) (~ g!extension))
- (All [(~ g!anchor) (~ g!expression) (~ g!directive)]
- (-> ((~ type) (~ g!expression))
- (generation.Handler (~ g!anchor) (~ g!expression) (~ g!directive))))
- (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!archive) (~ g!inputs))
- (case (~ g!inputs)
- (^ (list (~+ g!input+)))
- (do ///.monad
- [(~+ (|> g!input+
- (list\map (function (_ g!input)
- (list g!input (` ((~ g!phase) (~ g!archive) (~ g!input))))))
- list.concat))]
- ((~' wrap) ((~ g!extension) [(~+ g!input+)])))
-
- (~' _)
- (///.throw ///extension.incorrect_arity [(~ g!name) 1 (list.size (~ g!inputs))]))))))))))
-
-(arity: 0 nullary ..Nullary)
-(arity: 1 unary ..Unary)
-(arity: 2 binary ..Binary)
-(arity: 3 trinary ..Trinary)
-
-(def: #export (variadic extension)
- (All [anchor expression directive]
- (-> (Variadic expression) (generation.Handler anchor expression directive)))
- (function (_ extension_name)
- (function (_ phase archive inputsS)
- (do {! ///.monad}
- [inputsI (monad.map ! (phase archive) inputsS)]
- (wrap (extension inputsI))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux
deleted file mode 100644
index ab89ff708..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux
+++ /dev/null
@@ -1,116 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." exception (#+ exception:)]]
- [target
- ["_" js]]]
- ["." / #_
- [runtime (#+ Phase Phase!)]
- ["#." primitive]
- ["#." structure]
- ["#." reference]
- ["#." case]
- ["#." loop]
- ["#." function]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- ["#." extension]
- ["/#" // #_
- [analysis (#+)]
- ["." synthesis]
- ["//#" /// #_
- ["#." phase ("#\." monad)]
- [reference (#+)
- [variable (#+)]]]]]]])
-
-(def: (statement expression archive synthesis)
- Phase!
- (case synthesis
- (^template [<tag>]
- [(^ (<tag> value))
- (//////phase\map _.return (expression archive synthesis))])
- ([synthesis.bit]
- [synthesis.i64]
- [synthesis.f64]
- [synthesis.text]
- [synthesis.variant]
- [synthesis.tuple]
- [#synthesis.Reference]
- [synthesis.branch/get]
- [synthesis.function/apply]
- [#synthesis.Extension])
-
- (^ (synthesis.branch/case case))
- (/case.case! statement expression archive case)
-
- (^ (synthesis.branch/let let))
- (/case.let! statement expression archive let)
-
- (^ (synthesis.branch/if if))
- (/case.if! statement expression archive if)
-
- (^ (synthesis.loop/scope scope))
- (/loop.scope! statement expression archive scope)
-
- (^ (synthesis.loop/recur updates))
- (/loop.recur! statement expression archive updates)
-
- (^ (synthesis.function/abstraction abstraction))
- (//////phase\map _.return (/function.function statement expression archive abstraction))
- ))
-
-(exception: #export cannot-recur-as-an-expression)
-
-(def: (expression archive synthesis)
- Phase
- (case synthesis
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (//////phase\wrap (<generator> value))])
- ([synthesis.bit /primitive.bit]
- [synthesis.i64 /primitive.i64]
- [synthesis.f64 /primitive.f64]
- [synthesis.text /primitive.text])
-
- (^ (synthesis.variant variantS))
- (/structure.variant expression archive variantS)
-
- (^ (synthesis.tuple members))
- (/structure.tuple expression archive members)
-
- (#synthesis.Reference value)
- (//reference.reference /reference.system archive value)
-
- (^ (synthesis.branch/case case))
- (/case.case ..statement expression archive case)
-
- (^ (synthesis.branch/let let))
- (/case.let expression archive let)
-
- (^ (synthesis.branch/if if))
- (/case.if expression archive if)
-
- (^ (synthesis.branch/get get))
- (/case.get expression archive get)
-
- (^ (synthesis.loop/scope scope))
- (/loop.scope ..statement expression archive scope)
-
- (^ (synthesis.loop/recur updates))
- (//////phase.throw ..cannot-recur-as-an-expression [])
-
- (^ (synthesis.function/abstraction abstraction))
- (/function.function ..statement expression archive abstraction)
-
- (^ (synthesis.function/apply application))
- (/function.apply expression archive application)
-
- (#synthesis.Extension extension)
- (///extension.apply archive expression extension)))
-
-(def: #export generate
- Phase
- ..expression)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux
deleted file mode 100644
index 50e3ba008..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux
+++ /dev/null
@@ -1,321 +0,0 @@
-(.module:
- [lux (#- case let if)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." maybe]
- ["." text]
- [collection
- ["." list ("#\." functor fold)]]]
- [math
- [number
- ["n" nat]]]
- [target
- ["_" js (#+ Expression Computation Var Statement)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Phase! Generator Generator!)]
- ["#." reference]
- ["#." primitive]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- ["#." synthesis #_
- ["#/." case]]
- ["/#" // #_
- ["#." synthesis (#+ Member Synthesis Path)]
- ["//#" /// #_
- [reference
- [variable (#+ Register)]]
- ["#." phase ("#\." monad)]
- [meta
- [archive (#+ Archive)]]]]]]])
-
-(def: #export register
- (-> Register Var)
- (|>> (///reference.local //reference.system) :assume))
-
-(def: #export (let expression archive [valueS register bodyS])
- (Generator [Synthesis Register Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)
- bodyO (expression archive bodyS)]
- ## TODO: Find some way to do 'let' without paying the price of the closure.
- (wrap (_.apply/* (_.closure (list (..register register))
- (_.return bodyO))
- (list valueO)))))
-
-(def: #export (let! statement expression archive [valueS register bodyS])
- (Generator! [Synthesis Register Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)
- bodyO (statement expression archive bodyS)]
- (wrap ($_ _.then
- (_.define (..register register) valueO)
- bodyO))))
-
-(def: #export (if expression archive [testS thenS elseS])
- (Generator [Synthesis Synthesis Synthesis])
- (do ///////phase.monad
- [testO (expression archive testS)
- thenO (expression archive thenS)
- elseO (expression archive elseS)]
- (wrap (_.? testO thenO elseO))))
-
-(def: #export (if! statement expression archive [testS thenS elseS])
- (Generator! [Synthesis Synthesis Synthesis])
- (do ///////phase.monad
- [testO (expression archive testS)
- thenO (statement expression archive thenS)
- elseO (statement expression archive elseS)]
- (wrap (_.if testO
- thenO
- elseO))))
-
-(def: #export (get expression archive [pathP valueS])
- (Generator [(List Member) Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)]
- (wrap (list\fold (function (_ side source)
- (.let [method (.case side
- (^template [<side> <accessor>]
- [(<side> lefts)
- (<accessor> (_.i32 (.int lefts)))])
- ([#.Left //runtime.tuple//left]
- [#.Right //runtime.tuple//right]))]
- (method source)))
- valueO
- (list.reverse pathP)))))
-
-(def: @savepoint (_.var "lux_pm_cursor_savepoint"))
-(def: @cursor (_.var "lux_pm_cursor"))
-(def: @temp (_.var "lux_pm_temp"))
-
-(def: (push_cursor! value)
- (-> Expression Statement)
- (_.statement (|> @cursor (_.do "push" (list value)))))
-
-(def: peek_and_pop_cursor
- Expression
- (|> @cursor (_.do "pop" (list))))
-
-(def: pop_cursor!
- Statement
- (_.statement ..peek_and_pop_cursor))
-
-(def: length
- (|>> (_.the "length")))
-
-(def: last_index
- (|>> ..length (_.- (_.i32 +1))))
-
-(def: peek_cursor
- Expression
- (|> @cursor (_.at (last_index @cursor))))
-
-(def: save_cursor!
- Statement
- (.let [cursor (|> @cursor (_.do "slice" (list)))]
- (_.statement (|> @savepoint (_.do "push" (list cursor))))))
-
-(def: restore_cursor!
- Statement
- (_.set @cursor (|> @savepoint (_.do "pop" (list)))))
-
-(def: fail_pm! _.break)
-
-(def: (multi_pop_cursor! pops)
- (-> Nat Statement)
- (.let [popsJS (_.i32 (.int pops))]
- (_.statement (|> @cursor (_.do "splice" (list (|> @cursor ..length (_.- popsJS))
- popsJS))))))
-
-(template [<name> <flag> <prep>]
- [(def: (<name> simple? idx)
- (-> Bit Nat Statement)
- ($_ _.then
- (_.set @temp (|> idx <prep> .int _.i32 (//runtime.sum//get ..peek_cursor <flag>)))
- (.if simple?
- (_.when (_.= _.null @temp)
- ..fail_pm!)
- (_.if (_.= _.null @temp)
- ..fail_pm!
- (push_cursor! @temp)))))]
-
- [left_choice _.null (<|)]
- [right_choice (_.string "") inc]
- )
-
-(def: (alternation pre! post!)
- (-> Statement Statement Statement)
- ($_ _.then
- (_.do_while (_.boolean false)
- ($_ _.then
- ..save_cursor!
- pre!))
- ($_ _.then
- ..restore_cursor!
- post!)))
-
-(def: (optimized_pattern_matching recur pathP)
- (-> (-> Path (Operation Statement))
- (-> Path (Operation (Maybe Statement))))
- (.case pathP
- (^template [<simple> <choice>]
- [(^ (<simple> idx nextP))
- (|> nextP
- recur
- (\ ///////phase.monad map (|>> (_.then (<choice> true idx)) #.Some)))])
- ([/////synthesis.simple_left_side ..left_choice]
- [/////synthesis.simple_right_side ..right_choice])
-
- (^ (/////synthesis.member/left 0))
- (///////phase\wrap (#.Some (push_cursor! (_.at (_.i32 +0) ..peek_cursor))))
-
- ## Extra optimization
- (^ (/////synthesis.path/seq
- (/////synthesis.member/left 0)
- (/////synthesis.!bind_top register thenP)))
- (do ///////phase.monad
- [then! (recur thenP)]
- (wrap (#.Some ($_ _.then
- (_.define (..register register) (_.at (_.i32 +0) ..peek_cursor))
- then!))))
-
- ## Extra optimization
- (^template [<pm> <getter>]
- [(^ (/////synthesis.path/seq
- (<pm> lefts)
- (/////synthesis.!bind_top register thenP)))
- (do ///////phase.monad
- [then! (recur thenP)]
- (wrap (#.Some ($_ _.then
- (_.define (..register register) (<getter> (_.i32 (.int lefts)) ..peek_cursor))
- then!))))])
- ([/////synthesis.member/left //runtime.tuple//left]
- [/////synthesis.member/right //runtime.tuple//right])
-
- (^ (/////synthesis.!bind_top register thenP))
- (do ///////phase.monad
- [then! (recur thenP)]
- (wrap (#.Some ($_ _.then
- (_.define (..register register) ..peek_and_pop_cursor)
- then!))))
-
- (^ (/////synthesis.!multi_pop nextP))
- (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)]
- (do ///////phase.monad
- [next! (recur nextP')]
- (wrap (#.Some ($_ _.then
- (multi_pop_cursor! (n.+ 2 extra_pops))
- next!)))))
-
- _
- (///////phase\wrap #.None)))
-
-(def: (pattern_matching' statement expression archive)
- (-> Phase! Phase Archive
- (-> Path (Operation Statement)))
- (function (recur pathP)
- (do ///////phase.monad
- [outcome (optimized_pattern_matching recur pathP)]
- (.case outcome
- (#.Some outcome)
- (wrap outcome)
-
- #.None
- (.case pathP
- (#/////synthesis.Then bodyS)
- (statement expression archive bodyS)
-
- #/////synthesis.Pop
- (///////phase\wrap pop_cursor!)
-
- (#/////synthesis.Bind register)
- (///////phase\wrap (_.define (..register register) ..peek_cursor))
-
- (#/////synthesis.Bit_Fork when thenP elseP)
- (do {! ///////phase.monad}
- [then! (recur thenP)
- else! (.case elseP
- (#.Some elseP)
- (recur elseP)
-
- #.None
- (wrap ..fail_pm!))]
- (wrap (.if when
- (_.if ..peek_cursor
- then!
- else!)
- (_.if ..peek_cursor
- else!
- then!))))
-
- (#/////synthesis.I64_Fork cons)
- (do {! ///////phase.monad}
- [clauses (monad.map ! (function (_ [match then])
- (do !
- [then! (recur then)]
- (wrap [(//runtime.i64//= (//primitive.i64 (.int match))
- ..peek_cursor)
- then!])))
- (#.Cons cons))]
- (wrap (_.cond clauses ..fail_pm!)))
-
- (^template [<tag> <format>]
- [(<tag> cons)
- (do {! ///////phase.monad}
- [cases (monad.map ! (function (_ [match then])
- (\ ! map (|>> [(list (<format> match))]) (recur then)))
- (#.Cons cons))]
- (wrap (_.switch ..peek_cursor
- cases
- (#.Some ..fail_pm!))))])
- ([#/////synthesis.F64_Fork //primitive.f64]
- [#/////synthesis.Text_Fork //primitive.text])
-
- (^template [<complex> <choice>]
- [(^ (<complex> idx))
- (///////phase\wrap (<choice> false idx))])
- ([/////synthesis.side/left ..left_choice]
- [/////synthesis.side/right ..right_choice])
-
- (^template [<pm> <getter>]
- [(^ (<pm> lefts))
- (///////phase\wrap (push_cursor! (<getter> (_.i32 (.int lefts)) ..peek_cursor)))])
- ([/////synthesis.member/left //runtime.tuple//left]
- [/////synthesis.member/right //runtime.tuple//right])
-
- (^template [<tag> <combinator>]
- [(^ (<tag> leftP rightP))
- (do ///////phase.monad
- [left! (recur leftP)
- right! (recur rightP)]
- (wrap (<combinator> left! right!)))])
- ([/////synthesis.path/seq _.then]
- [/////synthesis.path/alt ..alternation]))))))
-
-(def: (pattern_matching statement expression archive pathP)
- (-> Phase! Phase Archive Path (Operation Statement))
- (do ///////phase.monad
- [pattern_matching! (pattern_matching' statement expression archive pathP)]
- (wrap ($_ _.then
- (_.do_while (_.boolean false)
- pattern_matching!)
- (_.throw (_.string ////synthesis/case.pattern_matching_error))))))
-
-(def: #export (case! statement expression archive [valueS pathP])
- (Generator! [Synthesis Path])
- (do ///////phase.monad
- [stack_init (expression archive valueS)
- pattern_matching! (pattern_matching statement expression archive pathP)]
- (wrap ($_ _.then
- (_.declare @temp)
- (_.define @cursor (_.array (list stack_init)))
- (_.define @savepoint (_.array (list)))
- pattern_matching!))))
-
-(def: #export (case statement expression archive [valueS pathP])
- (-> Phase! (Generator [Synthesis Path]))
- (do ///////phase.monad
- [pattern_matching! (..case! statement expression archive [valueS pathP])]
- (wrap (_.apply/* (_.closure (list) pattern_matching!) (list)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux
deleted file mode 100644
index 660ac4991..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux
+++ /dev/null
@@ -1,122 +0,0 @@
-(.module:
- [lux (#- function)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [target
- ["_" js (#+ Expression Computation Var Statement)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Phase! Generator)]
- ["#." reference]
- ["#." case]
- ["/#" // #_
- ["#." reference]
- ["//#" /// #_
- [analysis (#+ Variant Tuple Abstraction Application Analysis)]
- [synthesis (#+ Synthesis)]
- ["#." generation (#+ Context)]
- ["//#" /// #_
- [arity (#+ Arity)]
- ["#." phase ("#\." monad)]
- [reference
- [variable (#+ Register Variable)]]]]]])
-
-(def: #export (apply expression archive [functionS argsS+])
- (Generator (Application Synthesis))
- (do {! ///////phase.monad}
- [functionO (expression archive functionS)
- argsO+ (monad.map ! (expression archive) argsS+)]
- (wrap (_.apply/* functionO argsO+))))
-
-(def: capture
- (-> Register Var)
- (|>> (///reference.foreign //reference.system) :assume))
-
-(def: (with_closure @self inits body!)
- (-> Var (List Expression) Statement [Statement Expression])
- (case inits
- #.Nil
- [(_.function! @self (list) body!)
- @self]
-
- _
- [(_.function! @self
- (|> (list.enumeration inits)
- (list\map (|>> product.left ..capture)))
- (_.return (_.function @self (list) body!)))
- (_.apply/* @self inits)]))
-
-(def: @curried
- (_.var "curried"))
-
-(def: input
- (|>> inc //case.register))
-
-(def: @@arguments
- (_.var "arguments"))
-
-(def: (@scope function_name)
- (-> Context Text)
- (format (///reference.artifact function_name) "_scope"))
-
-(def: #export (function statement expression archive [environment arity bodyS])
- (-> Phase! (Generator (Abstraction Synthesis)))
- (do {! ///////phase.monad}
- [[function_name body!] (/////generation.with_new_context archive
- (do !
- [scope (\ ! map ..@scope
- (/////generation.context archive))]
- (/////generation.with_anchor [1 scope]
- (statement expression archive bodyS))))
- #let [arityO (|> arity .int _.i32)
- @num_args (_.var "num_args")
- @scope (..@scope function_name)
- @self (_.var (///reference.artifact function_name))
- apply_poly (.function (_ args func)
- (|> func (_.do "apply" (list _.null args))))
- initialize_self! (_.define (//case.register 0) @self)
- initialize! (list\fold (.function (_ post pre!)
- ($_ _.then
- pre!
- (_.define (..input post) (_.at (_.i32 (.int post)) @@arguments))))
- initialize_self!
- (list.indices arity))]
- environment (monad.map ! (expression archive) environment)
- #let [[definition instantiation] (with_closure @self environment
- ($_ _.then
- (_.define @num_args (_.the "length" @@arguments))
- (_.cond (list [(|> @num_args (_.= arityO))
- ($_ _.then
- initialize!
- (_.with_label (_.label @scope)
- (_.do_while (_.boolean true)
- body!)))]
- [(|> @num_args (_.> arityO))
- (let [arity_inputs (|> (_.array (list))
- (_.the "slice")
- (_.do "call" (list @@arguments (_.i32 +0) arityO)))
- extra_inputs (|> (_.array (list))
- (_.the "slice")
- (_.do "call" (list @@arguments arityO)))]
- (_.return (|> @self
- (apply_poly arity_inputs)
- (apply_poly extra_inputs))))])
- ## (|> @num_args (_.< arityO))
- (let [all_inputs (|> (_.array (list))
- (_.the "slice")
- (_.do "call" (list @@arguments)))]
- ($_ _.then
- (_.define @curried all_inputs)
- (_.return (_.closure (list)
- (let [@missing all_inputs]
- (_.return (apply_poly (_.do "concat" (list @missing) @curried)
- @self))))))))
- ))]
- _ (/////generation.execute! definition)
- _ (/////generation.save! (product.right function_name) definition)]
- (wrap instantiation)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux
deleted file mode 100644
index 135cfeb74..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux
+++ /dev/null
@@ -1,90 +0,0 @@
-(.module:
- [lux (#- Scope)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [math
- [number
- ["n" nat]]]
- [target
- ["_" js (#+ Computation Var Expression Statement)]]]
- ["." // #_
- [runtime (#+ Operation Phase Phase! Generator Generator!)]
- ["#." case]
- ["///#" //// #_
- [synthesis (#+ Scope Synthesis)]
- ["#." generation]
- ["//#" /// #_
- ["#." phase]
- [reference
- [variable (#+ Register)]]]]])
-
-(def: @scope
- (-> Nat Text)
- (|>> %.nat (format "scope")))
-
-(def: (setup initial? offset bindings body)
- (-> Bit Register (List Expression) Statement Statement)
- (|> bindings
- list.enumeration
- (list\map (function (_ [register value])
- (let [variable (//case.register (n.+ offset register))]
- (if initial?
- (_.define variable value)
- (_.set variable value)))))
- list.reverse
- (list\fold _.then body)))
-
-(def: #export (scope! statement expression archive [start initsS+ bodyS])
- (Generator! (Scope Synthesis))
- (case initsS+
- ## function/false/non-independent loop
- #.Nil
- (statement expression archive bodyS)
-
- ## true loop
- _
- (do {! ///////phase.monad}
- [@scope (\ ! map ..@scope /////generation.next)
- initsO+ (monad.map ! (expression archive) initsS+)
- body! (/////generation.with_anchor [start @scope]
- (statement expression archive bodyS))]
- (wrap (..setup true start initsO+
- (_.with_label (_.label @scope)
- (_.do_while (_.boolean true)
- body!)))))))
-
-(def: #export (scope statement expression archive [start initsS+ bodyS])
- (-> Phase! (Generator (Scope Synthesis)))
- (case initsS+
- ## function/false/non-independent loop
- #.Nil
- (expression archive bodyS)
-
- ## true loop
- _
- (do {! ///////phase.monad}
- [loop! (scope! statement expression archive [start initsS+ bodyS])]
- (wrap (_.apply/* (_.closure (list) loop!) (list))))))
-
-(def: @temp
- (_.var "lux_recur_values"))
-
-(def: #export (recur! statement expression archive argsS+)
- (Generator! (List Synthesis))
- (do {! ///////phase.monad}
- [[offset @scope] /////generation.anchor
- argsO+ (monad.map ! (expression archive) argsS+)]
- (wrap ($_ _.then
- (_.define @temp (_.array argsO+))
- (..setup false offset
- (|> argsO+
- list.enumeration
- (list\map (function (_ [idx _])
- (_.at (_.i32 (.int idx)) @temp))))
- (_.continue_at (_.label @scope)))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux
deleted file mode 100644
index db00d6439..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux
+++ /dev/null
@@ -1,20 +0,0 @@
-(.module:
- [lux (#- i64)
- [target
- ["_" js (#+ Computation)]]]
- ["." // #_
- ["#." runtime]])
-
-(def: #export bit
- _.boolean)
-
-(def: #export (i64 value)
- (-> (I64 Any) Computation)
- (//runtime.i64 (|> value //runtime.high .int _.i32)
- (|> value //runtime.low .int _.i32)))
-
-(def: #export f64
- _.number)
-
-(def: #export text
- _.string)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux
deleted file mode 100644
index 6361e3d09..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux
+++ /dev/null
@@ -1,12 +0,0 @@
-(.module:
- [lux #*
- [target
- ["_" js (#+ Expression)]]]
- [///
- [reference (#+ System)]])
-
-(implementation: #export system
- (System Expression)
-
- (def: constant _.var)
- (def: variable _.var))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux
deleted file mode 100644
index c307f4302..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux
+++ /dev/null
@@ -1,784 +0,0 @@
-(.module:
- [lux (#- i64)
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<.>" code]]]
- [data
- ["." product]
- ["." text ("#\." hash)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." list ("#\." functor)]
- ["." row]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number (#+ hex)
- ["." i64]]]
- [target
- ["_" js (#+ Expression Var Computation Statement)]]
- [tool
- [compiler
- [language
- [lux
- ["$" version]]]]]]
- ["." /// #_
- ["#." reference]
- ["//#" /// #_
- ["#." synthesis (#+ Synthesis)]
- ["#." generation]
- ["//#" ///
- ["#." phase]
- [reference
- [variable (#+ Register)]]
- [meta
- [archive (#+ Output Archive)
- ["." artifact (#+ Registry)]]]]]])
-
-(template [<name> <base>]
- [(type: #export <name>
- (<base> [Register Text] Expression Statement))]
-
- [Operation /////generation.Operation]
- [Phase /////generation.Phase]
- [Handler /////generation.Handler]
- [Bundle /////generation.Bundle]
- )
-
-(type: #export (Generator i)
- (-> Phase Archive i (Operation Expression)))
-
-(type: #export Phase!
- (-> Phase Archive Synthesis (Operation Statement)))
-
-(type: #export (Generator! i)
- (-> Phase! Phase Archive i (Operation Statement)))
-
-(def: #export high
- (-> (I64 Any) (I64 Any))
- (i64.right_shift 32))
-
-(def: #export low
- (-> (I64 Any) (I64 Any))
- (let [mask (dec (i64.left_shift 32 1))]
- (|>> (i64.and mask))))
-
-(def: #export unit
- Computation
- (_.string /////synthesis.unit))
-
-(def: #export (flag value)
- (-> Bit Computation)
- (if value
- (_.string "")
- _.null))
-
-(def: (feature name definition)
- (-> Var (-> Var Expression) Statement)
- (_.define name (definition name)))
-
-(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
- body)
- (do {! meta.monad}
- [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
- (wrap (list (` (let [(~+ (|> vars
- (list.zip/2 ids)
- (list\map (function (_ [id var])
- (list (code.local_identifier var)
- (` (_.var (~ (code.text (format "v" (%.nat id)))))))))
- list.concat))]
- (~ body)))))))
-
-(syntax: (runtime: {declaration (<>.or <code>.local_identifier
- (<code>.form (<>.and <code>.local_identifier
- (<>.some <code>.local_identifier))))}
- code)
- (macro.with_gensyms [g!_ runtime]
- (let [runtime_name (` (_.var (~ (code.text (%.code runtime)))))]
- (case declaration
- (#.Left name)
- (let [g!name (code.local_identifier name)]
- (wrap (list (` (def: #export (~ g!name)
- Var
- (~ runtime_name)))
-
- (` (def: (~ (code.local_identifier (format "@" name)))
- Statement
- (..feature (~ runtime_name)
- (function ((~ g!_) (~ g!name))
- (~ code))))))))
-
- (#.Right [name inputs])
- (let [g!name (code.local_identifier name)
- inputsC (list\map code.local_identifier inputs)
- inputs_typesC (list\map (function.constant (` _.Expression)) inputs)]
- (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
- (-> (~+ inputs_typesC) Computation)
- (_.apply/* (~ runtime_name) (list (~+ inputsC)))))
-
- (` (def: (~ (code.local_identifier (format "@" name)))
- Statement
- (..feature (~ runtime_name)
- (function ((~ g!_) (~ g!_))
- (..with_vars [(~+ inputsC)]
- (_.function (~ g!_) (list (~+ inputsC))
- (~ code))))))))))))))
-
-(def: length
- (-> Expression Computation)
- (_.the "length"))
-
-(def: last_index
- (-> Expression Computation)
- (|>> ..length (_.- (_.i32 +1))))
-
-(def: (last_element tuple)
- (_.at (..last_index tuple)
- tuple))
-
-(with_expansions [<recur> (as_is ($_ _.then
- (_.set lefts (_.- last_index_right lefts))
- (_.set tuple (_.at last_index_right tuple))))]
- (runtime: (tuple//left lefts tuple)
- (with_vars [last_index_right]
- (<| (_.while (_.boolean true))
- ($_ _.then
- (_.define last_index_right (..last_index tuple))
- (_.if (_.> lefts last_index_right)
- ## No need for recursion
- (_.return (_.at lefts tuple))
- ## Needs recursion
- <recur>)))))
-
- (runtime: (tuple//right lefts tuple)
- (with_vars [last_index_right right_index]
- (<| (_.while (_.boolean true))
- ($_ _.then
- (_.define last_index_right (..last_index tuple))
- (_.define right_index (_.+ (_.i32 +1) lefts))
- (_.cond (list [(_.= last_index_right right_index)
- (_.return (_.at right_index tuple))]
- [(_.> last_index_right right_index)
- ## Needs recursion.
- <recur>])
- (_.return (_.do "slice" (list right_index) tuple)))
- )))))
-
-(def: #export variant_tag_field "_lux_tag")
-(def: #export variant_flag_field "_lux_flag")
-(def: #export variant_value_field "_lux_value")
-
-(runtime: variant//new
- (let [@this (_.var "this")]
- (with_vars [tag is_last value]
- (_.closure (list tag is_last value)
- ($_ _.then
- (_.set (_.the ..variant_tag_field @this) tag)
- (_.set (_.the ..variant_flag_field @this) is_last)
- (_.set (_.the ..variant_value_field @this) value)
- )))))
-
-(def: #export (variant tag last? value)
- (-> Expression Expression Expression Computation)
- (_.new ..variant//new (list tag last? value)))
-
-(runtime: (sum//get sum wants_last wanted_tag)
- (let [no_match! (_.return _.null)
- sum_tag (|> sum (_.the ..variant_tag_field))
- sum_flag (|> sum (_.the ..variant_flag_field))
- sum_value (|> sum (_.the ..variant_value_field))
- is_last? (_.= ..unit sum_flag)
- extact_match! (_.return sum_value)
- test_recursion! (_.if is_last?
- ## Must recurse.
- ($_ _.then
- (_.set wanted_tag (_.- sum_tag wanted_tag))
- (_.set sum sum_value))
- no_match!)
- extrac_sub_variant! (_.return (..variant (_.- wanted_tag sum_tag) sum_flag sum_value))]
- (<| (_.while (_.boolean true))
- (_.cond (list [(_.= wanted_tag sum_tag)
- (_.if (_.= wants_last sum_flag)
- extact_match!
- test_recursion!)]
- [(_.< wanted_tag sum_tag)
- test_recursion!]
- [(_.= ..unit wants_last)
- extrac_sub_variant!])
- no_match!))))
-
-(def: none
- Computation
- (..variant (_.i32 +0) (flag #0) unit))
-
-(def: some
- (-> Expression Computation)
- (..variant (_.i32 +1) (flag #1)))
-
-(def: left
- (-> Expression Computation)
- (..variant (_.i32 +0) (flag #0)))
-
-(def: right
- (-> Expression Computation)
- (..variant (_.i32 +1) (flag #1)))
-
-(def: runtime//structure
- Statement
- ($_ _.then
- @tuple//left
- @tuple//right
- @variant//new
- @sum//get
- ))
-
-(runtime: (lux//try op)
- (with_vars [ex]
- (_.try (_.return (..right (_.apply/1 op ..unit)))
- [ex (_.return (..left (|> ex (_.do "toString" (list)))))])))
-
-(runtime: (lux//program_args inputs)
- (with_vars [output idx]
- ($_ _.then
- (_.define output ..none)
- (_.for idx
- (..last_index inputs)
- (_.>= (_.i32 +0) idx)
- (_.-- idx)
- (_.set output (..some (_.array (list (_.at idx inputs)
- output)))))
- (_.return output))))
-
-(def: runtime//lux
- Statement
- ($_ _.then
- @lux//try
- @lux//program_args
- ))
-
-(def: #export i64_low_field Text "_lux_low")
-(def: #export i64_high_field Text "_lux_high")
-
-(runtime: i64//new
- (let [@this (_.var "this")]
- (with_vars [high low]
- (_.closure (list high low)
- ($_ _.then
- (_.set (_.the ..i64_high_field @this) high)
- (_.set (_.the ..i64_low_field @this) low)
- )))))
-
-(def: #export (i64 high low)
- (-> Expression Expression Computation)
- (_.new ..i64//new (list high low)))
-
-(runtime: i64//2^16
- (_.left_shift (_.i32 +16) (_.i32 +1)))
-
-(runtime: i64//2^32
- (_.* i64//2^16 i64//2^16))
-
-(runtime: i64//2^64
- (_.* i64//2^32 i64//2^32))
-
-(runtime: i64//2^63
- (|> i64//2^64 (_./ (_.i32 +2))))
-
-(runtime: (i64//unsigned_low i64)
- (_.return (_.? (|> i64 (_.the ..i64_low_field) (_.>= (_.i32 +0)))
- (|> i64 (_.the ..i64_low_field))
- (|> i64 (_.the ..i64_low_field) (_.+ i64//2^32)))))
-
-(runtime: (i64//to_number i64)
- (_.return (|> i64
- (_.the ..i64_high_field)
- (_.* i64//2^32)
- (_.+ (i64//unsigned_low i64)))))
-
-(runtime: i64//zero
- (..i64 (_.i32 +0) (_.i32 +0)))
-
-(runtime: i64//min
- (..i64 (_.i32 (.int (hex "80,00,00,00")))
- (_.i32 +0)))
-
-(runtime: i64//max
- (..i64 (_.i32 (.int (hex "7F,FF,FF,FF")))
- (_.i32 (.int (hex "FF,FF,FF,FF")))))
-
-(runtime: i64//one
- (..i64 (_.i32 +0) (_.i32 +1)))
-
-(runtime: (i64//= reference sample)
- (_.return (_.and (_.= (_.the ..i64_high_field reference)
- (_.the ..i64_high_field sample))
- (_.= (_.the ..i64_low_field reference)
- (_.the ..i64_low_field sample)))))
-
-(runtime: (i64//+ parameter subject)
- (let [up_16 (_.left_shift (_.i32 +16))
- high_16 (_.logic_right_shift (_.i32 +16))
- low_16 (_.bit_and (_.i32 (.int (hex "FFFF"))))
- hh (|>> (_.the ..i64_high_field) high_16)
- hl (|>> (_.the ..i64_high_field) low_16)
- lh (|>> (_.the ..i64_low_field) high_16)
- ll (|>> (_.the ..i64_low_field) low_16)]
- (with_vars [l48 l32 l16 l00
- r48 r32 r16 r00
- x48 x32 x16 x00]
- ($_ _.then
- (_.define l48 (hh subject))
- (_.define l32 (hl subject))
- (_.define l16 (lh subject))
- (_.define l00 (ll subject))
-
- (_.define r48 (hh parameter))
- (_.define r32 (hl parameter))
- (_.define r16 (lh parameter))
- (_.define r00 (ll parameter))
-
- (_.define x00 (_.+ l00 r00))
-
- (_.define x16 (|> (high_16 x00)
- (_.+ l16)
- (_.+ r16)))
- (_.set x00 (low_16 x00))
-
- (_.define x32 (|> (high_16 x16)
- (_.+ l32)
- (_.+ r32)))
- (_.set x16 (low_16 x16))
-
- (_.define x48 (|> (high_16 x32)
- (_.+ l48)
- (_.+ r48)
- low_16))
- (_.set x32 (low_16 x32))
-
- (_.return (..i64 (_.bit_or (up_16 x48) x32)
- (_.bit_or (up_16 x16) x00)))
- ))))
-
-(template [<name> <op>]
- [(runtime: (<name> subject parameter)
- (_.return (..i64 (<op> (_.the ..i64_high_field subject)
- (_.the ..i64_high_field parameter))
- (<op> (_.the ..i64_low_field subject)
- (_.the ..i64_low_field parameter)))))]
-
- [i64//xor _.bit_xor]
- [i64//or _.bit_or]
- [i64//and _.bit_and]
- )
-
-(runtime: (i64//not value)
- (_.return (..i64 (_.bit_not (_.the ..i64_high_field value))
- (_.bit_not (_.the ..i64_low_field value)))))
-
-(runtime: (i64//negate value)
- (_.return (_.? (i64//= i64//min value)
- i64//min
- (i64//+ i64//one (i64//not value)))))
-
-(runtime: i64//-one
- (i64//negate i64//one))
-
-(runtime: (i64//from_number value)
- (_.return (<| (_.? (_.not_a_number? value)
- i64//zero)
- (_.? (_.<= (_.negate i64//2^63) value)
- i64//min)
- (_.? (|> value (_.+ (_.i32 +1)) (_.>= i64//2^63))
- i64//max)
- (_.? (|> value (_.< (_.i32 +0)))
- (|> value _.negate i64//from_number i64//negate))
- (..i64 (|> value (_./ i64//2^32) _.to_i32)
- (|> value (_.% i64//2^32) _.to_i32)))))
-
-(def: (cap_shift! shift)
- (-> Var Statement)
- (_.set shift (|> shift (_.bit_and (_.i32 +63)))))
-
-(def: (no_shift! shift input)
- (-> Var Var (-> Expression Expression))
- (_.? (|> shift (_.= (_.i32 +0)))
- input))
-
-(def: small_shift?
- (-> Var Expression)
- (|>> (_.< (_.i32 +32))))
-
-(runtime: (i64//left_shift input shift)
- ($_ _.then
- (..cap_shift! shift)
- (_.return (<| (..no_shift! shift input)
- (_.? (..small_shift? shift)
- (let [high (_.bit_or (|> input (_.the ..i64_high_field) (_.left_shift shift))
- (|> input (_.the ..i64_low_field) (_.logic_right_shift (_.- shift (_.i32 +32)))))
- low (|> input (_.the ..i64_low_field) (_.left_shift shift))]
- (..i64 high low)))
- (let [high (|> input (_.the ..i64_low_field) (_.left_shift (_.- (_.i32 +32) shift)))]
- (..i64 high (_.i32 +0)))))
- ))
-
-(runtime: (i64//arithmetic_right_shift input shift)
- ($_ _.then
- (..cap_shift! shift)
- (_.return (<| (..no_shift! shift input)
- (_.? (..small_shift? shift)
- (let [high (|> input (_.the ..i64_high_field) (_.arithmetic_right_shift shift))
- low (|> input (_.the ..i64_low_field) (_.logic_right_shift shift)
- (_.bit_or (|> input (_.the ..i64_high_field) (_.left_shift (_.- shift (_.i32 +32))))))]
- (..i64 high low)))
- (let [high (_.? (|> input (_.the ..i64_high_field) (_.>= (_.i32 +0)))
- (_.i32 +0)
- (_.i32 -1))
- low (|> input (_.the ..i64_high_field) (_.arithmetic_right_shift (_.- (_.i32 +32) shift)))]
- (..i64 high low))))))
-
-(runtime: (i64//right_shift input shift)
- ($_ _.then
- (..cap_shift! shift)
- (_.return (<| (..no_shift! shift input)
- (_.? (..small_shift? shift)
- (let [high (|> input (_.the ..i64_high_field) (_.logic_right_shift shift))
- low (|> input (_.the ..i64_low_field) (_.logic_right_shift shift)
- (_.bit_or (|> input (_.the ..i64_high_field) (_.left_shift (_.- shift (_.i32 +32))))))]
- (..i64 high low)))
- (_.? (|> shift (_.= (_.i32 +32)))
- (..i64 (_.i32 +0) (|> input (_.the ..i64_high_field))))
- (..i64 (_.i32 +0)
- (|> input (_.the ..i64_high_field) (_.logic_right_shift (_.- (_.i32 +32) shift))))))))
-
-(def: runtime//bit
- Statement
- ($_ _.then
- @i64//and
- @i64//or
- @i64//xor
- @i64//not
- @i64//left_shift
- @i64//arithmetic_right_shift
- @i64//right_shift
- ))
-
-(runtime: (i64//- parameter subject)
- (_.return (i64//+ (i64//negate parameter) subject)))
-
-(runtime: (i64//* parameter subject)
- (let [up_16 (_.left_shift (_.i32 +16))
- high_16 (_.logic_right_shift (_.i32 +16))
- low_16 (_.bit_and (_.i32 (.int (hex "FFFF"))))
- hh (|>> (_.the ..i64_high_field) high_16)
- hl (|>> (_.the ..i64_high_field) low_16)
- lh (|>> (_.the ..i64_low_field) high_16)
- ll (|>> (_.the ..i64_low_field) low_16)]
- (with_vars [l48 l32 l16 l00
- r48 r32 r16 r00
- x48 x32 x16 x00]
- ($_ _.then
- (_.define l48 (hh subject))
- (_.define l32 (hl subject))
- (_.define l16 (lh subject))
- (_.define l00 (ll subject))
-
- (_.define r48 (hh parameter))
- (_.define r32 (hl parameter))
- (_.define r16 (lh parameter))
- (_.define r00 (ll parameter))
-
- (_.define x00 (_.* l00 r00))
- (_.define x16 (high_16 x00))
- (_.set x00 (low_16 x00))
-
- (_.set x16 (|> x16 (_.+ (_.* l16 r00))))
- (_.define x32 (high_16 x16)) (_.set x16 (low_16 x16))
- (_.set x16 (|> x16 (_.+ (_.* l00 r16))))
- (_.set x32 (|> x32 (_.+ (high_16 x16)))) (_.set x16 (low_16 x16))
-
- (_.set x32 (|> x32 (_.+ (_.* l32 r00))))
- (_.define x48 (high_16 x32)) (_.set x32 (low_16 x32))
- (_.set x32 (|> x32 (_.+ (_.* l16 r16))))
- (_.set x48 (|> x48 (_.+ (high_16 x32)))) (_.set x32 (low_16 x32))
- (_.set x32 (|> x32 (_.+ (_.* l00 r32))))
- (_.set x48 (|> x48 (_.+ (high_16 x32)))) (_.set x32 (low_16 x32))
-
- (_.set x48 (|> x48
- (_.+ (_.* l48 r00))
- (_.+ (_.* l32 r16))
- (_.+ (_.* l16 r32))
- (_.+ (_.* l00 r48))
- low_16))
-
- (_.return (..i64 (_.bit_or (up_16 x48) x32)
- (_.bit_or (up_16 x16) x00)))
- ))))
-
-(runtime: (i64//< parameter subject)
- (let [negative? (|>> (_.the ..i64_high_field) (_.< (_.i32 +0)))]
- (with_vars [-subject? -parameter?]
- ($_ _.then
- (_.define -subject? (negative? subject))
- (_.define -parameter? (negative? parameter))
- (_.return (<| (_.? (_.and -subject? (_.not -parameter?))
- (_.boolean true))
- (_.? (_.and (_.not -subject?) -parameter?)
- (_.boolean false))
- (negative? (i64//- parameter subject))))
- ))))
-
-(def: (i64//<= param subject)
- (-> Expression Expression Expression)
- (|> (i64//< param subject)
- (_.or (i64//= param subject))))
-
-(runtime: (i64/// parameter subject)
- (let [negative? (function (_ value)
- (i64//< i64//zero value))
- valid_division_check [(i64//= i64//zero parameter)
- (_.throw (_.string "Cannot divide by zero!"))]
- short_circuit_check [(i64//= i64//zero subject)
- (_.return i64//zero)]]
- (_.cond (list valid_division_check
- short_circuit_check
-
- [(i64//= i64//min subject)
- (_.cond (list [(_.or (i64//= i64//one parameter)
- (i64//= i64//-one parameter))
- (_.return i64//min)]
- [(i64//= i64//min parameter)
- (_.return i64//one)])
- (with_vars [approximation]
- (let [subject/2 (..i64//arithmetic_right_shift subject (_.i32 +1))]
- ($_ _.then
- (_.define approximation (i64//left_shift (i64/// parameter
- subject/2)
- (_.i32 +1)))
- (_.if (i64//= i64//zero approximation)
- (_.return (_.? (negative? parameter)
- i64//one
- i64//-one))
- (let [remainder (i64//- (i64//* approximation
- parameter)
- subject)]
- (_.return (i64//+ (i64/// parameter
- remainder)
- approximation))))))))]
- [(i64//= i64//min parameter)
- (_.return i64//zero)]
-
- [(negative? subject)
- (_.return (_.? (negative? parameter)
- (i64/// (i64//negate parameter)
- (i64//negate subject))
- (i64//negate (i64/// parameter
- (i64//negate subject)))))]
-
- [(negative? parameter)
- (_.return (i64//negate (i64/// (i64//negate parameter) subject)))])
- (with_vars [result remainder]
- ($_ _.then
- (_.define result i64//zero)
- (_.define remainder subject)
- (_.while (i64//<= remainder parameter)
- (with_vars [approximate approximate_result approximate_remainder log2 delta]
- (let [approximate_result' (i64//from_number approximate)
- approx_remainder (i64//* parameter approximate_result)]
- ($_ _.then
- (_.define approximate (|> (i64//to_number remainder)
- (_./ (i64//to_number parameter))
- (_.apply/1 (_.var "Math.floor"))
- (_.apply/2 (_.var "Math.max") (_.i32 +1))))
- (_.define log2 (|> approximate
- (_.apply/1 (_.var "Math.log"))
- (_./ (_.var "Math.LN2"))
- (_.apply/1 (_.var "Math.ceil"))))
- (_.define delta (_.? (_.<= (_.i32 +48) log2)
- (_.i32 +1)
- (_.apply/2 (_.var "Math.pow")
- (_.i32 +2)
- (_.- (_.i32 +48)
- log2))))
- (_.define approximate_result approximate_result')
- (_.define approximate_remainder approx_remainder)
- (_.while (_.or (negative? approximate_remainder)
- (i64//< approximate_remainder
- remainder))
- ($_ _.then
- (_.set approximate (_.- delta approximate))
- (_.set approximate_result approximate_result')
- (_.set approximate_remainder approx_remainder)))
- (_.set result (i64//+ (_.? (i64//= i64//zero approximate_result)
- i64//one
- approximate_result)
- result))
- (_.set remainder (i64//- approximate_remainder remainder))))))
- (_.return result)))
- )))
-
-(runtime: (i64//% parameter subject)
- (let [flat (|> subject
- (i64/// parameter)
- (i64//* parameter))]
- (_.return (i64//- flat subject))))
-
-(def: runtime//i64
- Statement
- ($_ _.then
- @i64//2^16
- @i64//2^32
- @i64//2^64
- @i64//2^63
- @i64//unsigned_low
- @i64//new
- @i64//zero
- @i64//min
- @i64//max
- @i64//one
- @i64//=
- @i64//+
- @i64//negate
- @i64//to_number
- @i64//from_number
- @i64//-
- @i64//*
- @i64//<
- @i64///
- @i64//%
- runtime//bit
- ))
-
-(runtime: (text//index start part text)
- (with_vars [idx]
- ($_ _.then
- (_.define idx (|> text (_.do "indexOf" (list part (i64//to_number start)))))
- (_.return (_.? (_.= (_.i32 -1) idx)
- ..none
- (..some (i64//from_number idx)))))))
-
-(runtime: (text//clip offset length text)
- (_.return (|> text (_.do "substring" (list (_.the ..i64_low_field offset)
- (_.+ (_.the ..i64_low_field offset)
- (_.the ..i64_low_field length)))))))
-
-(runtime: (text//char idx text)
- (with_vars [result]
- ($_ _.then
- (_.define result (|> text (_.do "charCodeAt" (list (_.the ..i64_low_field idx)))))
- (_.if (_.not_a_number? result)
- (_.throw (_.string "[Lux Error] Cannot get char from text."))
- (_.return (i64//from_number result))))))
-
-(def: runtime//text
- Statement
- ($_ _.then
- @text//index
- @text//clip
- @text//char
- ))
-
-(runtime: (io//log message)
- (let [console (_.var "console")
- print (_.var "print")
- end! (_.return ..unit)]
- (_.cond (list [(|> console _.type_of (_.= (_.string "undefined")) _.not
- (_.and (_.the "log" console)))
- ($_ _.then
- (_.statement (|> console (_.do "log" (list message))))
- end!)]
- [(|> print _.type_of (_.= (_.string "undefined")) _.not)
- ($_ _.then
- (_.statement (_.apply/1 print (_.? (_.= (_.string "string")
- (_.type_of message))
- message
- (_.apply/1 (_.var "JSON.stringify") message))))
- end!)])
- end!)))
-
-(runtime: (io//error message)
- (_.throw message))
-
-(def: runtime//io
- Statement
- ($_ _.then
- @io//log
- @io//error
- ))
-
-(runtime: (js//get object field)
- (with_vars [temp]
- ($_ _.then
- (_.define temp (_.at field object))
- (_.return (_.? (_.= _.undefined temp)
- ..none
- (..some temp))))))
-
-(runtime: (js//set object field input)
- ($_ _.then
- (_.set (_.at field object) input)
- (_.return object)))
-
-(runtime: (js//delete object field)
- ($_ _.then
- (_.delete (_.at field object))
- (_.return object)))
-
-(def: runtime//js
- Statement
- ($_ _.then
- @js//get
- @js//set
- @js//delete
- ))
-
-(runtime: (array//write idx value array)
- ($_ _.then
- (_.set (_.at (_.the ..i64_low_field idx) array) value)
- (_.return array)))
-
-(runtime: (array//delete idx array)
- ($_ _.then
- (_.delete (_.at (_.the ..i64_low_field idx) array))
- (_.return array)))
-
-(def: runtime//array
- Statement
- ($_ _.then
- @array//write
- @array//delete
- ))
-
-(def: runtime
- Statement
- ($_ _.then
- runtime//structure
- runtime//i64
- runtime//text
- runtime//io
- runtime//js
- runtime//array
- runtime//lux
- ))
-
-(def: module_id
- 0)
-
-(def: #export generate
- (Operation [Registry Output])
- (do ///////phase.monad
- [_ (/////generation.execute! ..runtime)
- _ (/////generation.save! ..module_id ..runtime)]
- (wrap [(|> artifact.empty
- artifact.resource
- product.right)
- (row.row [..module_id
- (|> ..runtime
- _.code
- (\ utf8.codec encode))])])))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux
deleted file mode 100644
index a90b81f7d..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux
+++ /dev/null
@@ -1,37 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [target
- ["_" js (#+ Expression)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." primitive]
- ["///#" //// #_
- [analysis (#+ Variant Tuple)]
- ["#." synthesis (#+ Synthesis)]
- ["//#" ///
- ["#." phase ("#\." monad)]]]])
-
-(def: #export (tuple generate archive elemsS+)
- (Generator (Tuple Synthesis))
- (case elemsS+
- #.Nil
- (///////phase\wrap //runtime.unit)
-
- (#.Cons singletonS #.Nil)
- (generate archive singletonS)
-
- _
- (do {! ///////phase.monad}
- [elemsT+ (monad.map ! (generate archive) elemsS+)]
- (wrap (_.array elemsT+)))))
-
-(def: #export (variant generate archive [lefts right? valueS])
- (Generator (Variant Synthesis))
- (let [tag (if right?
- (inc lefts)
- lefts)]
- (///////phase\map (//runtime.variant (_.i32 (.int tag))
- (//runtime.flag right?))
- (generate archive valueS))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux
deleted file mode 100644
index bb908e4c9..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux
+++ /dev/null
@@ -1,72 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]]
- ["." / #_
- [runtime (#+ Phase)]
- ["#." primitive]
- ["#." structure]
- ["#." reference]
- ["#." function]
- ["#." case]
- ["#." loop]
- ["//#" /// #_
- ["#." extension]
- [//
- ["." synthesis]
- [///
- ["." reference]
- ["#" phase ("#\." monad)]]]]])
-
-(def: #export (generate archive synthesis)
- Phase
- (case synthesis
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (///\wrap (<generator> value))])
- ([synthesis.bit /primitive.bit]
- [synthesis.i64 /primitive.i64]
- [synthesis.f64 /primitive.f64]
- [synthesis.text /primitive.text])
-
- (^ (synthesis.variant variantS))
- (/structure.variant generate archive variantS)
-
- (^ (synthesis.tuple members))
- (/structure.tuple generate archive members)
-
- (#synthesis.Reference reference)
- (case reference
- (#reference.Variable variable)
- (/reference.variable archive variable)
-
- (#reference.Constant constant)
- (/reference.constant archive constant))
-
- (^ (synthesis.branch/case [valueS pathS]))
- (/case.case generate archive [valueS pathS])
-
- (^ (synthesis.branch/let [inputS register bodyS]))
- (/case.let generate archive [inputS register bodyS])
-
- (^ (synthesis.branch/if [conditionS thenS elseS]))
- (/case.if generate archive [conditionS thenS elseS])
-
- (^ (synthesis.branch/get [path recordS]))
- (/case.get generate archive [path recordS])
-
- (^ (synthesis.loop/scope scope))
- (/loop.scope generate archive scope)
-
- (^ (synthesis.loop/recur updates))
- (/loop.recur generate archive updates)
-
- (^ (synthesis.function/abstraction abstraction))
- (/function.abstraction generate archive abstraction)
-
- (^ (synthesis.function/apply application))
- (/function.apply generate archive application)
-
- (#synthesis.Extension extension)
- (///extension.apply archive generate extension)
- ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux
deleted file mode 100644
index 010f97349..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux
+++ /dev/null
@@ -1,265 +0,0 @@
-(.module:
- [lux (#- Type if let case int)
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]]
- [data
- [number
- ["." i32]
- ["n" nat]]
- [collection
- ["." list ("#\." fold)]]]
- [target
- [jvm
- ["_" bytecode (#+ Label Bytecode) ("#\." monad)]
- ["." type (#+ Type)
- [category (#+ Method)]]]]]
- ["." // #_
- ["#." type]
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." value]
- ["#." structure]
- [////
- ["." synthesis (#+ Path Synthesis)]
- ["." generation]
- [///
- ["." phase ("operation\." monad)]
- [reference
- [variable (#+ Register)]]]]])
-
-(def: equals-name
- "equals")
-
-(def: equals-type
- (type.method [(list //type.value) type.boolean (list)]))
-
-(def: (pop-alt stack-depth)
- (-> Nat (Bytecode Any))
- (.case stack-depth
- 0 (_\wrap [])
- 1 _.pop
- 2 _.pop2
- _ ## (n.> 2)
- ($_ _.compose
- _.pop2
- (pop-alt (n.- 2 stack-depth)))))
-
-(def: int
- (-> (I64 Any) (Bytecode Any))
- (|>> .i64 i32.i32 _.int))
-
-(def: long
- (-> (I64 Any) (Bytecode Any))
- (|>> .int _.long))
-
-(def: double
- (-> Frac (Bytecode Any))
- (|>> _.double))
-
-(def: peek
- (Bytecode Any)
- ($_ _.compose
- _.dup
- (//runtime.get //runtime.stack-head)))
-
-(def: pop
- (Bytecode Any)
- ($_ _.compose
- (//runtime.get //runtime.stack-tail)
- (_.checkcast //type.stack)))
-
-(def: (left-projection lefts)
- (-> Nat (Bytecode Any))
- ($_ _.compose
- (_.checkcast //type.tuple)
- (..int lefts)
- (.case lefts
- 0
- _.aaload
-
- lefts
- //runtime.left-projection)))
-
-(def: (right-projection lefts)
- (-> Nat (Bytecode Any))
- ($_ _.compose
- (_.checkcast //type.tuple)
- (..int lefts)
- //runtime.right-projection))
-
-(def: (path' stack-depth @else @end phase archive path)
- (-> Nat Label Label (Generator Path))
- (.case path
- #synthesis.Pop
- (operation\wrap ..pop)
-
- (#synthesis.Bind register)
- (operation\wrap ($_ _.compose
- ..peek
- (_.astore register)))
-
- (#synthesis.Then bodyS)
- (do phase.monad
- [bodyG (phase archive bodyS)]
- (wrap ($_ _.compose
- (..pop-alt stack-depth)
- bodyG
- (_.goto @end))))
-
- (^template [<pattern> <right?>]
- [(^ (<pattern> lefts))
- (operation\wrap
- (do _.monad
- [@success _.new-label
- @fail _.new-label]
- ($_ _.compose
- ..peek
- (_.checkcast //type.variant)
- (//structure.tag lefts <right?>)
- (//structure.flag <right?>)
- //runtime.case
- _.dup
- (_.ifnull @fail)
- (_.goto @success)
- (_.set-label @fail)
- _.pop
- (_.goto @else)
- (_.set-label @success)
- //runtime.push)))])
- ([synthesis.side/left false]
- [synthesis.side/right true])
-
- (^template [<pattern> <projection>]
- [(^ (<pattern> lefts))
- (operation\wrap ($_ _.compose
- ..peek
- (<projection> lefts)
- //runtime.push))])
- ([synthesis.member/left ..left-projection]
- [synthesis.member/right ..right-projection])
-
- ## Extra optimization
- (^ (synthesis.path/seq
- (synthesis.member/left 0)
- (synthesis.!bind-top register thenP)))
- (do phase.monad
- [thenG (path' stack-depth @else @end phase archive thenP)]
- (wrap ($_ _.compose
- ..peek
- (_.checkcast //type.tuple)
- _.iconst-0
- _.aaload
- (_.astore register)
- thenG)))
-
- ## Extra optimization
- (^template [<pm> <projection>]
- [(^ (synthesis.path/seq
- (<pm> lefts)
- (synthesis.!bind-top register thenP)))
- (do phase.monad
- [then! (path' stack-depth @else @end phase archive thenP)]
- (wrap ($_ _.compose
- ..peek
- (_.checkcast //type.tuple)
- (..int lefts)
- <projection>
- (_.astore register)
- then!)))])
- ([synthesis.member/left //runtime.left-projection]
- [synthesis.member/right //runtime.right-projection])
-
- (#synthesis.Alt leftP rightP)
- (do phase.monad
- [@alt-else //runtime.forge-label
- left! (path' (inc stack-depth) @alt-else @end phase archive leftP)
- right! (path' stack-depth @else @end phase archive rightP)]
- (wrap ($_ _.compose
- _.dup
- left!
- (_.set-label @alt-else)
- _.pop
- right!)))
-
- (#synthesis.Seq leftP rightP)
- (do phase.monad
- [left! (path' stack-depth @else @end phase archive leftP)
- right! (path' stack-depth @else @end phase archive rightP)]
- (wrap ($_ _.compose
- left!
- right!)))
-
- _
- (undefined)
- ))
-
-(def: (path @end phase archive path)
- (-> Label (Generator Path))
- (do phase.monad
- [@else //runtime.forge-label
- pathG (..path' 1 @else @end phase archive path)]
- (wrap ($_ _.compose
- pathG
- (_.set-label @else)
- _.pop
- //runtime.pm-failure
- _.aconst-null
- (_.goto @end)))))
-
-(def: #export (if phase archive [conditionS thenS elseS])
- (Generator [Synthesis Synthesis Synthesis])
- (do phase.monad
- [conditionG (phase archive conditionS)
- thenG (phase archive thenS)
- elseG (phase archive elseS)]
- (wrap (do _.monad
- [@else _.new-label
- @end _.new-label]
- ($_ _.compose
- conditionG
- (//value.unwrap type.boolean)
- (_.ifeq @else)
- thenG
- (_.goto @end)
- (_.set-label @else)
- elseG
- (_.set-label @end))))))
-
-(def: #export (let phase archive [inputS register bodyS])
- (Generator [Synthesis Register Synthesis])
- (do phase.monad
- [inputG (phase archive inputS)
- bodyG (phase archive bodyS)]
- (wrap ($_ _.compose
- inputG
- (_.astore register)
- bodyG))))
-
-(def: #export (get phase archive [path recordS])
- (Generator [(List synthesis.Member) Synthesis])
- (do phase.monad
- [recordG (phase archive recordS)]
- (wrap (list\fold (function (_ step so-far)
- (.let [next (.case step
- (#.Left lefts)
- (..left-projection lefts)
-
- (#.Right lefts)
- (..right-projection lefts))]
- (_.compose so-far next)))
- recordG
- (list.reverse path)))))
-
-(def: #export (case phase archive [valueS path])
- (Generator [Synthesis Path])
- (do phase.monad
- [@end //runtime.forge-label
- valueG (phase archive valueS)
- pathG (..path @end phase archive path)]
- (wrap ($_ _.compose
- _.aconst-null
- valueG
- //runtime.push
- pathG
- (_.set-label @end)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux
deleted file mode 100644
index 659dc0799..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux
+++ /dev/null
@@ -1,30 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." io (#+ IO)]
- ["." try (#+ Try)]]
- [data
- [binary (#+ Binary)]
- [text
- ["%" format (#+ format)]]]
- [world
- ["." file (#+ File)]]])
-
-(def: extension ".class")
-
-(def: #export (write-class! name bytecode)
- (-> Text Binary (IO Text))
- (let [file-path (format name ..extension)]
- (do io.monad
- [outcome (do (try.with @)
- [file (: (IO (Try (File IO)))
- (file.get-file io.monad file.default file-path))]
- (\ file over-write bytecode))]
- (wrap (case outcome
- (#try.Success definition)
- file-path
-
- (#try.Failure error)
- error)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux
deleted file mode 100644
index a456644b8..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux
+++ /dev/null
@@ -1,134 +0,0 @@
-(.module:
- [lux (#- Type)
- [abstract
- ["." monad (#+ do)]]
- [data
- [number
- ["." i32]
- ["n" nat]]
- [collection
- ["." list ("#\." monoid functor)]
- ["." row]]
- ["." format #_
- ["#" binary]]]
- [target
- [jvm
- ["." version]
- ["." modifier (#+ Modifier) ("#\." monoid)]
- ["." field (#+ Field)]
- ["." method (#+ Method)]
- ["_" bytecode (#+ Label Bytecode) ("#\." monad)]
- ["." class (#+ Class)]
- ["." type (#+ Type)
- [category (#+ Return' Value')]
- ["." reflection]]
- ["." constant
- [pool (#+ Resource)]]
- [encoding
- ["." name (#+ External Internal)]
- ["." unsigned]]]]
- [tool
- [compiler
- [meta
- ["." archive (#+ Archive)]]]]]
- ["." / #_
- ["#." abstract]
- [field
- [constant
- ["#." arity]]
- [variable
- ["#." foreign]
- ["#." partial]]]
- [method
- ["#." init]
- ["#." new]
- ["#." implementation]
- ["#." reset]
- ["#." apply]]
- ["/#" // #_
- ["#." runtime (#+ Operation Phase Generator)]
- [////
- [analysis (#+ Environment)]
- [synthesis (#+ Synthesis Abstraction Apply)]
- ["." generation]
- [///
- ["." arity (#+ Arity)]
- ["." phase]
- [reference
- [variable (#+ Register)]]]]]])
-
-(def: #export (with generate archive @begin class environment arity body)
- (-> Phase Archive Label External (Environment Synthesis) Arity (Bytecode Any)
- (Operation [(List (Resource Field))
- (List (Resource Method))
- (Bytecode Any)]))
- (let [classT (type.class class (list))
- fields (: (List (Resource Field))
- (list& /arity.constant
- (list\compose (/foreign.variables environment)
- (/partial.variables arity))))
- methods (: (List (Resource Method))
- (list& (/init.method classT environment arity)
- (/reset.method classT environment arity)
- (if (arity.multiary? arity)
- (|> (n.min arity /arity.maximum)
- list.indices
- (list\map (|>> inc (/apply.method classT environment arity @begin body)))
- (list& (/implementation.method arity @begin body)))
- (list (/implementation.method' //runtime.apply::name arity @begin body)))))]
- (do phase.monad
- [instance (/new.instance generate archive classT environment arity)]
- (wrap [fields methods instance]))))
-
-(def: modifier
- (Modifier Class)
- ($_ modifier\compose
- class.public
- class.final))
-
-(def: this-offset 1)
-
-(def: internal
- (All [category]
- (-> (Type (<| Return' Value' category))
- Internal))
- (|>> type.reflection reflection.reflection name.internal))
-
-(def: #export (abstraction generate archive [environment arity bodyS])
- (Generator Abstraction)
- (do phase.monad
- [@begin //runtime.forge-label
- [function-context bodyG] (generation.with-new-context archive
- (generation.with-anchor [@begin ..this-offset]
- (generate archive bodyS)))
- #let [function-class (//runtime.class-name function-context)]
- [fields methods instance] (..with generate archive @begin function-class environment arity bodyG)
- class (phase.lift (class.class version.v6_0
- ..modifier
- (name.internal function-class)
- (..internal /abstract.class) (list)
- fields
- methods
- (row.row)))
- #let [bytecode (format.run class.writer class)]
- _ (generation.execute! [function-class bytecode])
- _ (generation.save! function-class [function-class bytecode])]
- (wrap instance)))
-
-(def: #export (apply generate archive [abstractionS inputsS])
- (Generator Apply)
- (do {! phase.monad}
- [abstractionG (generate archive abstractionS)
- inputsG (monad.map ! (generate archive) inputsS)]
- (wrap ($_ _.compose
- abstractionG
- (|> inputsG
- (list.chunk /arity.maximum)
- (monad.map _.monad
- (function (_ batchG)
- ($_ _.compose
- (_.checkcast /abstract.class)
- (monad.seq _.monad batchG)
- (_.invokevirtual /abstract.class //runtime.apply::name (//runtime.apply::type (list.size batchG)))
- ))))
- ))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux
deleted file mode 100644
index 0b4885180..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux
+++ /dev/null
@@ -1,23 +0,0 @@
-(.module:
- [lux (#- Type)
- [data
- [text
- ["%" format]]]
- [target
- [jvm
- ["." type (#+ Type)
- [category (#+ Method)]]]]]
- [//
- [field
- [constant
- ["." arity]]]])
-
-(def: #export artifact_id
- 1)
-
-(def: #export class
- (type.class (%.nat artifact_id) (list)))
-
-(def: #export init
- (Type Method)
- (type.method [(list arity.type) type.void (list)]))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux
deleted file mode 100644
index f3b4a4720..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux
+++ /dev/null
@@ -1,25 +0,0 @@
-(.module:
- [lux (#- Type type)
- [data
- [collection
- ["." row]]]
- [target
- [jvm
- ["." field (#+ Field)]
- ["." modifier (#+ Modifier) ("#\." monoid)]
- [type (#+ Type)
- [category (#+ Value)]]
- [constant
- [pool (#+ Resource)]]]]])
-
-(def: modifier
- (Modifier Field)
- ($_ modifier\compose
- field.public
- field.static
- field.final
- ))
-
-(def: #export (constant name type)
- (-> Text (Type Value) (Resource Field))
- (field.field ..modifier name type (row.row)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux
deleted file mode 100644
index 011535ce9..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux
+++ /dev/null
@@ -1,21 +0,0 @@
-(.module:
- [lux (#- type)
- [target
- [jvm
- ["." type]
- ["." field (#+ Field)]
- [constant
- [pool (#+ Resource)]]]]]
- ["." //
- [/////////
- [arity (#+ Arity)]]])
-
-(def: #export name "arity")
-(def: #export type type.int)
-
-(def: #export minimum Arity 1)
-(def: #export maximum Arity 8)
-
-(def: #export constant
- (Resource Field)
- (//.constant ..name ..type))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux
deleted file mode 100644
index 478f9d454..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux
+++ /dev/null
@@ -1,55 +0,0 @@
-(.module:
- [lux (#- Type type)
- [data
- [collection
- ["." list ("#\." functor)]
- ["." row]]]
- [target
- [jvm
- ["." modifier (#+ Modifier) ("#\." monoid)]
- ["." field (#+ Field)]
- ["_" bytecode (#+ Bytecode)]
- [type (#+ Type)
- [category (#+ Value Class)]]
- [constant
- [pool (#+ Resource)]]]]]
- ["." //// #_
- ["#." type]
- ["#." reference]
- [//////
- [reference
- [variable (#+ Register)]]]])
-
-(def: #export type ////type.value)
-
-(def: #export (get class name)
- (-> (Type Class) Text (Bytecode Any))
- ($_ _.compose
- ////reference.this
- (_.getfield class name ..type)
- ))
-
-(def: #export (put naming class register value)
- (-> (-> Register Text) (Type Class) Register (Bytecode Any) (Bytecode Any))
- ($_ _.compose
- ////reference.this
- value
- (_.putfield class (naming register) ..type)))
-
-(def: modifier
- (Modifier Field)
- ($_ modifier\compose
- field.private
- field.final
- ))
-
-(def: #export (variable name type)
- (-> Text (Type Value) (Resource Field))
- (field.field ..modifier name type (row.row)))
-
-(def: #export (variables naming amount)
- (-> (-> Register Text) Nat (List (Resource Field)))
- (|> amount
- list.indices
- (list\map (function (_ register)
- (..variable (naming register) ..type)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux
deleted file mode 100644
index 1c6bf6455..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux
+++ /dev/null
@@ -1,39 +0,0 @@
-(.module:
- [lux (#- Type)
- [data
- [collection
- ["." list]
- ["." row]]]
- [target
- [jvm
- ["_" bytecode (#+ Bytecode)]
- ["." field (#+ Field)]
- [constant
- [pool (#+ Resource)]]
- [type (#+ Type)
- [category (#+ Value Class)]]]]]
- ["." //
- ["///#" //// #_
- ["#." reference]
- [////
- [analysis (#+ Environment)]
- [synthesis (#+ Synthesis)]
- [///
- [reference
- [variable (#+ Register)]]]]]])
-
-(def: #export (closure environment)
- (-> (Environment Synthesis) (List (Type Value)))
- (list.repeat (list.size environment) //.type))
-
-(def: #export (get class register)
- (-> (Type Class) Register (Bytecode Any))
- (//.get class (/////reference.foreign-name register)))
-
-(def: #export (put class register value)
- (-> (Type Class) Register (Bytecode Any) (Bytecode Any))
- (//.put /////reference.foreign-name class register value))
-
-(def: #export variables
- (-> (Environment Synthesis) (List (Resource Field)))
- (|>> list.size (//.variables /////reference.foreign-name)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux
deleted file mode 100644
index ff1599a0c..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux
+++ /dev/null
@@ -1,58 +0,0 @@
-(.module:
- [lux (#- Type)
- [abstract
- ["." monad]]
- [data
- [number
- ["n" nat]]
- [collection
- ["." list ("#\." functor)]
- ["." row]]]
- [target
- [jvm
- ["." field (#+ Field)]
- ["_" bytecode (#+ Label Bytecode) ("#\." monad)]
- [type (#+ Type)
- [category (#+ Class)]]
- [constant
- [pool (#+ Resource)]]]]]
- ["." / #_
- ["#." count]
- ["/#" //
- ["/#" // #_
- [constant
- ["#." arity]]
- ["//#" /// #_
- ["#." reference]
- [//////
- ["." arity (#+ Arity)]
- [reference
- [variable (#+ Register)]]]]]]])
-
-(def: #export (initial amount)
- (-> Nat (Bytecode Any))
- ($_ _.compose
- (|> _.aconst-null
- (list.repeat amount)
- (monad.seq _.monad))
- (_\wrap [])))
-
-(def: #export (get class register)
- (-> (Type Class) Register (Bytecode Any))
- (//.get class (/////reference.partial-name register)))
-
-(def: #export (put class register value)
- (-> (Type Class) Register (Bytecode Any) (Bytecode Any))
- (//.put /////reference.partial-name class register value))
-
-(def: #export variables
- (-> Arity (List (Resource Field)))
- (|>> (n.- ///arity.minimum) (//.variables /////reference.partial-name)))
-
-(def: #export (new arity)
- (-> Arity (Bytecode Any))
- (if (arity.multiary? arity)
- ($_ _.compose
- /count.initial
- (initial (n.- ///arity.minimum arity)))
- (_\wrap [])))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux
deleted file mode 100644
index dbafd7ee5..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux
+++ /dev/null
@@ -1,30 +0,0 @@
-(.module:
- [lux (#- type)
- [control
- ["." try]]
- [target
- [jvm
- ["_" bytecode (#+ Bytecode)]
- [encoding
- [name (#+ External)]
- ["." signed]]
- ["." type]]]]
- ["." ///// #_
- ["#." abstract]])
-
-(def: #export field "partials")
-(def: #export type type.int)
-
-(def: #export initial
- (Bytecode Any)
- (|> +0 signed.s1 try.assume _.bipush))
-
-(def: this
- _.aload_0)
-
-(def: #export value
- (Bytecode Any)
- ($_ _.compose
- ..this
- (_.getfield /////abstract.class ..field ..type)
- ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux
deleted file mode 100644
index a6de97cc3..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux
+++ /dev/null
@@ -1,13 +0,0 @@
-(.module:
- [lux #*
- [target
- [jvm
- ["." modifier (#+ Modifier) ("#\." monoid)]
- ["." method (#+ Method)]]]])
-
-(def: #export modifier
- (Modifier Method)
- ($_ modifier\compose
- method.public
- method.strict
- ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux
deleted file mode 100644
index 581cce970..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux
+++ /dev/null
@@ -1,156 +0,0 @@
-(.module:
- [lux (#- Type type)
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try]]
- [data
- [number
- ["n" nat]
- ["i" int]
- ["." i32]]
- [collection
- ["." list ("#\." monoid functor)]]]
- [target
- [jvm
- ["_" bytecode (#+ Label Bytecode) ("#\." monad)]
- ["." method (#+ Method)]
- [constant
- [pool (#+ Resource)]]
- [encoding
- ["." signed]]
- ["." type (#+ Type)
- ["." category (#+ Class)]]]]]
- ["." //
- ["#." reset]
- ["#." implementation]
- ["#." init]
- ["/#" // #_
- ["#." abstract]
- [field
- [constant
- ["#." arity]]
- [variable
- ["#." partial
- ["#/." count]]
- ["#." foreign]]]
- ["/#" // #_
- ["#." runtime]
- ["#." value]
- ["#." reference]
- [////
- [analysis (#+ Environment)]
- [synthesis (#+ Synthesis)]
- [///
- [arity (#+ Arity)]
- [reference
- [variable (#+ Register)]]]]]]])
-
-(def: (increment by)
- (-> Nat (Bytecode Any))
- ($_ _.compose
- (<| _.int .i64 by)
- _.iadd))
-
-(def: (inputs offset amount)
- (-> Register Nat (Bytecode Any))
- ($_ _.compose
- (|> amount
- list.indices
- (monad.map _.monad (|>> (n.+ offset) _.aload)))
- (_\wrap [])
- ))
-
-(def: (apply offset amount)
- (-> Register Nat (Bytecode Any))
- (let [arity (n.min amount ///arity.maximum)]
- ($_ _.compose
- (_.checkcast ///abstract.class)
- (..inputs offset arity)
- (_.invokevirtual ///abstract.class ////runtime.apply::name (////runtime.apply::type arity))
- (if (n.> ///arity.maximum amount)
- (apply (n.+ ///arity.maximum offset)
- (n.- ///arity.maximum amount))
- (_\wrap []))
- )))
-
-(def: this-offset 1)
-
-(def: #export (method class environment function-arity @begin body apply-arity)
- (-> (Type Class) (Environment Synthesis) Arity Label (Bytecode Any) Arity (Resource Method))
- (let [num-partials (dec function-arity)
- over-extent (i.- (.int apply-arity)
- (.int function-arity))]
- (method.method //.modifier ////runtime.apply::name
- (////runtime.apply::type apply-arity)
- (list)
- (#.Some (case num-partials
- 0 ($_ _.compose
- ////reference.this
- (..inputs ..this-offset apply-arity)
- (_.invokevirtual class //implementation.name (//implementation.type function-arity))
- _.areturn)
- _ (do _.monad
- [@default _.new-label
- @labelsH _.new-label
- @labelsT (|> _.new-label
- (list.repeat (dec num-partials))
- (monad.seq _.monad))
- #let [cases (|> (list\compose (#.Cons [@labelsH @labelsT])
- (list @default))
- list.enumeration
- (list\map (function (_ [stage @case])
- (let [current-partials (|> (list.indices stage)
- (list\map (///partial.get class))
- (monad.seq _.monad))
- already-partial? (n.> 0 stage)
- exact-match? (i.= over-extent (.int stage))
- has-more-than-necessary? (i.> over-extent (.int stage))]
- ($_ _.compose
- (_.set-label @case)
- (cond exact-match?
- ($_ _.compose
- ////reference.this
- (if already-partial?
- (_.invokevirtual class //reset.name (//reset.type class))
- (_\wrap []))
- current-partials
- (..inputs ..this-offset apply-arity)
- (_.invokevirtual class //implementation.name (//implementation.type function-arity))
- _.areturn)
-
- has-more-than-necessary?
- (let [inputs-to-completion (|> function-arity (n.- stage))
- inputs-left (|> apply-arity (n.- inputs-to-completion))]
- ($_ _.compose
- ////reference.this
- (_.invokevirtual class //reset.name (//reset.type class))
- current-partials
- (..inputs ..this-offset inputs-to-completion)
- (_.invokevirtual class //implementation.name (//implementation.type function-arity))
- (apply (n.+ ..this-offset inputs-to-completion) inputs-left)
- _.areturn))
-
- ## (i.< over-extent (.int stage))
- (let [current-environment (|> (list.indices (list.size environment))
- (list\map (///foreign.get class))
- (monad.seq _.monad))
- missing-partials (|> _.aconst-null
- (list.repeat (|> num-partials (n.- apply-arity) (n.- stage)))
- (monad.seq _.monad))]
- ($_ _.compose
- (_.new class)
- _.dup
- current-environment
- ///partial/count.value
- (..increment apply-arity)
- current-partials
- (..inputs ..this-offset apply-arity)
- missing-partials
- (_.invokevirtual class //init.name (//init.type environment function-arity))
- _.areturn)))))))
- (monad.seq _.monad))]]
- ($_ _.compose
- ///partial/count.value
- (_.tableswitch (try.assume (signed.s4 +0)) @default [@labelsH @labelsT])
- cases)))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux
deleted file mode 100644
index 000bdf569..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux
+++ /dev/null
@@ -1,41 +0,0 @@
-(.module:
- [lux (#- Type type)
- [data
- [collection
- ["." list]]]
- [target
- [jvm
- ["." method (#+ Method)]
- ["_" bytecode (#+ Label Bytecode)]
- [constant
- [pool (#+ Resource)]]
- ["." type (#+ Type)
- ["." category]]]]]
- ["." //
- ["//#" /// #_
- ["#." type]
- [//////
- [arity (#+ Arity)]]]])
-
-(def: #export name "impl")
-
-(def: #export (type arity)
- (-> Arity (Type category.Method))
- (type.method [(list.repeat arity ////type.value)
- ////type.value
- (list)]))
-
-(def: #export (method' name arity @begin body)
- (-> Text Arity Label (Bytecode Any) (Resource Method))
- (method.method //.modifier name
- (..type arity)
- (list)
- (#.Some ($_ _.compose
- (_.set-label @begin)
- body
- _.areturn
- ))))
-
-(def: #export method
- (-> Arity Label (Bytecode Any) (Resource Method))
- (method' ..name))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux
deleted file mode 100644
index fe8b824c9..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux
+++ /dev/null
@@ -1,97 +0,0 @@
-(.module:
- [lux (#- Type type)
- [abstract
- ["." monad]]
- [control
- ["." try]]
- [data
- [number
- ["n" nat]]
- [collection
- ["." list ("#\." monoid functor)]]]
- [target
- [jvm
- ["_" bytecode (#+ Bytecode)]
- ["." method (#+ Method)]
- [encoding
- ["." unsigned]]
- [constant
- [pool (#+ Resource)]]
- ["." type (#+ Type)
- ["." category (#+ Class Value)]]]]]
- ["." //
- ["#." implementation]
- ["/#" // #_
- ["#." abstract]
- [field
- [constant
- ["#." arity]]
- [variable
- ["#." foreign]
- ["#." partial]]]
- ["/#" // #_
- ["#." type]
- ["#." reference]
- [////
- [analysis (#+ Environment)]
- [synthesis (#+ Synthesis)]
- [///
- ["." arity (#+ Arity)]
- [reference
- [variable (#+ Register)]]]]]]])
-
-(def: #export name "<init>")
-
-(def: (partials arity)
- (-> Arity (List (Type Value)))
- (list.repeat (dec arity) ////type.value))
-
-(def: #export (type environment arity)
- (-> (Environment Synthesis) Arity (Type category.Method))
- (type.method [(list\compose (///foreign.closure environment)
- (if (arity.multiary? arity)
- (list& ///arity.type (..partials arity))
- (list)))
- type.void
- (list)]))
-
-(def: no-partials (|> 0 unsigned.u1 try.assume _.bipush))
-
-(def: #export (super environment-size arity)
- (-> Nat Arity (Bytecode Any))
- (let [arity-register (inc environment-size)]
- ($_ _.compose
- (if (arity.unary? arity)
- ..no-partials
- (_.iload arity-register))
- (_.invokespecial ///abstract.class ..name ///abstract.init))))
-
-(def: (store-all amount put offset)
- (-> Nat
- (-> Register (Bytecode Any) (Bytecode Any))
- (-> Register Register)
- (Bytecode Any))
- (|> (list.indices amount)
- (list\map (function (_ register)
- (put register
- (_.aload (offset register)))))
- (monad.seq _.monad)))
-
-(def: #export (method class environment arity)
- (-> (Type Class) (Environment Synthesis) Arity (Resource Method))
- (let [environment-size (list.size environment)
- offset-foreign (: (-> Register Register)
- (n.+ 1))
- offset-arity (: (-> Register Register)
- (|>> offset-foreign (n.+ environment-size)))
- offset-partial (: (-> Register Register)
- (|>> offset-arity (n.+ 1)))]
- (method.method //.modifier ..name
- (..type environment arity)
- (list)
- (#.Some ($_ _.compose
- ////reference.this
- (..super environment-size arity)
- (store-all environment-size (///foreign.put class) offset-foreign)
- (store-all (dec arity) (///partial.put class) offset-partial)
- _.return)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux
deleted file mode 100644
index 7bf1b0bd8..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux
+++ /dev/null
@@ -1,80 +0,0 @@
-(.module:
- [lux (#- Type type)
- [abstract
- ["." monad (#+ do)]]
- [data
- [number
- ["n" nat]]
- [collection
- ["." list]]]
- [target
- [jvm
- ["." field (#+ Field)]
- ["." method (#+ Method)]
- ["_" bytecode (#+ Bytecode)]
- ["." constant
- [pool (#+ Resource)]]
- [type (#+ Type)
- ["." category (#+ Class Value Return)]]]]
- [tool
- [compiler
- [meta
- ["." archive (#+ Archive)]]]]]
- ["." //
- ["#." init]
- ["#." implementation]
- ["/#" // #_
- [field
- [constant
- ["#." arity]]
- [variable
- ["#." foreign]
- ["#." partial]]]
- ["/#" // #_
- [runtime (#+ Operation Phase)]
- ["#." value]
- ["#." reference]
- [////
- [analysis (#+ Environment)]
- [synthesis (#+ Synthesis)]
- [///
- ["." arity (#+ Arity)]
- ["." phase]]]]]])
-
-(def: #export (instance' foreign-setup class environment arity)
- (-> (List (Bytecode Any)) (Type Class) (Environment Synthesis) Arity (Bytecode Any))
- ($_ _.compose
- (_.new class)
- _.dup
- (monad.seq _.monad foreign-setup)
- (///partial.new arity)
- (_.invokespecial class //init.name (//init.type environment arity))))
-
-(def: #export (instance generate archive class environment arity)
- (-> Phase Archive (Type Class) (Environment Synthesis) Arity (Operation (Bytecode Any)))
- (do {! phase.monad}
- [foreign* (monad.map ! (generate archive) environment)]
- (wrap (instance' foreign* class environment arity))))
-
-(def: #export (method class environment arity)
- (-> (Type Class) (Environment Synthesis) Arity (Resource Method))
- (let [after-this (: (-> Nat Nat)
- (n.+ 1))
- environment-size (list.size environment)
- after-environment (: (-> Nat Nat)
- (|>> after-this (n.+ environment-size)))
- after-arity (: (-> Nat Nat)
- (|>> after-environment (n.+ 1)))]
- (method.method //.modifier //init.name
- (//init.type environment arity)
- (list)
- (#.Some ($_ _.compose
- ////reference.this
- (//init.super environment-size arity)
- (monad.map _.monad (function (_ register)
- (///foreign.put class register (_.aload (after-this register))))
- (list.indices environment-size))
- (monad.map _.monad (function (_ register)
- (///partial.put class register (_.aload (after-arity register))))
- (list.indices (n.- ///arity.minimum arity)))
- _.areturn)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux
deleted file mode 100644
index 9793da801..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux
+++ /dev/null
@@ -1,49 +0,0 @@
-(.module:
- [lux (#- Type type)
- [data
- [collection
- ["." list ("#\." functor)]]]
- [target
- [jvm
- ["." method (#+ Method)]
- ["_" bytecode (#+ Bytecode)]
- [constant
- [pool (#+ Resource)]]
- ["." type (#+ Type)
- ["." category (#+ Class)]]]]]
- ["." //
- ["#." new]
- ["/#" // #_
- [field
- [variable
- ["#." foreign]]]
- ["/#" // #_
- ["#." reference]
- [////
- [analysis (#+ Environment)]
- [synthesis (#+ Synthesis)]
- [///
- ["." arity (#+ Arity)]]]]]])
-
-(def: #export name "reset")
-
-(def: #export (type class)
- (-> (Type Class) (Type category.Method))
- (type.method [(list) class (list)]))
-
-(def: (current-environment class)
- (-> (Type Class) (Environment Synthesis) (List (Bytecode Any)))
- (|>> list.size
- list.indices
- (list\map (///foreign.get class))))
-
-(def: #export (method class environment arity)
- (-> (Type Class) (Environment Synthesis) Arity (Resource Method))
- (method.method //.modifier ..name
- (..type class)
- (list)
- (#.Some ($_ _.compose
- (if (arity.multiary? arity)
- (//new.instance' (..current-environment class environment) class environment arity)
- ////reference.this)
- _.areturn))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux
deleted file mode 100644
index 0e7a2c776..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux
+++ /dev/null
@@ -1,160 +0,0 @@
-(.module:
- [lux (#- Definition)
- ["." ffi (#+ import: do-to object)]
- [abstract
- [monad (#+ do)]]
- [control
- pipe
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." io (#+ IO io)]
- [concurrency
- ["." atom (#+ Atom atom)]]]
- [data
- [binary (#+ Binary)]
- ["." product]
- ["." text ("#\." hash)
- ["%" format (#+ format)]]
- [collection
- ["." array]
- ["." dictionary (#+ Dictionary)]
- ["." row]]
- ["." format #_
- ["#" binary]]]
- [target
- [jvm
- ["." loader (#+ Library)]
- ["_" bytecode (#+ Bytecode)]
- ["." modifier (#+ Modifier) ("#\." monoid)]
- ["." field (#+ Field)]
- ["." method (#+ Method)]
- ["." version]
- ["." class (#+ Class)]
- ["." encoding #_
- ["#/." name]]
- ["." type
- ["." descriptor]]]]
- [tool
- [compiler
- ["." name]]]]
- ["." // #_
- ["#." runtime (#+ Definition)]]
- )
-
-(import: java/lang/reflect/Field
- (get [#? java/lang/Object] #try #? java/lang/Object))
-
-(import: (java/lang/Class a)
- (getField [java/lang/String] #try java/lang/reflect/Field))
-
-(import: java/lang/Object
- (getClass [] (java/lang/Class java/lang/Object)))
-
-(import: java/lang/ClassLoader)
-
-(def: value::field "value")
-(def: value::type (type.class "java.lang.Object" (list)))
-(def: value::modifier ($_ modifier\compose field.public field.final field.static))
-
-(def: init::type (type.method [(list) type.void (list)]))
-(def: init::modifier ($_ modifier\compose method.public method.static method.strict))
-
-(exception: #export (cannot-load {class Text} {error Text})
- (exception.report
- ["Class" class]
- ["Error" error]))
-
-(exception: #export (invalid-field {class Text} {field Text} {error Text})
- (exception.report
- ["Class" class]
- ["Field" field]
- ["Error" error]))
-
-(exception: #export (invalid-value {class Text})
- (exception.report
- ["Class" class]))
-
-(def: (class-value class-name class)
- (-> Text (java/lang/Class java/lang/Object) (Try Any))
- (case (java/lang/Class::getField ..value::field class)
- (#try.Success field)
- (case (java/lang/reflect/Field::get #.None field)
- (#try.Success ?value)
- (case ?value
- (#.Some value)
- (#try.Success value)
-
- #.None
- (exception.throw ..invalid-value [class-name]))
-
- (#try.Failure error)
- (exception.throw ..cannot-load [class-name error]))
-
- (#try.Failure error)
- (exception.throw ..invalid-field [class-name ..value::field error])))
-
-(def: class-path-separator ".")
-
-(def: (evaluate! library loader eval-class valueG)
- (-> Library java/lang/ClassLoader Text (Bytecode Any) (Try [Any Definition]))
- (let [bytecode-name (text.replace-all class-path-separator .module-separator eval-class)
- bytecode (class.class version.v6_0
- class.public
- (encoding/name.internal bytecode-name)
- (encoding/name.internal "java.lang.Object") (list)
- (list (field.field ..value::modifier ..value::field ..value::type (row.row)))
- (list (method.method ..init::modifier "<clinit>" ..init::type
- (list)
- (#.Some
- ($_ _.compose
- valueG
- (_.putstatic (type.class bytecode-name (list)) ..value::field ..value::type)
- _.return))))
- (row.row))]
- (io.run (do {! (try.with io.monad)}
- [bytecode (\ ! map (format.run class.writer)
- (io.io bytecode))
- _ (loader.store eval-class bytecode library)
- class (loader.load eval-class loader)
- value (\ io.monad wrap (class-value eval-class class))]
- (wrap [value
- [eval-class bytecode]])))))
-
-(def: (execute! library loader temp-label [class-name class-bytecode])
- (-> Library java/lang/ClassLoader Text Definition (Try Any))
- (io.run (do (try.with io.monad)
- [existing-class? (|> (atom.read library)
- (\ io.monad map (function (_ library)
- (dictionary.key? library class-name)))
- (try.lift io.monad)
- (: (IO (Try Bit))))
- _ (if existing-class?
- (wrap [])
- (loader.store class-name class-bytecode library))]
- (loader.load class-name loader))))
-
-(def: (define! library loader [module name] valueG)
- (-> Library java/lang/ClassLoader Name (Bytecode Any) (Try [Text Any Definition]))
- (let [class-name (format (text.replace-all .module-separator class-path-separator module)
- class-path-separator (name.normalize name)
- "___" (%.nat (text\hash name)))]
- (do try.monad
- [[value definition] (evaluate! library loader class-name valueG)]
- (wrap [class-name value definition]))))
-
-(def: #export host
- (IO //runtime.Host)
- (io (let [library (loader.new-library [])
- loader (loader.memory library)]
- (: //runtime.Host
- (implementation
- (def: (evaluate! temp-label valueG)
- (let [eval-class (|> temp-label name.normalize (text.replace-all " " "$"))]
- (\ try.monad map product.left
- (..evaluate! library loader eval-class valueG))))
-
- (def: execute!
- (..execute! library loader))
-
- (def: define!
- (..define! library loader)))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux
deleted file mode 100644
index 2640f28ce..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux
+++ /dev/null
@@ -1,89 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]]
- [data
- ["." product]
- [number
- ["n" nat]]
- [collection
- ["." list ("#\." functor)]]]
- [target
- [jvm
- ["_" bytecode (#+ Label Bytecode) ("#\." monad)]]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." value]
- [////
- ["." synthesis (#+ Path Synthesis)]
- ["." generation]
- [///
- ["." phase]
- [reference
- [variable (#+ Register)]]]]])
-
-(def: (invariant? register changeS)
- (-> Register Synthesis Bit)
- (case changeS
- (^ (synthesis.variable/local var))
- (n.= register var)
-
- _
- false))
-
-(def: no-op
- (_\wrap []))
-
-(def: #export (recur translate archive updatesS)
- (Generator (List Synthesis))
- (do {! phase.monad}
- [[@begin offset] generation.anchor
- updatesG (|> updatesS
- list.enumeration
- (list\map (function (_ [index updateS])
- [(n.+ offset index) updateS]))
- (monad.map ! (function (_ [register updateS])
- (if (invariant? register updateS)
- (wrap [..no-op
- ..no-op])
- (do !
- [fetchG (translate archive updateS)
- #let [storeG (_.astore register)]]
- (wrap [fetchG storeG]))))))]
- (wrap ($_ _.compose
- ## It may look weird that first I fetch all the values separately,
- ## and then I store them all.
- ## It must be done that way in order to avoid a potential bug.
- ## Let's say that you'll recur with 2 expressions: X and Y.
- ## If Y depends on the value of X, and you don't perform fetches
- ## and stores separately, then by the time Y is evaluated, it
- ## will refer to the new value of X, instead of the old value, as
- ## should be the case.
- (|> updatesG
- (list\map product.left)
- (monad.seq _.monad))
- (|> updatesG
- list.reverse
- (list\map product.right)
- (monad.seq _.monad))
- (_.goto @begin)))))
-
-(def: #export (scope translate archive [offset initsS+ iterationS])
- (Generator [Nat (List Synthesis) Synthesis])
- (do {! phase.monad}
- [@begin //runtime.forge-label
- initsI+ (monad.map ! (translate archive) initsS+)
- iterationG (generation.with-anchor [@begin offset]
- (translate archive iterationS))
- #let [initializationG (|> (list.enumeration initsI+)
- (list\map (function (_ [index initG])
- ($_ _.compose
- initG
- (_.astore (n.+ offset index)))))
- (monad.seq _.monad))]]
- (wrap ($_ _.compose
- initializationG
- (_.set-label @begin)
- iterationG))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux
deleted file mode 100644
index b23d41726..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux
+++ /dev/null
@@ -1,120 +0,0 @@
-(.module:
- [lux (#- i64)
- ["." ffi (#+ import:)]
- [abstract
- [monad (#+ do)]]
- [target
- [jvm
- ["_" bytecode (#+ Bytecode)]
- ["." type]
- [encoding
- ["." signed]]]]]
- ["." // #_
- ["#." runtime]])
-
-(def: $Boolean (type.class "java.lang.Boolean" (list)))
-(def: $Long (type.class "java.lang.Long" (list)))
-(def: $Double (type.class "java.lang.Double" (list)))
-
-(def: #export (bit value)
- (-> Bit (Bytecode Any))
- (_.getstatic $Boolean (if value "TRUE" "FALSE") $Boolean))
-
-(def: wrap-i64
- (_.invokestatic $Long "valueOf" (type.method [(list type.long) $Long (list)])))
-
-(def: #export (i64 value)
- (-> (I64 Any) (Bytecode Any))
- (case (.int value)
- (^template [<int> <instruction>]
- [<int>
- (do _.monad
- [_ <instruction>]
- ..wrap-i64)])
- ([+0 _.lconst-0]
- [+1 _.lconst-1])
-
- (^template [<int> <instruction>]
- [<int>
- (do _.monad
- [_ <instruction>
- _ _.i2l]
- ..wrap-i64)])
- ([-1 _.iconst-m1]
- ## [+0 _.iconst-0]
- ## [+1 _.iconst-1]
- [+2 _.iconst-2]
- [+3 _.iconst-3]
- [+4 _.iconst-4]
- [+5 _.iconst-5])
-
- value
- (case (signed.s1 value)
- (#try.Success value)
- (do _.monad
- [_ (_.bipush value)
- _ _.i2l]
- ..wrap-i64)
-
- (#try.Failure _)
- (case (signed.s2 value)
- (#try.Success value)
- (do _.monad
- [_ (_.sipush value)
- _ _.i2l]
- ..wrap-i64)
-
- (#try.Failure _)
- (do _.monad
- [_ (_.long value)]
- ..wrap-i64)))))
-
-(def: wrap-f64
- (_.invokestatic $Double "valueOf" (type.method [(list type.double) $Double (list)])))
-
-(import: java/lang/Double
- (#static doubleToRawLongBits #manual [double] int))
-
-(def: #export (f64 value)
- (-> Frac (Bytecode Any))
- (case value
- (^template [<int> <instruction>]
- [<int>
- (do _.monad
- [_ <instruction>]
- ..wrap-f64)])
- ([+1.0 _.dconst-1])
-
- (^template [<int> <instruction>]
- [<int>
- (do _.monad
- [_ <instruction>
- _ _.f2d]
- ..wrap-f64)])
- ([+2.0 _.fconst-2])
-
- (^template [<int> <instruction>]
- [<int>
- (do _.monad
- [_ <instruction>
- _ _.i2d]
- ..wrap-f64)])
- ([-1.0 _.iconst-m1]
- ## [+0.0 _.iconst-0]
- ## [+1.0 _.iconst-1]
- [+2.0 _.iconst-2]
- [+3.0 _.iconst-3]
- [+4.0 _.iconst-4]
- [+5.0 _.iconst-5])
-
- _
- (let [constantI (if (i.= ..d0-bits
- (java/lang/Double::doubleToRawLongBits (:as java/lang/Double value)))
- _.dconst-0
- (_.double value))]
- (do _.monad
- [_ constantI]
- ..wrap-f64))))
-
-(def: #export text
- _.string)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux
deleted file mode 100644
index 6166f14c1..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux
+++ /dev/null
@@ -1,143 +0,0 @@
-(.module:
- [lux (#- Definition)
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]]
- [data
- [collection
- ["." row]]
- ["." format #_
- ["#" binary]]]
- [target
- [jvm
- ["_" bytecode (#+ Bytecode)]
- ["." modifier (#+ Modifier) ("#\." monoid)]
- ["." method (#+ Method)]
- ["." version]
- ["." class (#+ Class)]
- [encoding
- ["." name]]
- ["." type
- ["." reflection]]]]]
- ["." //
- ["#." runtime (#+ Definition)]
- ["#." function/abstract]])
-
-(def: #export class "LuxProgram")
-
-(def: ^Object (type.class "java.lang.Object" (list)))
-(def: ^String (type.class "java.lang.String" (list)))
-(def: ^Args (type.array ^String))
-
-(def: main::type (type.method [(list ..^Args) type.void (list)]))
-
-(def: main::modifier
- (Modifier Method)
- ($_ modifier\compose
- method.public
- method.static
- method.strict
- ))
-
-(def: program::modifier
- (Modifier Class)
- ($_ modifier\compose
- class.public
- class.final
- ))
-
-(def: nil //runtime.none-injection)
-
-(def: amount-of-inputs
- (Bytecode Any)
- ($_ _.compose
- _.aload-0
- _.arraylength))
-
-(def: decrease
- (Bytecode Any)
- ($_ _.compose
- _.iconst-1
- _.isub))
-
-(def: head
- (Bytecode Any)
- ($_ _.compose
- _.dup
- _.aload-0
- _.swap
- _.aaload
- _.swap
- _.dup-x2
- _.pop))
-
-(def: pair
- (Bytecode Any)
- ($_ _.compose
- _.iconst-2
- (_.anewarray ^Object)
- _.dup-x1
- _.swap
- _.iconst-0
- _.swap
- _.aastore
- _.dup-x1
- _.swap
- _.iconst-1
- _.swap
- _.aastore))
-
-(def: cons //runtime.right-injection)
-
-(def: input-list
- (Bytecode Any)
- (do _.monad
- [@loop _.new-label
- @end _.new-label]
- ($_ _.compose
- ..nil
- ..amount-of-inputs
- (_.set-label @loop)
- ..decrease
- _.dup
- (_.iflt @end)
- ..head
- ..pair
- ..cons
- _.swap
- (_.goto @loop)
- (_.set-label @end)
- _.pop)))
-
-(def: feed-inputs //runtime.apply)
-
-(def: run-io
- (Bytecode Any)
- ($_ _.compose
- (_.checkcast //function/abstract.class)
- _.aconst-null
- //runtime.apply))
-
-(def: #export (program program)
- (-> (Bytecode Any) Definition)
- (let [super-class (|> ..^Object type.reflection reflection.reflection name.internal)
- main (method.method ..main::modifier "main" ..main::type
- (list)
- (#.Some ($_ _.compose
- program
- ..input-list
- ..feed-inputs
- ..run-io
- _.return)))]
- [..class
- (<| (format.run class.writer)
- try.assume
- (class.class version.v6_0
- ..program::modifier
- (name.internal ..class)
- super-class
- (list)
- (list)
- (list main)
- (row.row)))]))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux
deleted file mode 100644
index edffd87ff..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux
+++ /dev/null
@@ -1,66 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [data
- [text
- ["%" format (#+ format)]]]
- [target
- [jvm
- ["_" bytecode (#+ Bytecode)]
- ["." type]
- [encoding
- ["." unsigned]]]]]
- ["." // #_
- ["#." runtime (#+ Operation)]
- ["#." value]
- ["#." type]
- ["//#" /// #_
- [//
- ["." generation]
- [///
- ["#" phase ("operation\." monad)]
- [reference
- ["." variable (#+ Register Variable)]]
- [meta
- [archive (#+ Archive)]]]]]])
-
-(def: #export this
- (Bytecode Any)
- _.aload-0)
-
-(template [<name> <prefix>]
- [(def: #export <name>
- (-> Register Text)
- (|>> %.nat (format <prefix>)))]
-
- [foreign-name "f"]
- [partial-name "p"]
- )
-
-(def: (foreign archive variable)
- (-> Archive Register (Operation (Bytecode Any)))
- (do {! ////.monad}
- [bytecode-name (\ ! map //runtime.class-name
- (generation.context archive))]
- (wrap ($_ _.compose
- ..this
- (_.getfield (type.class bytecode-name (list))
- (..foreign-name variable)
- //type.value)))))
-
-(def: #export (variable archive variable)
- (-> Archive Variable (Operation (Bytecode Any)))
- (case variable
- (#variable.Local variable)
- (operation\wrap (_.aload variable))
-
- (#variable.Foreign variable)
- (..foreign archive variable)))
-
-(def: #export (constant archive name)
- (-> Archive Name (Operation (Bytecode Any)))
- (do {! ////.monad}
- [bytecode-name (\ ! map //runtime.class-name
- (generation.remember archive name))]
- (wrap (_.getstatic (type.class bytecode-name (list)) //value.field //type.value))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux
deleted file mode 100644
index 1c31c7ed9..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux
+++ /dev/null
@@ -1,610 +0,0 @@
-(.module:
- [lux (#- Type Definition case false true try)
- [abstract
- ["." monad (#+ do)]
- ["." enum]]
- [control
- ["." try]]
- [data
- [binary (#+ Binary)]
- [collection
- ["." list ("#\." functor)]
- ["." row]]
- ["." format #_
- ["#" binary]]
- [text
- ["%" format (#+ format)]]]
- [math
- [number
- ["n" nat]
- ["." i32]
- ["." i64]]]
- [target
- ["." jvm #_
- ["_" bytecode (#+ Label Bytecode)]
- ["." modifier (#+ Modifier) ("#\." monoid)]
- ["." field (#+ Field)]
- ["." method (#+ Method)]
- ["#/." version]
- ["." class (#+ Class)]
- ["." constant
- [pool (#+ Resource)]]
- [encoding
- ["." name]]
- ["." type (#+ Type)
- ["." category (#+ Return' Value')]
- ["." reflection]]]]]
- ["." // #_
- ["#." type]
- ["#." value]
- ["#." function #_
- ["#" abstract]
- [field
- [constant
- ["#/." arity]]
- [variable
- [partial
- ["#/." count]]]]]
- ["//#" /// #_
- [//
- ["." version]
- ["." synthesis]
- ["." generation]
- [///
- ["#" phase]
- [arity (#+ Arity)]
- [reference
- [variable (#+ Register)]]
- [meta
- [io (#+ lux_context)]
- [archive (#+ Archive)]]]]]])
-
-(type: #export Byte_Code Binary)
-
-(type: #export Definition [Text Byte_Code])
-
-(type: #export Anchor [Label Register])
-
-(template [<name> <base>]
- [(type: #export <name>
- (<base> Anchor (Bytecode Any) Definition))]
-
- [Operation generation.Operation]
- [Phase generation.Phase]
- [Handler generation.Handler]
- [Bundle generation.Bundle]
- )
-
-(type: #export (Generator i)
- (-> Phase Archive i (Operation (Bytecode Any))))
-
-(type: #export Host
- (generation.Host (Bytecode Any) Definition))
-
-(def: #export (class_name [module id])
- (-> generation.Context Text)
- (format lux_context
- "/" (%.nat version.version)
- "/" (%.nat module)
- "/" (%.nat id)))
-
-(def: artifact_id
- 0)
-
-(def: #export class
- (type.class (%.nat ..artifact_id) (list)))
-
-(def: procedure
- (-> Text (Type category.Method) (Bytecode Any))
- (_.invokestatic ..class))
-
-(def: modifier
- (Modifier Method)
- ($_ modifier\compose
- method.public
- method.static
- method.strict
- ))
-
-(def: this
- (Bytecode Any)
- _.aload_0)
-
-(def: #export (get index)
- (-> (Bytecode Any) (Bytecode Any))
- ($_ _.compose
- index
- _.aaload))
-
-(def: (set! index value)
- (-> (Bytecode Any) (Bytecode Any) (Bytecode Any))
- ($_ _.compose
- ## A
- _.dup ## AA
- index ## AAI
- value ## AAIV
- _.aastore ## A
- ))
-
-(def: #export unit (_.string synthesis.unit))
-
-(def: variant::name "variant")
-(def: variant::type (type.method [(list //type.tag //type.flag //type.value) //type.variant (list)]))
-(def: #export variant (..procedure ..variant::name ..variant::type))
-
-(def: variant_tag _.iconst_0)
-(def: variant_last? _.iconst_1)
-(def: variant_value _.iconst_2)
-
-(def: variant::method
- (let [new_variant ($_ _.compose
- _.iconst_3
- (_.anewarray //type.value))
- $tag ($_ _.compose
- _.iload_0
- (//value.wrap type.int))
- $last? _.aload_1
- $value _.aload_2]
- (method.method ..modifier ..variant::name
- ..variant::type
- (list)
- (#.Some ($_ _.compose
- new_variant ## A[3]
- (..set! ..variant_tag $tag) ## A[3]
- (..set! ..variant_last? $last?) ## A[3]
- (..set! ..variant_value $value) ## A[3]
- _.areturn)))))
-
-(def: #export left_flag _.aconst_null)
-(def: #export right_flag ..unit)
-
-(def: #export left_injection
- (Bytecode Any)
- ($_ _.compose
- _.iconst_0
- ..left_flag
- _.dup2_x1
- _.pop2
- ..variant))
-
-(def: #export right_injection
- (Bytecode Any)
- ($_ _.compose
- _.iconst_1
- ..right_flag
- _.dup2_x1
- _.pop2
- ..variant))
-
-(def: #export some_injection ..right_injection)
-
-(def: #export none_injection
- (Bytecode Any)
- ($_ _.compose
- _.iconst_0
- ..left_flag
- ..unit
- ..variant))
-
-(def: (risky $unsafe)
- (-> (Bytecode Any) (Bytecode Any))
- (do _.monad
- [@try _.new_label
- @handler _.new_label]
- ($_ _.compose
- (_.try @try @handler @handler //type.error)
- (_.set_label @try)
- $unsafe
- ..some_injection
- _.areturn
- (_.set_label @handler)
- ..none_injection
- _.areturn
- )))
-
-(def: decode_frac::name "decode_frac")
-(def: decode_frac::type (type.method [(list //type.text) //type.variant (list)]))
-(def: #export decode_frac (..procedure ..decode_frac::name ..decode_frac::type))
-
-(def: decode_frac::method
- (method.method ..modifier ..decode_frac::name
- ..decode_frac::type
- (list)
- (#.Some
- (..risky
- ($_ _.compose
- _.aload_0
- (_.invokestatic //type.frac "parseDouble" (type.method [(list //type.text) type.double (list)]))
- (//value.wrap type.double)
- )))))
-
-(def: #export log!
- (Bytecode Any)
- (let [^PrintStream (type.class "java.io.PrintStream" (list))
- ^System (type.class "java.lang.System" (list))
- out (_.getstatic ^System "out" ^PrintStream)
- print_type (type.method [(list //type.value) type.void (list)])
- print! (function (_ method) (_.invokevirtual ^PrintStream method print_type))]
- ($_ _.compose
- out (_.string "LUX LOG: ") (print! "print")
- out _.swap (print! "println"))))
-
-(def: exception_constructor (type.method [(list //type.text) type.void (list)]))
-(def: (illegal_state_exception message)
- (-> Text (Bytecode Any))
- (let [^IllegalStateException (type.class "java.lang.IllegalStateException" (list))]
- ($_ _.compose
- (_.new ^IllegalStateException)
- _.dup
- (_.string message)
- (_.invokespecial ^IllegalStateException "<init>" ..exception_constructor))))
-
-(def: failure::type
- (type.method [(list) type.void (list)]))
-
-(def: (failure name message)
- (-> Text Text (Resource Method))
- (method.method ..modifier name
- ..failure::type
- (list)
- (#.Some
- ($_ _.compose
- (..illegal_state_exception message)
- _.athrow))))
-
-(def: pm_failure::name "pm_failure")
-(def: #export pm_failure (..procedure ..pm_failure::name ..failure::type))
-
-(def: pm_failure::method
- (..failure ..pm_failure::name "Invalid expression for pattern-matching."))
-
-(def: #export stack_head _.iconst_0)
-(def: #export stack_tail _.iconst_1)
-
-(def: push::name "push")
-(def: push::type (type.method [(list //type.stack //type.value) //type.stack (list)]))
-(def: #export push (..procedure ..push::name ..push::type))
-
-(def: push::method
- (method.method ..modifier ..push::name
- ..push::type
- (list)
- (#.Some
- (let [new_stack_frame! ($_ _.compose
- _.iconst_2
- (_.anewarray //type.value))
- $head _.aload_1
- $tail _.aload_0]
- ($_ _.compose
- new_stack_frame!
- (..set! ..stack_head $head)
- (..set! ..stack_tail $tail)
- _.areturn)))))
-
-(def: case::name "case")
-(def: case::type (type.method [(list //type.variant //type.tag //type.flag) //type.value (list)]))
-(def: #export case (..procedure ..case::name ..case::type))
-
-(def: case::method
- (method.method ..modifier ..case::name ..case::type
- (list)
- (#.Some
- (do _.monad
- [@loop _.new_label
- @perfect_match! _.new_label
- @tags_match! _.new_label
- @maybe_nested _.new_label
- @mismatch! _.new_label
- #let [::tag ($_ _.compose
- (..get ..variant_tag)
- (//value.unwrap type.int))
- ::last? (..get ..variant_last?)
- ::value (..get ..variant_value)
-
- $variant _.aload_0
- $tag _.iload_1
- $last? _.aload_2
-
- not_found _.aconst_null
-
- update_$tag _.isub
- update_$variant ($_ _.compose
- $variant ::value
- (_.checkcast //type.variant)
- _.astore_0)
- recur (: (-> Label (Bytecode Any))
- (function (_ @loop_start)
- ($_ _.compose
- ## tag, sumT
- update_$variant ## tag, sumT
- update_$tag ## sub_tag
- (_.goto @loop_start))))
-
- super_nested_tag ($_ _.compose
- ## tag, sumT
- _.swap ## sumT, tag
- _.isub)
- super_nested ($_ _.compose
- ## tag, sumT
- super_nested_tag ## super_tag
- $variant ::last? ## super_tag, super_last
- $variant ::value ## super_tag, super_last, super_value
- ..variant)]]
- ($_ _.compose
- $tag
- (_.set_label @loop)
- $variant ::tag
- _.dup2 (_.if_icmpeq @tags_match!)
- _.dup2 (_.if_icmpgt @maybe_nested)
- $last? (_.ifnull @mismatch!) ## tag, sumT
- super_nested ## super_variant
- _.areturn
- (_.set_label @tags_match!) ## tag, sumT
- $last? ## tag, sumT, wants_last?
- $variant ::last? ## tag, sumT, wants_last?, is_last?
- (_.if_acmpeq @perfect_match!) ## tag, sumT
- (_.set_label @maybe_nested) ## tag, sumT
- $variant ::last? ## tag, sumT, last?
- (_.ifnull @mismatch!) ## tag, sumT
- (recur @loop)
- (_.set_label @perfect_match!) ## tag, sumT
- ## _.pop2
- $variant ::value
- _.areturn
- (_.set_label @mismatch!) ## tag, sumT
- ## _.pop2
- not_found
- _.areturn
- )))))
-
-(def: projection_type (type.method [(list //type.tuple //type.offset) //type.value (list)]))
-
-(def: left_projection::name "left")
-(def: #export left_projection (..procedure ..left_projection::name ..projection_type))
-
-(def: right_projection::name "right")
-(def: #export right_projection (..procedure ..right_projection::name ..projection_type))
-
-(def: projection::method2
- [(Resource Method) (Resource Method)]
- (let [$tuple _.aload_0
- $tuple::size ($_ _.compose
- $tuple _.arraylength)
-
- $lefts _.iload_1
-
- $last_right ($_ _.compose
- $tuple::size _.iconst_1 _.isub)
-
- update_$lefts ($_ _.compose
- $lefts $last_right _.isub
- _.istore_1)
- update_$tuple ($_ _.compose
- $tuple $last_right _.aaload (_.checkcast //type.tuple)
- _.astore_0)
- recur (: (-> Label (Bytecode Any))
- (function (_ @loop)
- ($_ _.compose
- update_$lefts
- update_$tuple
- (_.goto @loop))))
-
- left_projection::method
- (method.method ..modifier ..left_projection::name ..projection_type
- (list)
- (#.Some
- (do _.monad
- [@loop _.new_label
- @recursive _.new_label
- #let [::left ($_ _.compose
- $lefts _.aaload)]]
- ($_ _.compose
- (_.set_label @loop)
- $lefts $last_right (_.if_icmpge @recursive)
- $tuple ::left
- _.areturn
- (_.set_label @recursive)
- ## Recursive
- (recur @loop)))))
-
- right_projection::method
- (method.method ..modifier ..right_projection::name ..projection_type
- (list)
- (#.Some
- (do _.monad
- [@loop _.new_label
- @not_tail _.new_label
- @slice _.new_label
- #let [$right ($_ _.compose
- $lefts
- _.iconst_1
- _.iadd)
- $::nested ($_ _.compose
- $tuple _.swap _.aaload)
- super_nested ($_ _.compose
- $tuple
- $right
- $tuple::size
- (_.invokestatic (type.class "java.util.Arrays" (list)) "copyOfRange"
- (type.method [(list //type.tuple //type.index //type.index) //type.tuple (list)])))]]
- ($_ _.compose
- (_.set_label @loop)
- $last_right $right
- _.dup2 (_.if_icmpne @not_tail)
- ## _.pop
- $::nested
- _.areturn
- (_.set_label @not_tail)
- (_.if_icmpgt @slice)
- ## Must recurse
- (recur @loop)
- (_.set_label @slice)
- super_nested
- _.areturn))))]
- [left_projection::method
- right_projection::method]))
-
-(def: #export apply::name "apply")
-
-(def: #export (apply::type arity)
- (-> Arity (Type category.Method))
- (type.method [(list.repeat arity //type.value) //type.value (list)]))
-
-(def: #export apply
- (_.invokevirtual //function.class ..apply::name (..apply::type 1)))
-
-(def: try::name "try")
-(def: try::type (type.method [(list //function.class) //type.variant (list)]))
-(def: #export try (..procedure ..try::name ..try::type))
-
-(def: false _.iconst_0)
-(def: true _.iconst_1)
-
-(def: try::method
- (method.method ..modifier ..try::name ..try::type
- (list)
- (#.Some
- (do _.monad
- [@try _.new_label
- @handler _.new_label
- #let [$unsafe ..this
- unit _.aconst_null
-
- ^StringWriter (type.class "java.io.StringWriter" (list))
- string_writer ($_ _.compose
- (_.new ^StringWriter)
- _.dup
- (_.invokespecial ^StringWriter "<init>" (type.method [(list) type.void (list)])))
-
- ^PrintWriter (type.class "java.io.PrintWriter" (list))
- print_writer ($_ _.compose
- ## WTW
- (_.new ^PrintWriter) ## WTWP
- _.dup_x1 ## WTPWP
- _.swap ## WTPPW
- ..true ## WTPPWZ
- (_.invokespecial ^PrintWriter "<init>" (type.method [(list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)]))
- ## WTP
- )]]
- ($_ _.compose
- (_.try @try @handler @handler //type.error)
- (_.set_label @try)
- $unsafe unit ..apply
- ..right_injection _.areturn
- (_.set_label @handler) ## T
- string_writer ## TW
- _.dup_x1 ## WTW
- print_writer ## WTP
- (_.invokevirtual //type.error "printStackTrace" (type.method [(list ^PrintWriter) type.void (list)])) ## W
- (_.invokevirtual ^StringWriter "toString" (type.method [(list) //type.text (list)])) ## S
- ..left_injection _.areturn
- )))))
-
-(def: reflection
- (All [category]
- (-> (Type (<| Return' Value' category)) Text))
- (|>> type.reflection reflection.reflection))
-
-(def: ^Object (type.class "java.lang.Object" (list)))
-
-(def: generate_runtime
- (Operation Any)
- (let [class (..reflection ..class)
- modifier (: (Modifier Class)
- ($_ modifier\compose
- class.public
- class.final))
- bytecode (<| (format.run class.writer)
- try.assume
- (class.class jvm/version.v6_0
- modifier
- (name.internal class)
- (name.internal (..reflection ^Object)) (list)
- (list)
- (let [[left_projection::method right_projection::method] projection::method2]
- (list ..decode_frac::method
- ..variant::method
-
- ..pm_failure::method
-
- ..push::method
- ..case::method
- left_projection::method
- right_projection::method
-
- ..try::method))
- (row.row)))]
- (do ////.monad
- [_ (generation.execute! [class bytecode])]
- (generation.save! ..artifact_id [class bytecode]))))
-
-(def: generate_function
- (Operation Any)
- (let [apply::method+ (|> (enum.range n.enum
- (inc //function/arity.minimum)
- //function/arity.maximum)
- (list\map (function (_ arity)
- (method.method method.public ..apply::name (..apply::type arity)
- (list)
- (#.Some
- (let [previous_inputs (|> arity
- list.indices
- (monad.map _.monad _.aload))]
- ($_ _.compose
- previous_inputs
- (_.invokevirtual //function.class ..apply::name (..apply::type (dec arity)))
- (_.checkcast //function.class)
- (_.aload arity)
- (_.invokevirtual //function.class ..apply::name (..apply::type //function/arity.minimum))
- _.areturn))))))
- (list& (method.method (modifier\compose method.public method.abstract)
- ..apply::name (..apply::type //function/arity.minimum)
- (list)
- #.None)))
- <init>::method (method.method method.public "<init>" //function.init
- (list)
- (#.Some
- (let [$partials _.iload_1]
- ($_ _.compose
- ..this
- (_.invokespecial ^Object "<init>" (type.method [(list) type.void (list)]))
- ..this
- $partials
- (_.putfield //function.class //function/count.field //function/count.type)
- _.return))))
- modifier (: (Modifier Class)
- ($_ modifier\compose
- class.public
- class.abstract))
- class (..reflection //function.class)
- partial_count (: (Resource Field)
- (field.field (modifier\compose field.public field.final)
- //function/count.field
- //function/count.type
- (row.row)))
- bytecode (<| (format.run class.writer)
- try.assume
- (class.class jvm/version.v6_0
- modifier
- (name.internal class)
- (name.internal (..reflection ^Object)) (list)
- (list partial_count)
- (list& <init>::method apply::method+)
- (row.row)))]
- (do ////.monad
- [_ (generation.execute! [class bytecode])]
- (generation.save! //function.artifact_id [class bytecode]))))
-
-(def: #export generate
- (Operation Any)
- (do ////.monad
- [_ ..generate_runtime]
- ..generate_function))
-
-(def: #export forge_label
- (Operation Label)
- (let [shift (n./ 4 i64.width)]
- ## This shift is done to avoid the possibility of forged labels
- ## to be in the range of the labels that are generated automatically
- ## during the evaluation of Bytecode expressions.
- (\ ////.monad map (i64.left_shift shift) generation.next)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux
deleted file mode 100644
index b89bbca35..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux
+++ /dev/null
@@ -1,94 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [data
- [number
- ["." i32]]
- [collection
- ["." list]]]
- [target
- [jvm
- ["_" bytecode (#+ Bytecode)]
- ["." type]
- [encoding
- ["." signed]]]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." primitive]
- ["///#" //// #_
- [analysis (#+ Variant Tuple)]
- ["#." synthesis (#+ Synthesis)]
- [///
- ["." phase]]]])
-
-(def: $Object
- (type.class "java.lang.Object" (list)))
-
-(def: #export (tuple generate archive membersS)
- (Generator (Tuple Synthesis))
- (case membersS
- #.Nil
- (\ phase.monad wrap //runtime.unit)
-
- (#.Cons singletonS #.Nil)
- (generate archive singletonS)
-
- _
- (do {! phase.monad}
- [membersI (|> membersS
- list.enumeration
- (monad.map ! (function (_ [idx member])
- (do !
- [memberI (generate archive member)]
- (wrap (do _.monad
- [_ _.dup
- _ (_.int (.i64 idx))
- _ memberI]
- _.aastore))))))]
- (wrap (do {! _.monad}
- [_ (_.int (.i64 (list.size membersS)))
- _ (_.anewarray $Object)]
- (monad.seq ! membersI))))))
-
-(def: #export (tag lefts right?)
- (-> Nat Bit (Bytecode Any))
- (case (if right?
- (.inc lefts)
- lefts)
- 0 _.iconst-0
- 1 _.iconst-1
- 2 _.iconst-2
- 3 _.iconst-3
- 4 _.iconst-4
- 5 _.iconst-5
- tag (case (signed.s1 (.int tag))
- (#try.Success value)
- (_.bipush value)
-
- (#try.Failure _)
- (case (signed.s2 (.int tag))
- (#try.Success value)
- (_.sipush value)
-
- (#try.Failure _)
- (_.int (.i64 tag))))))
-
-(def: #export (flag right?)
- (-> Bit (Bytecode Any))
- (if right?
- //runtime.right-flag
- //runtime.left-flag))
-
-(def: #export (variant generate archive [lefts right? valueS])
- (Generator (Variant Synthesis))
- (do phase.monad
- [valueI (generate archive valueS)]
- (wrap (do _.monad
- [_ (..tag lefts right?)
- _ (..flag right?)
- _ valueI]
- (_.invokestatic //runtime.class "variant"
- (type.method [(list type.int $Object $Object)
- (type.array $Object)
- (list)]))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux
deleted file mode 100644
index 954740d2d..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux
+++ /dev/null
@@ -1,22 +0,0 @@
-(.module:
- [lux #*
- [target
- [jvm
- ["." type]]]])
-
-(def: #export frac (type.class "java.lang.Double" (list)))
-(def: #export text (type.class "java.lang.String" (list)))
-
-(def: #export value (type.class "java.lang.Object" (list)))
-
-(def: #export tag type.int)
-(def: #export flag ..value)
-(def: #export variant (type.array ..value))
-
-(def: #export offset type.int)
-(def: #export index ..offset)
-(def: #export tuple (type.array ..value))
-
-(def: #export stack (type.array ..value))
-
-(def: #export error (type.class "java.lang.Throwable" (list)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux
deleted file mode 100644
index 206af53b8..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux
+++ /dev/null
@@ -1,48 +0,0 @@
-(.module:
- [lux (#- Type type)
- [target
- [jvm
- ["_" bytecode (#+ Bytecode)]
- ["." type (#+ Type) ("#\." equivalence)
- [category (#+ Primitive)]
- ["." box]]]]])
-
-(def: #export field "value")
-
-(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>]
- [(def: (<name> type)
- (-> (Type Primitive) Text)
- (`` (cond (~~ (template [<type> <output>]
- [(type\= <type> type) <output>]
-
- [type.boolean <boolean>]
- [type.byte <byte>]
- [type.short <short>]
- [type.int <int>]
- [type.long <long>]
- [type.float <float>]
- [type.double <double>]
- [type.char <char>]))
- ## else
- (undefined))))]
-
- [primitive-wrapper
- box.boolean box.byte box.short box.int
- box.long box.float box.double box.char]
- [primitive-unwrap
- "booleanValue" "byteValue" "shortValue" "intValue"
- "longValue" "floatValue" "doubleValue" "charValue"]
- )
-
-(def: #export (wrap type)
- (-> (Type Primitive) (Bytecode Any))
- (let [wrapper (type.class (primitive-wrapper type) (list))]
- (_.invokestatic wrapper "valueOf"
- (type.method [(list type) wrapper (list)]))))
-
-(def: #export (unwrap type)
- (-> (Type Primitive) (Bytecode Any))
- (let [wrapper (type.class (primitive-wrapper type) (list))]
- ($_ _.compose
- (_.checkcast wrapper)
- (_.invokevirtual wrapper (primitive-unwrap type) (type.method [(list) type (list)])))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux
deleted file mode 100644
index 3f64c53bf..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux
+++ /dev/null
@@ -1,118 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." exception (#+ exception:)]]
- [target
- ["_" lua]]]
- ["." / #_
- [runtime (#+ Phase Phase!)]
- ["#." primitive]
- ["#." structure]
- ["#." reference]
- ["#." case]
- ["#." loop]
- ["#." function]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- ["#." extension]
- ["/#" // #_
- [analysis (#+)]
- ["." synthesis]
- ["//#" /// #_
- ["#." phase ("#\." monad)]
- [reference (#+)
- [variable (#+)]]]]]]])
-
-(def: (statement expression archive synthesis)
- Phase!
- (case synthesis
- (^template [<tag>]
- [(^ (<tag> value))
- (//////phase\map _.return (expression archive synthesis))])
- ([synthesis.bit]
- [synthesis.i64]
- [synthesis.f64]
- [synthesis.text]
- [synthesis.variant]
- [synthesis.tuple]
- [#synthesis.Reference]
- [synthesis.branch/get]
- [synthesis.function/apply]
- [#synthesis.Extension])
-
- (^ (synthesis.branch/case case))
- (/case.case! statement expression archive case)
-
- (^ (synthesis.branch/let let))
- (/case.let! statement expression archive let)
-
- (^ (synthesis.branch/if if))
- (/case.if! statement expression archive if)
-
- (^ (synthesis.loop/scope scope))
- (do //////phase.monad
- [[inits scope!] (/loop.scope! statement expression archive false scope)]
- (wrap scope!))
-
- (^ (synthesis.loop/recur updates))
- (/loop.recur! statement expression archive updates)
-
- (^ (synthesis.function/abstraction abstraction))
- (//////phase\map _.return (/function.function statement expression archive abstraction))
- ))
-
-(exception: #export cannot-recur-as-an-expression)
-
-(def: (expression archive synthesis)
- Phase
- (case synthesis
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (//////phase\wrap (<generator> value))])
- ([synthesis.bit /primitive.bit]
- [synthesis.i64 /primitive.i64]
- [synthesis.f64 /primitive.f64]
- [synthesis.text /primitive.text])
-
- (^ (synthesis.variant variantS))
- (/structure.variant expression archive variantS)
-
- (^ (synthesis.tuple members))
- (/structure.tuple expression archive members)
-
- (#synthesis.Reference value)
- (//reference.reference /reference.system archive value)
-
- (^ (synthesis.branch/case case))
- (/case.case ..statement expression archive case)
-
- (^ (synthesis.branch/let let))
- (/case.let expression archive let)
-
- (^ (synthesis.branch/if if))
- (/case.if expression archive if)
-
- (^ (synthesis.branch/get get))
- (/case.get expression archive get)
-
- (^ (synthesis.loop/scope scope))
- (/loop.scope ..statement expression archive scope)
-
- (^ (synthesis.loop/recur updates))
- (//////phase.throw ..cannot-recur-as-an-expression [])
-
- (^ (synthesis.function/abstraction abstraction))
- (/function.function ..statement expression archive abstraction)
-
- (^ (synthesis.function/apply application))
- (/function.apply expression archive application)
-
- (#synthesis.Extension extension)
- (///extension.apply archive expression extension)))
-
-(def: #export generate
- Phase
- ..expression)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux
deleted file mode 100644
index 6a2101fe3..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux
+++ /dev/null
@@ -1,279 +0,0 @@
-(.module:
- [lux (#- case let if)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." set]]]
- [target
- ["_" lua (#+ Expression Var Statement)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Phase! Generator Generator!)]
- ["#." reference]
- ["#." primitive]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- ["#." synthesis #_
- ["#/." case]]
- ["/#" // #_
- ["#." synthesis (#+ Member Synthesis Path)]
- ["#." generation]
- ["//#" /// #_
- [reference
- ["#." variable (#+ Register)]]
- ["#." phase ("#\." monad)]
- [meta
- [archive (#+ Archive)]]]]]]])
-
-(def: #export register
- (-> Register Var)
- (|>> (///reference.local //reference.system) :assume))
-
-(def: #export capture
- (-> Register Var)
- (|>> (///reference.foreign //reference.system) :assume))
-
-(def: #export (let expression archive [valueS register bodyS])
- (Generator [Synthesis Register Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)
- bodyO (expression archive bodyS)]
- ## TODO: Find some way to do 'let' without paying the price of the closure.
- (wrap (|> bodyO
- _.return
- (_.closure (list (..register register)))
- (_.apply/* (list valueO))))))
-
-(def: #export (let! statement expression archive [valueS register bodyS])
- (Generator! [Synthesis Register Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)
- bodyO (statement expression archive bodyS)]
- (wrap ($_ _.then
- (_.local/1 (..register register) valueO)
- bodyO))))
-
-(def: #export (get expression archive [pathP valueS])
- (Generator [(List Member) Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)]
- (wrap (list\fold (function (_ side source)
- (.let [method (.case side
- (^template [<side> <accessor>]
- [(<side> lefts)
- (<accessor> (_.int (.int lefts)))])
- ([#.Left //runtime.tuple//left]
- [#.Right //runtime.tuple//right]))]
- (method source)))
- valueO
- (list.reverse pathP)))))
-
-(def: #export (if expression archive [testS thenS elseS])
- (Generator [Synthesis Synthesis Synthesis])
- (do ///////phase.monad
- [testO (expression archive testS)
- thenO (expression archive thenS)
- elseO (expression archive elseS)]
- (wrap (|> (_.if testO
- (_.return thenO)
- (_.return elseO))
- (_.closure (list))
- (_.apply/* (list))))))
-
-(def: #export (if! statement expression archive [testS thenS elseS])
- (Generator! [Synthesis Synthesis Synthesis])
- (do ///////phase.monad
- [testO (expression archive testS)
- thenO (statement expression archive thenS)
- elseO (statement expression archive elseS)]
- (wrap (_.if testO
- thenO
- elseO))))
-
-(def: @savepoint (_.var "lux_pm_savepoint"))
-(def: @cursor (_.var "lux_pm_cursor"))
-(def: @temp (_.var "lux_pm_temp"))
-
-(def: (push! value)
- (-> Expression Statement)
- (_.statement (|> (_.var "table.insert") (_.apply/* (list @cursor value)))))
-
-(def: peek_and_pop
- Expression
- (|> (_.var "table.remove") (_.apply/* (list @cursor))))
-
-(def: pop!
- Statement
- (_.statement ..peek_and_pop))
-
-(def: peek
- Expression
- (_.nth (_.length @cursor) @cursor))
-
-(def: save!
- Statement
- (_.statement (|> (_.var "table.insert")
- (_.apply/* (list @savepoint
- (_.apply/* (list @cursor
- (_.int +1)
- (_.length @cursor)
- (_.int +1)
- (_.table (list)))
- (_.var "table.move")))))))
-
-(def: restore!
- Statement
- (_.set (list @cursor) (|> (_.var "table.remove") (_.apply/* (list @savepoint)))))
-
-(def: fail! _.break)
-
-(template [<name> <flag> <prep>]
- [(def: (<name> simple? idx)
- (-> Bit Nat Statement)
- ($_ _.then
- (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>)))
- (.if simple?
- (_.when (_.= _.nil @temp)
- fail!)
- (_.if (_.= _.nil @temp)
- fail!
- (..push! @temp)))))]
-
- [left_choice _.nil (<|)]
- [right_choice (_.string "") inc]
- )
-
-(def: (alternation pre! post!)
- (-> Statement Statement Statement)
- ($_ _.then
- (_.while (_.bool true)
- ($_ _.then
- ..save!
- pre!))
- ($_ _.then
- ..restore!
- post!)))
-
-(def: (pattern_matching' statement expression archive)
- (-> Phase! Phase Archive Path (Operation Statement))
- (function (recur pathP)
- (.case pathP
- (#/////synthesis.Then bodyS)
- (statement expression archive bodyS)
-
- #/////synthesis.Pop
- (///////phase\wrap ..pop!)
-
- (#/////synthesis.Bind register)
- (///////phase\wrap (_.local/1 (..register register) ..peek))
-
- (#/////synthesis.Bit_Fork when thenP elseP)
- (do {! ///////phase.monad}
- [then! (recur thenP)
- else! (.case elseP
- (#.Some elseP)
- (recur elseP)
-
- #.None
- (wrap ..fail!))]
- (wrap (.if when
- (_.if ..peek
- then!
- else!)
- (_.if ..peek
- else!
- then!))))
-
- (^template [<tag> <format>]
- [(<tag> cons)
- (do {! ///////phase.monad}
- [clauses (monad.map ! (function (_ [match then])
- (do !
- [then! (recur then)]
- (wrap [(_.= (|> match <format>)
- ..peek)
- then!])))
- (#.Cons cons))]
- (wrap (_.cond clauses ..fail!)))])
- ([#/////synthesis.I64_Fork (<| _.int .int)]
- [#/////synthesis.F64_Fork _.float]
- [#/////synthesis.Text_Fork _.string])
-
- (^template [<complex> <simple> <choice>]
- [(^ (<complex> idx))
- (///////phase\wrap (<choice> false idx))
-
- (^ (<simple> idx nextP))
- (///////phase\map (_.then (<choice> true idx)) (recur nextP))])
- ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice]
- [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice])
-
- (^ (/////synthesis.member/left 0))
- (///////phase\wrap (|> ..peek (_.nth (_.int +1)) ..push!))
-
- (^template [<pm> <getter>]
- [(^ (<pm> lefts))
- (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))])
- ([/////synthesis.member/left //runtime.tuple//left]
- [/////synthesis.member/right //runtime.tuple//right])
-
- (^ (/////synthesis.!bind_top register thenP))
- (do ///////phase.monad
- [then! (recur thenP)]
- (///////phase\wrap ($_ _.then
- (_.local/1 (..register register) ..peek_and_pop)
- then!)))
-
- (^template [<tag> <combinator>]
- [(^ (<tag> preP postP))
- (do ///////phase.monad
- [pre! (recur preP)
- post! (recur postP)]
- (wrap (<combinator> pre! post!)))])
- ([/////synthesis.path/seq _.then]
- [/////synthesis.path/alt ..alternation]))))
-
-(def: (pattern_matching statement expression archive pathP)
- (-> Phase! Phase Archive Path (Operation Statement))
- (do ///////phase.monad
- [pattern_matching! (pattern_matching' statement expression archive pathP)]
- (wrap ($_ _.then
- (_.while (_.bool true)
- pattern_matching!)
- (_.statement (|> (_.var "error") (_.apply/* (list (_.string ////synthesis/case.pattern_matching_error)))))))))
-
-(def: #export dependencies
- (-> Path (List Var))
- (|>> ////synthesis/case.storage
- (get@ #////synthesis/case.dependencies)
- set.to_list
- (list\map (function (_ variable)
- (.case variable
- (#///////variable.Local register)
- (..register register)
-
- (#///////variable.Foreign register)
- (..capture register))))))
-
-(def: #export (case! statement expression archive [valueS pathP])
- (Generator! [Synthesis Path])
- (do ///////phase.monad
- [stack_init (expression archive valueS)
- pattern_matching! (pattern_matching statement expression archive pathP)]
- (wrap ($_ _.then
- (_.local (list @temp))
- (_.local/1 @cursor (_.array (list stack_init)))
- (_.local/1 @savepoint (_.array (list)))
- pattern_matching!))))
-
-(def: #export (case statement expression archive [valueS pathP])
- (-> Phase! (Generator [Synthesis Path]))
- (|> [valueS pathP]
- (..case! statement expression archive)
- (\ ///////phase.monad map
- (|>> (_.closure (list))
- (_.apply/* (list))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux
deleted file mode 100644
index 55490d3f2..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux
+++ /dev/null
@@ -1,136 +0,0 @@
-(.module:
- [lux (#- function)
- [abstract
- ["." monad (#+ do)]]
- [control
- pipe]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [target
- ["_" lua (#+ Var Expression Label Statement)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Phase! Generator)]
- ["#." reference]
- ["#." case]
- ["/#" // #_
- ["#." reference]
- ["//#" /// #_
- [analysis (#+ Variant Tuple Abstraction Application Analysis)]
- [synthesis (#+ Synthesis)]
- ["#." generation (#+ Context)]
- ["//#" /// #_
- [arity (#+ Arity)]
- ["#." phase ("#\." monad)]
- [reference
- [variable (#+ Register Variable)]]]]]])
-
-(def: #export (apply expression archive [functionS argsS+])
- (Generator (Application Synthesis))
- (do {! ///////phase.monad}
- [functionO (expression archive functionS)
- argsO+ (monad.map ! (expression archive) argsS+)]
- (wrap (_.apply/* argsO+ functionO))))
-
-(def: capture
- (-> Register Var)
- (|>> (///reference.foreign //reference.system) :assume))
-
-(def: (with_closure inits @self @args body!)
- (-> (List Expression) Var (List Var) Statement [Statement Expression])
- (case inits
- #.Nil
- [(_.function @self @args body!)
- @self]
-
- _
- (let [@inits (|> (list.enumeration inits)
- (list\map (|>> product.left ..capture)))]
- [(_.function @self @inits
- ($_ _.then
- (_.local_function @self @args body!)
- (_.return @self)))
- (_.apply/* inits @self)])))
-
-(def: input
- (|>> inc //case.register))
-
-(def: (@scope function_name)
- (-> Context Label)
- (_.label (format (///reference.artifact function_name) "_scope")))
-
-(def: #export (function statement expression archive [environment arity bodyS])
- (-> Phase! (Generator (Abstraction Synthesis)))
- (do {! ///////phase.monad}
- [[function_name body!] (/////generation.with_new_context archive
- (do !
- [@scope (\ ! map ..@scope
- (/////generation.context archive))]
- (/////generation.with_anchor [1 @scope]
- (statement expression archive bodyS))))
- closureO+ (monad.map ! (expression archive) environment)
- #let [@curried (_.var "curried")
- arityO (|> arity .int _.int)
- @num_args (_.var "num_args")
- @scope (..@scope function_name)
- @self (_.var (///reference.artifact function_name))
- initialize_self! (_.local/1 (//case.register 0) @self)
- initialize! (list\fold (.function (_ post pre!)
- ($_ _.then
- pre!
- (_.local/1 (..input post) (_.nth (|> post inc .int _.int) @curried))))
- initialize_self!
- (list.indices arity))
- pack (|>> (list) _.array)
- unpack (_.apply/1 (_.var "table.unpack"))
- @var_args (_.var "...")]
- #let [[definition instantiation] (with_closure closureO+ @self (list @var_args)
- ($_ _.then
- (_.local/1 @curried (pack @var_args))
- (_.local/1 @num_args (_.length @curried))
- (_.cond (list [(|> @num_args (_.= arityO))
- ($_ _.then
- initialize!
- (_.set_label @scope)
- body!)]
- [(|> @num_args (_.> arityO))
- (let [arity_inputs (_.apply/5 (_.var "table.move")
- @curried
- (_.int +1)
- arityO
- (_.int +1)
- (_.array (list)))
- extra_inputs (_.apply/5 (_.var "table.move")
- @curried
- (_.+ (_.int +1) arityO)
- @num_args
- (_.int +1)
- (_.array (list)))]
- (_.return (|> @self
- (_.apply/* (list (unpack arity_inputs)))
- (_.apply/* (list (unpack extra_inputs))))))])
- ## (|> @num_args (_.< arityO))
- (_.return (_.closure (list @var_args)
- (let [@extra_args (_.var "extra_args")]
- ($_ _.then
- (_.local/1 @extra_args (pack @var_args))
- (_.return (|> (_.array (list))
- (_.apply/5 (_.var "table.move")
- @curried
- (_.int +1)
- @num_args
- (_.int +1))
- (_.apply/5 (_.var "table.move")
- @extra_args
- (_.int +1)
- (_.length @extra_args)
- (_.+ (_.int +1) @num_args))
- unpack
- (_.apply/1 @self))))))))
- ))]
- _ (/////generation.execute! definition)
- _ (/////generation.save! (product.right function_name) definition)]
- (wrap instantiation)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux
deleted file mode 100644
index e95fc0f49..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux
+++ /dev/null
@@ -1,118 +0,0 @@
-(.module:
- [lux (#- Scope)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]
- ["." set]]]
- [math
- [number
- ["n" nat]]]
- [target
- ["_" lua (#+ Var Expression Label Statement)]]]
- ["." // #_
- [runtime (#+ Operation Phase Phase! Generator Generator!)]
- ["#." case]
- ["/#" // #_
- ["#." reference]
- ["//#" /// #_
- ["."synthesis (#+ Scope Synthesis)]
- ["#." generation]
- ["//#" /// #_
- ["#." phase]
- [meta
- [archive (#+ Archive)]]
- [reference
- [variable (#+ Register)]]]]]])
-
-(def: @scope
- (-> Nat Label)
- (|>> %.nat (format "scope") _.label))
-
-(def: (setup initial? offset bindings as_expression? body)
- (-> Bit Register (List Expression) Bit Statement Statement)
- (let [variables (|> bindings
- list.enumeration
- (list\map (|>> product.left (n.+ offset) //case.register)))]
- (if as_expression?
- body
- ($_ _.then
- (if initial?
- (_.let variables (_.multi bindings))
- (_.set variables (_.multi bindings)))
- body))))
-
-(def: #export (scope! statement expression archive as_expression? [start initsS+ bodyS])
- ## (Generator! (Scope Synthesis))
- (-> Phase! Phase Archive Bit (Scope Synthesis)
- (Operation [(List Expression) Statement]))
- (case initsS+
- ## function/false/non-independent loop
- #.Nil
- (|> bodyS
- (statement expression archive)
- (\ ///////phase.monad map (|>> [(list)])))
-
- ## true loop
- _
- (do {! ///////phase.monad}
- [@scope (\ ! map ..@scope /////generation.next)
- initsO+ (monad.map ! (expression archive) initsS+)
- body! (/////generation.with_anchor [start @scope]
- (statement expression archive bodyS))]
- (wrap [initsO+
- (..setup true start initsO+ as_expression?
- ($_ _.then
- (_.set_label @scope)
- body!))]))))
-
-(def: #export (scope statement expression archive [start initsS+ bodyS])
- (-> Phase! (Generator (Scope Synthesis)))
- (case initsS+
- ## function/false/non-independent loop
- #.Nil
- (expression archive bodyS)
-
- ## true loop
- _
- (do {! ///////phase.monad}
- [[[artifact_module artifact_id] [initsO+ scope!]] (/////generation.with_new_context archive
- (scope! statement expression archive true [start initsS+ bodyS]))
- #let [@loop (_.var (///reference.artifact [artifact_module artifact_id]))
- locals (|> initsO+
- list.enumeration
- (list\map (|>> product.left (n.+ start) //case.register)))
- [directive instantiation] (: [Statement Expression]
- (case (|> (synthesis.path/then bodyS)
- //case.dependencies
- (set.from_list _.hash)
- (set.difference (set.from_list _.hash locals))
- set.to_list)
- #.Nil
- [(_.function @loop locals
- scope!)
- @loop]
-
- foreigns
- (let [@context (_.var (format (_.code @loop) "_context"))]
- [(_.function @context foreigns
- ($_ _.then
- (<| (_.local_function @loop locals)
- scope!)
- (_.return @loop)
- ))
- (|> @context (_.apply/* foreigns))])))]
- _ (/////generation.execute! directive)
- _ (/////generation.save! artifact_id directive)]
- (wrap (|> instantiation (_.apply/* initsO+))))))
-
-(def: #export (recur! statement expression archive argsS+)
- (Generator! (List Synthesis))
- (do {! ///////phase.monad}
- [[offset @scope] /////generation.anchor
- argsO+ (monad.map ! (expression archive) argsS+)]
- (wrap (..setup false offset argsO+ false (_.go_to @scope)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux
deleted file mode 100644
index 6cce70f05..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux
+++ /dev/null
@@ -1,15 +0,0 @@
-(.module:
- [lux (#- i64)
- [target
- ["_" lua (#+ Literal)]]])
-
-(template [<name> <type> <implementation>]
- [(def: #export <name>
- (-> <type> Literal)
- <implementation>)]
-
- [bit Bit _.bool]
- [i64 (I64 Any) (|>> .int _.int)]
- [f64 Frac _.float]
- [text Text _.string]
- )
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux
deleted file mode 100644
index 72a54569c..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux
+++ /dev/null
@@ -1,12 +0,0 @@
-(.module:
- [lux #*
- [target
- ["_" lua (#+ Expression)]]]
- [///
- [reference (#+ System)]])
-
-(implementation: #export system
- (System Expression)
-
- (def: constant _.var)
- (def: variable _.var))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux
deleted file mode 100644
index 0da87ff6a..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux
+++ /dev/null
@@ -1,431 +0,0 @@
-(.module:
- [lux (#- Location inc)
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<.>" code]]]
- [data
- ["." product]
- ["." text ("#\." hash)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." list ("#\." functor)]
- ["." row]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number (#+ hex)
- ["." i64]]]
- ["@" target
- ["_" lua (#+ Expression Location Var Computation Literal Label Statement)]]]
- ["." /// #_
- ["#." reference]
- ["//#" /// #_
- ["#." synthesis (#+ Synthesis)]
- ["#." generation]
- ["//#" ///
- ["#." phase]
- [reference
- [variable (#+ Register)]]
- [meta
- [archive (#+ Output Archive)
- ["." artifact (#+ Registry)]]]]]])
-
-(template [<name> <base>]
- [(type: #export <name>
- (<base> [Register Label] Expression Statement))]
-
- [Operation /////generation.Operation]
- [Phase /////generation.Phase]
- [Handler /////generation.Handler]
- [Bundle /////generation.Bundle]
- )
-
-(type: #export (Generator i)
- (-> Phase Archive i (Operation Expression)))
-
-(type: #export Phase!
- (-> Phase Archive Synthesis (Operation Statement)))
-
-(type: #export (Generator! i)
- (-> Phase! Phase Archive i (Operation Statement)))
-
-(def: #export unit
- (_.string /////synthesis.unit))
-
-(def: (flag value)
- (-> Bit Literal)
- (if value
- ..unit
- _.nil))
-
-(def: #export variant_tag_field "_lux_tag")
-(def: #export variant_flag_field "_lux_flag")
-(def: #export variant_value_field "_lux_value")
-
-(def: (variant' tag last? value)
- (-> Expression Expression Expression Literal)
- (_.table (list [..variant_tag_field tag]
- [..variant_flag_field last?]
- [..variant_value_field value])))
-
-(def: #export (variant tag last? value)
- (-> Nat Bit Expression Literal)
- (variant' (_.int (.int tag))
- (flag last?)
- value))
-
-(def: #export none
- Literal
- (..variant 0 #0 ..unit))
-
-(def: #export some
- (-> Expression Literal)
- (..variant 1 #1))
-
-(def: #export left
- (-> Expression Literal)
- (..variant 0 #0))
-
-(def: #export right
- (-> Expression Literal)
- (..variant 1 #1))
-
-(def: (feature name definition)
- (-> Var (-> Var Statement) Statement)
- (definition name))
-
-(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
- body)
- (do {! meta.monad}
- [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
- (wrap (list (` (let [(~+ (|> vars
- (list.zip/2 ids)
- (list\map (function (_ [id var])
- (list (code.local_identifier var)
- (` (_.var (~ (code.text (format "v" (%.nat id)))))))))
- list.concat))]
- (~ body)))))))
-
-(def: module_id
- 0)
-
-(syntax: (runtime: {declaration (<>.or <code>.local_identifier
- (<code>.form (<>.and <code>.local_identifier
- (<>.some <code>.local_identifier))))}
- code)
- (do meta.monad
- [runtime_id meta.count]
- (macro.with_gensyms [g!_]
- (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id]))
- runtime_name (` (_.var (~ (code.text (%.code runtime)))))]
- (case declaration
- (#.Left name)
- (macro.with_gensyms [g!_]
- (let [g!name (code.local_identifier name)]
- (wrap (list (` (def: #export (~ g!name)
- Var
- (~ runtime_name)))
-
- (` (def: (~ (code.local_identifier (format "@" name)))
- Statement
- (..feature (~ runtime_name)
- (function ((~ g!_) (~ g!name))
- (_.set (~ g!name) (~ code))))))))))
-
- (#.Right [name inputs])
- (macro.with_gensyms [g!_]
- (let [g!name (code.local_identifier name)
- inputsC (list\map code.local_identifier inputs)
- inputs_typesC (list\map (function.constant (` _.Expression))
- inputs)]
- (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
- (-> (~+ inputs_typesC) Computation)
- (_.apply/* (list (~+ inputsC)) (~ runtime_name))))
-
- (` (def: (~ (code.local_identifier (format "@" name)))
- Statement
- (..feature (~ runtime_name)
- (function ((~ g!_) (~ g!_))
- (..with_vars [(~+ inputsC)]
- (_.function (~ g!_) (list (~+ inputsC))
- (~ code))))))))))))))))
-
-(def: (nth index table)
- (-> Expression Expression Location)
- (_.nth (_.+ (_.int +1) index) table))
-
-(def: last_index
- (|>> _.length (_.- (_.int +1))))
-
-(with_expansions [<recur> (as_is ($_ _.then
- (_.set (list lefts) (_.- last_index_right lefts))
- (_.set (list tuple) (..nth last_index_right tuple))))]
- (runtime: (tuple//left lefts tuple)
- (with_vars [last_index_right]
- (<| (_.while (_.bool true))
- ($_ _.then
- (_.local/1 last_index_right (..last_index tuple))
- (_.if (_.> lefts last_index_right)
- ## No need for recursion
- (_.return (..nth lefts tuple))
- ## Needs recursion
- <recur>)))))
-
- (runtime: (tuple//right lefts tuple)
- (with_vars [last_index_right right_index]
- (<| (_.while (_.bool true))
- ($_ _.then
- (_.local/1 last_index_right (..last_index tuple))
- (_.local/1 right_index (_.+ (_.int +1) lefts))
- (_.cond (list [(_.= last_index_right right_index)
- (_.return (..nth right_index tuple))]
- [(_.> last_index_right right_index)
- ## Needs recursion.
- <recur>])
- (_.return (_.apply/* (list tuple
- (_.+ (_.int +1) right_index)
- (_.length tuple)
- (_.int +1)
- (_.array (list)))
- (_.var "table.move"))))
- )))))
-
-(runtime: (sum//get sum wants_last wanted_tag)
- (let [no_match! (_.return _.nil)
- sum_tag (_.the ..variant_tag_field sum)
- sum_flag (_.the ..variant_flag_field sum)
- sum_value (_.the ..variant_value_field sum)
- is_last? (_.= ..unit sum_flag)
- extact_match! (_.return sum_value)
- test_recursion! (_.if is_last?
- ## Must recurse.
- ($_ _.then
- (_.set (list wanted_tag) (_.- sum_tag wanted_tag))
- (_.set (list sum) sum_value))
- no_match!)
- extrac_sub_variant! (_.return (variant' (_.- wanted_tag sum_tag) sum_flag sum_value))]
- (<| (_.while (_.bool true))
- (_.cond (list [(_.= sum_tag wanted_tag)
- (_.if (_.= wants_last sum_flag)
- extact_match!
- test_recursion!)]
- [(_.< wanted_tag sum_tag)
- test_recursion!]
- [(_.= ..unit wants_last)
- extrac_sub_variant!])
- no_match!))))
-
-(def: runtime//adt
- Statement
- ($_ _.then
- @tuple//left
- @tuple//right
- @sum//get
- ))
-
-(runtime: (lux//try risky)
- (with_vars [success value]
- ($_ _.then
- (_.let (list success value) (|> risky (_.apply/* (list ..unit))
- _.return (_.closure (list))
- list _.apply/* (|> (_.var "pcall"))))
- (_.if success
- (_.return (..right value))
- (_.return (..left value))))))
-
-(runtime: (lux//program_args raw)
- (with_vars [tail head idx]
- ($_ _.then
- (_.let (list tail) ..none)
- (<| (_.for_step idx (_.length raw) (_.int +1) (_.int -1))
- (_.set (list tail) (..some (_.array (list (_.nth idx raw)
- tail)))))
- (_.return tail))))
-
-(def: runtime//lux
- Statement
- ($_ _.then
- @lux//try
- @lux//program_args
- ))
-
-(def: cap_shift
- (_.% (_.int +64)))
-
-(runtime: (i64//left_shift param subject)
- (_.return (_.bit_shl (..cap_shift param) subject)))
-
-(runtime: (i64//right_shift param subject)
- (let [mask (|> (_.int +1)
- (_.bit_shl (_.- param (_.int +64)))
- (_.- (_.int +1)))]
- ($_ _.then
- (_.set (list param) (..cap_shift param))
- (_.return (|> subject
- (_.bit_shr param)
- (_.bit_and mask))))))
-
-(runtime: (i64//division param subject)
- (with_vars [floored]
- ($_ _.then
- (_.local/1 floored (_.// param subject))
- (let [potentially_floored? (_.< (_.int +0) floored)
- inexact? (|> subject
- (_.% param)
- (_.= (_.int +0))
- _.not)]
- (_.if (_.and potentially_floored?
- inexact?)
- (_.return (_.+ (_.int +1) floored))
- (_.return floored))))))
-
-(runtime: (i64//remainder param subject)
- (_.return (_.- (|> subject (..i64//division param) (_.* param))
- subject)))
-
-(def: runtime//i64
- Statement
- ($_ _.then
- @i64//left_shift
- @i64//right_shift
- @i64//division
- @i64//remainder
- ))
-
-(def: (find_byte_index subject param start)
- (-> Expression Expression Expression Expression)
- (_.apply/4 (_.var "string.find") subject param start (_.bool #1)))
-
-(def: (char_index subject byte_index)
- (-> Expression Expression Expression)
- (|> byte_index
- (_.apply/3 (_.var "utf8.len") subject (_.int +1))))
-
-(def: (byte_index subject char_index)
- (-> Expression Expression Expression)
- (|> char_index
- (_.+ (_.int +1))
- (_.apply/2 (_.var "utf8.offset") subject)))
-
-(def: lux_index
- (-> Expression Expression)
- (_.- (_.int +1)))
-
-## TODO: Remove this once the Lua compiler becomes self-hosted.
-(def: on_rembulan?
- (_.= (_.string "Lua 5.3")
- (_.var "_VERSION")))
-
-(runtime: (text//index subject param start)
- (with_expansions [<rembulan> ($_ _.then
- (_.local/1 byte_index (|> start
- (_.+ (_.int +1))
- (..find_byte_index subject param)))
- (_.if (_.= _.nil byte_index)
- (_.return ..none)
- (_.return (..some (..lux_index byte_index)))))
- <normal> ($_ _.then
- (_.local/1 byte_index (|> start
- (..byte_index subject)
- (..find_byte_index subject param)))
- (_.if (_.= _.nil byte_index)
- (_.return ..none)
- (_.return (..some (|> byte_index
- (..char_index subject)
- ..lux_index)))))]
- (with_vars [byte_index]
- (for {@.lua <normal>}
- (_.if ..on_rembulan?
- <rembulan>
- <normal>)))))
-
-(runtime: (text//clip text offset length)
- (with_expansions [<rembulan> (_.return (_.apply/3 (_.var "string.sub") text (_.+ (_.int +1) offset) (_.+ offset length)))
- <normal> (_.return (_.apply/3 (_.var "string.sub")
- text
- (..byte_index text offset)
- (|> (_.+ offset length)
- ## (_.+ (_.int +1))
- (..byte_index text)
- (_.- (_.int +1)))))]
- (for {@.lua <normal>}
- (_.if ..on_rembulan?
- <rembulan>
- <normal>))))
-
-(runtime: (text//size subject)
- (with_expansions [<rembulan> (_.return (_.apply/1 (_.var "string.len") subject))
- <normal> (_.return (_.apply/1 (_.var "utf8.len") subject))]
- (for {@.lua <normal>}
- (_.if ..on_rembulan?
- <rembulan>
- <normal>))))
-
-(runtime: (text//char idx text)
- (with_expansions [<rembulan> (with_vars [char]
- ($_ _.then
- (_.local/1 char (_.apply/* (list text idx)
- (_.var "string.byte")))
- (_.if (_.= _.nil char)
- (_.statement (_.error/1 (_.string "[Lux Error] Cannot get char from text.")))
- (_.return char))))
- <normal> (with_vars [offset char]
- ($_ _.then
- (_.local/1 offset (_.apply/2 (_.var "utf8.offset") text idx))
- (_.if (_.= _.nil offset)
- (_.statement (_.error/1 (_.string "[Lux Error] Cannot get char from text.")))
- (_.return (_.apply/2 (_.var "utf8.codepoint") text offset)))))]
- (for {@.lua <normal>}
- (_.if ..on_rembulan?
- <rembulan>
- <normal>))))
-
-(def: runtime//text
- Statement
- ($_ _.then
- @text//index
- @text//clip
- @text//size
- @text//char
- ))
-
-(runtime: (array//write idx value array)
- ($_ _.then
- (_.set (list (..nth idx array)) value)
- (_.return array)))
-
-(def: runtime//array
- Statement
- ($_ _.then
- @array//write
- ))
-
-(def: runtime
- Statement
- ($_ _.then
- ..runtime//adt
- ..runtime//lux
- ..runtime//i64
- ..runtime//text
- ..runtime//array
- ))
-
-(def: #export generate
- (Operation [Registry Output])
- (do ///////phase.monad
- [_ (/////generation.execute! ..runtime)
- _ (/////generation.save! ..module_id ..runtime)]
- (wrap [(|> artifact.empty
- artifact.resource
- product.right)
- (row.row [..module_id
- (|> ..runtime
- _.code
- (\ utf8.codec encode))])])))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux
deleted file mode 100644
index 0d96fe6df..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux
+++ /dev/null
@@ -1,36 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [target
- ["_" lua (#+ Expression)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." primitive]
- ["///#" //// #_
- [analysis (#+ Variant Tuple)]
- ["#." synthesis (#+ Synthesis)]
- ["//#" /// #_
- ["#." phase ("#\." monad)]]]])
-
-(def: #export (tuple generate archive elemsS+)
- (Generator (Tuple Synthesis))
- (case elemsS+
- #.Nil
- (///////phase\wrap (//primitive.text /////synthesis.unit))
-
- (#.Cons singletonS #.Nil)
- (generate archive singletonS)
-
- _
- (|> elemsS+
- (monad.map ///////phase.monad (generate archive))
- (///////phase\map _.array))))
-
-(def: #export (variant generate archive [lefts right? valueS])
- (Generator (Variant Synthesis))
- (let [tag (if right?
- (inc lefts)
- lefts)]
- (///////phase\map (//runtime.variant tag right?)
- (generate archive valueS))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php.lux
deleted file mode 100644
index 654c07bdf..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php.lux
+++ /dev/null
@@ -1,102 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." exception (#+ exception:)]]
- [target
- ["_" php]]]
- ["." / #_
- [runtime (#+ Phase Phase!)]
- ["#." primitive]
- ["#." structure]
- ["#." reference]
- ["#." case]
- ["#." loop]
- ["#." function]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- ["#." extension]
- ["/#" // #_
- [analysis (#+)]
- ["#." synthesis]
- ["//#" /// #_
- ["#." phase ("#\." monad)]
- [reference (#+)
- [variable (#+)]]]]]]])
-
-(def: (statement expression archive synthesis)
- Phase!
- (case synthesis
- (^template [<tag>]
- [(^ (<tag> value))
- (//////phase\map _.return (expression archive synthesis))])
- ([////synthesis.bit]
- [////synthesis.i64]
- [////synthesis.f64]
- [////synthesis.text]
- [////synthesis.variant]
- [////synthesis.tuple]
- [#////synthesis.Reference]
- [////synthesis.branch/get]
- [////synthesis.function/apply]
- [#////synthesis.Extension])
-
- (^ (////synthesis.branch/case case))
- (/case.case! statement expression archive case)
-
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (<generator> statement expression archive value)])
- ([////synthesis.branch/let /case.let!]
- [////synthesis.branch/if /case.if!]
- [////synthesis.loop/scope /loop.scope!]
- [////synthesis.loop/recur /loop.recur!])
-
- (^ (////synthesis.function/abstraction abstraction))
- (//////phase\map _.return (/function.function statement expression archive abstraction))
- ))
-
-(exception: #export cannot-recur-as-an-expression)
-
-(def: #export (expression archive synthesis)
- Phase
- (case synthesis
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (//////phase\wrap (<generator> value))])
- ([////synthesis.bit /primitive.bit]
- [////synthesis.i64 /primitive.i64]
- [////synthesis.f64 /primitive.f64]
- [////synthesis.text /primitive.text])
-
- (#////synthesis.Reference value)
- (//reference.reference /reference.system archive value)
-
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (<generator> expression archive value)])
- ([////synthesis.variant /structure.variant]
- [////synthesis.tuple /structure.tuple]
- [////synthesis.branch/let /case.let]
- [////synthesis.branch/if /case.if]
- [////synthesis.branch/get /case.get]
- [////synthesis.function/apply /function.apply])
-
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (<generator> statement expression archive value)])
- ([////synthesis.branch/case /case.case]
- [////synthesis.loop/scope /loop.scope]
- [////synthesis.function/abstraction /function.function])
-
- (^ (////synthesis.loop/recur _))
- (//////phase.throw ..cannot-recur-as-an-expression [])
-
- (#////synthesis.Extension extension)
- (///extension.apply archive expression extension)))
-
-(def: #export generate
- Phase
- ..expression)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux
deleted file mode 100644
index 728902418..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux
+++ /dev/null
@@ -1,297 +0,0 @@
-(.module:
- [lux (#- case let if)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." set]]]
- [math
- [number
- ["i" int]]]
- [target
- ["_" php (#+ Expression Var Statement)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Phase! Generator Generator!)]
- ["#." reference]
- ["#." primitive]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- ["#." synthesis #_
- ["#/." case]]
- ["/#" // #_
- ["#." synthesis (#+ Member Synthesis Path)]
- ["#." generation]
- ["//#" /// #_
- [reference
- ["#." variable (#+ Register)]]
- ["#." phase ("#\." monad)]
- [meta
- [archive (#+ Archive)]]]]]]])
-
-(def: #export register
- (-> Register Var)
- (|>> (///reference.local //reference.system) :assume))
-
-(def: #export capture
- (-> Register Var)
- (|>> (///reference.foreign //reference.system) :assume))
-
-(def: #export (let expression archive [valueS register bodyS])
- (Generator [Synthesis Register Synthesis])
- (do ///////phase.monad
- [valueG (expression archive valueS)
- bodyG (expression archive bodyS)]
- (wrap (|> bodyG
- (list (_.set (..register register) valueG))
- _.array/*
- (_.nth (_.int +1))))))
-
-(def: #export (let! statement expression archive [valueS register bodyS])
- (Generator! [Synthesis Register Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)
- body! (statement expression archive bodyS)]
- (wrap ($_ _.then
- (_.set! (..register register) valueO)
- body!))))
-
-(def: #export (if expression archive [testS thenS elseS])
- (Generator [Synthesis Synthesis Synthesis])
- (do ///////phase.monad
- [testG (expression archive testS)
- thenG (expression archive thenS)
- elseG (expression archive elseS)]
- (wrap (_.? testG thenG elseG))))
-
-(def: #export (if! statement expression archive [testS thenS elseS])
- (Generator! [Synthesis Synthesis Synthesis])
- (do ///////phase.monad
- [test! (expression archive testS)
- then! (statement expression archive thenS)
- else! (statement expression archive elseS)]
- (wrap (_.if test!
- then!
- else!))))
-
-(def: #export (get expression archive [pathP valueS])
- (Generator [(List Member) Synthesis])
- (do ///////phase.monad
- [valueG (expression archive valueS)]
- (wrap (list\fold (function (_ side source)
- (.let [method (.case side
- (^template [<side> <accessor>]
- [(<side> lefts)
- (<accessor> (_.int (.int lefts)))])
- ([#.Left //runtime.tuple//left]
- [#.Right //runtime.tuple//right]))]
- (method source)))
- valueG
- (list.reverse pathP)))))
-
-(def: @savepoint (_.var "lux_pm_savepoint"))
-(def: @cursor (_.var "lux_pm_cursor"))
-(def: @temp (_.var "lux_pm_temp"))
-
-(def: (push! value)
- (-> Expression Statement)
- (_.; (_.array_push/2 [@cursor value])))
-
-(def: peek_and_pop
- Expression
- (_.array_pop/1 @cursor))
-
-(def: pop!
- Statement
- (_.; ..peek_and_pop))
-
-(def: peek
- Expression
- (_.nth (|> @cursor _.count/1 (_.- (_.int +1)))
- @cursor))
-
-(def: save!
- Statement
- (.let [cursor (_.array_slice/2 [@cursor (_.int +0)])]
- (_.; (_.array_push/2 [@savepoint cursor]))))
-
-(def: restore!
- Statement
- (_.set! @cursor (_.array_pop/1 @savepoint)))
-
-(def: fail! _.break)
-
-(def: (multi_pop! pops)
- (-> Nat Statement)
- (_.; (_.array_splice/3 [@cursor
- (_.int +0)
- (_.int (i.* -1 (.int pops)))])))
-
-(template [<name> <flag> <prep>]
- [(def: (<name> simple? idx)
- (-> Bit Nat Statement)
- ($_ _.then
- (_.set! @temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>)))
- (.if simple?
- (_.when (_.is_null/1 @temp)
- fail!)
- (_.if (_.is_null/1 @temp)
- fail!
- (..push! @temp)))))]
-
- [left_choice _.null (<|)]
- [right_choice (_.string "") inc]
- )
-
-(def: (alternation pre! post!)
- (-> Statement Statement Statement)
- ($_ _.then
- (_.do_while (_.bool false)
- ($_ _.then
- ..save!
- pre!))
- ($_ _.then
- ..restore!
- post!)))
-
-(def: (pattern_matching' statement expression archive)
- (Generator! Path)
- (function (recur pathP)
- (.case pathP
- (#/////synthesis.Then bodyS)
- (statement expression archive bodyS)
-
- #/////synthesis.Pop
- (///////phase\wrap ..pop!)
-
- (#/////synthesis.Bind register)
- (///////phase\wrap (_.set! (..register register) ..peek))
-
- (#/////synthesis.Bit_Fork when thenP elseP)
- (do {! ///////phase.monad}
- [then! (recur thenP)
- else! (.case elseP
- (#.Some elseP)
- (recur elseP)
-
- #.None
- (wrap ..fail!))]
- (wrap (.if when
- (_.if ..peek
- then!
- else!)
- (_.if ..peek
- else!
- then!))))
-
- (^template [<tag> <format>]
- [(<tag> cons)
- (do {! ///////phase.monad}
- [clauses (monad.map ! (function (_ [match then])
- (do !
- [then! (recur then)]
- (wrap [(_.=== (|> match <format>)
- ..peek)
- then!])))
- (#.Cons cons))]
- (wrap (_.cond clauses ..fail!)))])
- ([#/////synthesis.I64_Fork //primitive.i64]
- [#/////synthesis.F64_Fork //primitive.f64]
- [#/////synthesis.Text_Fork //primitive.text])
-
- (^template [<complex> <simple> <choice>]
- [(^ (<complex> idx))
- (///////phase\wrap (<choice> false idx))
-
- (^ (<simple> idx nextP))
- (|> nextP
- recur
- (\ ///////phase.monad map (_.then (<choice> true idx))))])
- ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice]
- [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice])
-
- (^ (/////synthesis.member/left 0))
- (///////phase\wrap (|> ..peek (_.nth (_.int +0)) ..push!))
-
- (^template [<pm> <getter>]
- [(^ (<pm> lefts))
- (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))])
- ([/////synthesis.member/left //runtime.tuple//left]
- [/////synthesis.member/right //runtime.tuple//right])
-
- (^ (/////synthesis.!bind_top register thenP))
- (do ///////phase.monad
- [then! (recur thenP)]
- (///////phase\wrap ($_ _.then
- (_.set! (..register register) ..peek_and_pop)
- then!)))
-
- ## (^ (/////synthesis.!multi_pop nextP))
- ## (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)]
- ## (do ///////phase.monad
- ## [next! (recur nextP')]
- ## (///////phase\wrap ($_ _.then
- ## (..multi_pop! (n.+ 2 extra_pops))
- ## next!))))
-
- (^template [<tag> <combinator>]
- [(^ (<tag> preP postP))
- (do ///////phase.monad
- [pre! (recur preP)
- post! (recur postP)]
- (wrap (<combinator> pre! post!)))])
- ([/////synthesis.path/seq _.then]
- [/////synthesis.path/alt ..alternation]))))
-
-(def: (pattern_matching statement expression archive pathP)
- (Generator! Path)
- (do ///////phase.monad
- [iteration! (pattern_matching' statement expression archive pathP)]
- (wrap ($_ _.then
- (_.do_while (_.bool false)
- iteration!)
- (_.throw (_.new (_.constant "Exception") (list (_.string ////synthesis/case.pattern_matching_error))))))))
-
-(def: (gensym prefix)
- (-> Text (Operation Text))
- (\ ///////phase.monad map (|>> %.nat (format prefix)) /////generation.next))
-
-(def: #export dependencies
- (-> Path (List Var))
- (|>> ////synthesis/case.storage
- (get@ #////synthesis/case.dependencies)
- set.to_list
- (list\map (function (_ variable)
- (.case variable
- (#///////variable.Local register)
- (..register register)
-
- (#///////variable.Foreign register)
- (..capture register))))))
-
-(def: #export (case! statement expression archive [valueS pathP])
- (Generator! [Synthesis Path])
- (do ///////phase.monad
- [stack_init (expression archive valueS)
- pattern_matching! (pattern_matching statement expression archive pathP)]
- (wrap ($_ _.then
- (_.set! @cursor (_.array/* (list stack_init)))
- (_.set! @savepoint (_.array/* (list)))
- pattern_matching!))))
-
-(def: #export (case statement expression archive [valueS pathP])
- (-> Phase! (Generator [Synthesis Path]))
- (do {! ///////phase.monad}
- [[[case_module case_artifact] case!] (/////generation.with_new_context archive
- (case! statement expression archive [valueS pathP]))
- #let [@case (_.constant (///reference.artifact [case_module case_artifact]))
- @dependencies+ (..dependencies (/////synthesis.path/seq (/////synthesis.path/then valueS)
- pathP))
- directive (_.define_function @case (list\map _.parameter @dependencies+) case!)]
- _ (/////generation.execute! directive)
- _ (/////generation.save! case_artifact directive)]
- (wrap (_.apply/* @dependencies+ @case))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension.lux
deleted file mode 100644
index 3bc0a0887..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension.lux
+++ /dev/null
@@ -1,13 +0,0 @@
-(.module:
- [lux #*
- [data
- [collection
- ["." dictionary]]]]
- [//
- [runtime (#+ Bundle)]]
- [/
- ["." common]])
-
-(def: #export bundle
- Bundle
- common.bundle)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux
deleted file mode 100644
index 2a4c4c50d..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux
+++ /dev/null
@@ -1,111 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]]
- [data
- ["." product]
- ["." text]
- [number
- ["f" frac]]
- [collection
- ["." dictionary]]]
- [target
- ["_" php (#+ Expression)]]]
- ["." /// #_
- ["#." runtime (#+ Operation Phase Handler Bundle)]
- ["#." primitive]
- [//
- [extension (#+ Nullary Unary Binary Trinary
- nullary unary binary trinary)]
- [//
- [extension
- ["." bundle]]]]])
-
-(def: lux-procs
- Bundle
- (|> bundle.empty
- (bundle.install "is" (binary (product.uncurry _.=)))
- (bundle.install "try" (unary ///runtime.lux//try))))
-
-(def: i64-procs
- Bundle
- (<| (bundle.prefix "i64")
- (|> bundle.empty
- (bundle.install "and" (binary (product.uncurry _.bit-and)))
- (bundle.install "or" (binary (product.uncurry _.bit-or)))
- (bundle.install "xor" (binary (product.uncurry _.bit-xor)))
- (bundle.install "left-shift" (binary (product.uncurry _.bit-shl)))
- (bundle.install "logical-right-shift" (binary (product.uncurry ///runtime.i64//logic-right-shift)))
- (bundle.install "arithmetic-right-shift" (binary (product.uncurry _.bit-shr)))
- (bundle.install "=" (binary (product.uncurry _.=)))
- (bundle.install "+" (binary (product.uncurry _.+)))
- (bundle.install "-" (binary (product.uncurry _.-)))
- )))
-
-(def: int-procs
- Bundle
- (<| (bundle.prefix "int")
- (|> bundle.empty
- (bundle.install "<" (binary (product.uncurry _.<)))
- (bundle.install "*" (binary (product.uncurry _.*)))
- (bundle.install "/" (binary (product.uncurry _./)))
- (bundle.install "%" (binary (product.uncurry _.%)))
- (bundle.install "frac" (unary _.floatval/1))
- (bundle.install "char" (unary _.chr/1)))))
-
-(def: frac-procs
- Bundle
- (<| (bundle.prefix "frac")
- (|> bundle.empty
- (bundle.install "+" (binary (product.uncurry _.+)))
- (bundle.install "-" (binary (product.uncurry _.-)))
- (bundle.install "*" (binary (product.uncurry _.*)))
- (bundle.install "/" (binary (product.uncurry _./)))
- (bundle.install "%" (binary (product.uncurry _.%)))
- (bundle.install "=" (binary (product.uncurry _.=)))
- (bundle.install "<" (binary (product.uncurry _.<)))
- (bundle.install "int" (unary _.intval/1))
- (bundle.install "encode" (unary _.strval/1))
- (bundle.install "decode" (unary (|>> _.floatval/1 ///runtime.some)))
- )))
-
-(def: (text//index [startO partO textO])
- (Trinary (Expression Any))
- (///runtime.text//index textO partO startO))
-
-(def: text-procs
- Bundle
- (<| (bundle.prefix "text")
- (|> bundle.empty
- (bundle.install "=" (binary (product.uncurry _.=)))
- (bundle.install "<" (binary (product.uncurry _.<)))
- (bundle.install "concat" (binary (product.uncurry _.concat)))
- (bundle.install "index" (trinary text//index))
- (bundle.install "size" (unary _.strlen/1))
- (bundle.install "char" (binary (function (text//char [text idx])
- (|> text (_.nth idx) _.ord/1))))
- (bundle.install "clip" (trinary (function (text//clip [from to text])
- (_.substr/3 [text from (_.- from to)]))))
- )))
-
-(def: io-procs
- Bundle
- (<| (bundle.prefix "io")
- (|> bundle.empty
- (bundle.install "log" (unary (|>> (_.concat (_.string text.new-line)) _.print/1)))
- (bundle.install "error" (unary ///runtime.io//throw!))
- (bundle.install "exit" (unary _.exit/1))
- (bundle.install "current-time" (nullary (|>> _.time/0 (_.* (_.int +1,000))))))))
-
-(def: #export bundle
- Bundle
- (<| (bundle.prefix "lux")
- (|> lux-procs
- (dictionary.merge i64-procs)
- (dictionary.merge int-procs)
- (dictionary.merge frac-procs)
- (dictionary.merge text-procs)
- (dictionary.merge io-procs)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux
deleted file mode 100644
index 1194cfe9a..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux
+++ /dev/null
@@ -1,115 +0,0 @@
-(.module:
- [lux (#- Global function)
- [abstract
- ["." monad (#+ do)]]
- [control
- pipe]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [target
- ["_" php (#+ Var Global Expression Argument Label Statement)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Phase! Generator)]
- ["#." reference]
- ["#." case]
- ["/#" // #_
- ["#." reference]
- ["//#" /// #_
- [analysis (#+ Variant Tuple Abstraction Application Analysis)]
- [synthesis (#+ Synthesis)]
- ["#." generation (#+ Context)]
- ["//#" /// #_
- [arity (#+ Arity)]
- ["#." phase ("#\." monad)]
- [reference
- [variable (#+ Register Variable)]]]]]])
-
-(def: #export (apply expression archive [functionS argsS+])
- (Generator (Application Synthesis))
- (do {! ///////phase.monad}
- [functionG (expression archive functionS)
- argsG+ (monad.map ! (expression archive) argsS+)]
- (wrap (_.apply/*' argsG+ functionG))))
-
-(def: capture
- (-> Register Var)
- (|>> (///reference.foreign //reference.system) :assume))
-
-(def: input
- (|>> inc //case.register))
-
-(def: (@scope function_name)
- (-> Context Label)
- (_.label (format (///reference.artifact function_name) "_scope")))
-
-(def: (with_closure inits @selfG @selfL body!)
- (-> (List Expression) Global Var Statement [Statement Expression])
- (case inits
- #.Nil
- [($_ _.then
- (_.set! @selfL (_.closure (list (_.reference @selfL)) (list) body!))
- (_.set! @selfG @selfL))
- @selfG]
-
- _
- (let [@inits (|> (list.enumeration inits)
- (list\map (|>> product.left ..capture)))]
- [(_.set! @selfG (_.closure (list) (list\map _.parameter @inits)
- ($_ _.then
- (_.set! @selfL (_.closure (list& (_.reference @selfL) (list\map _.reference @inits))
- (list)
- body!))
- (_.return @selfL))))
- (_.apply/* inits @selfG)])))
-
-(def: #export (function statement expression archive [environment arity bodyS])
- (-> Phase! (Generator (Abstraction Synthesis)))
- (do {! ///////phase.monad}
- [[function_name body!] (/////generation.with_new_context archive
- (do !
- [@scope (\ ! map ..@scope
- (/////generation.context archive))]
- (/////generation.with_anchor [1 @scope]
- (statement expression archive bodyS))))
- closureG+ (monad.map ! (expression archive) environment)
- #let [@curried (_.var "curried")
- arityG (|> arity .int _.int)
- @num_args (_.var "num_args")
- @scope (..@scope function_name)
- @selfG (_.global (///reference.artifact function_name))
- @selfL (_.var (///reference.artifact function_name))
- initialize_self! (_.set! (//case.register 0) @selfL)
- initialize! (list\fold (.function (_ post pre!)
- ($_ _.then
- pre!
- (_.set! (..input post) (_.nth (|> post .int _.int) @curried))))
- initialize_self!
- (list.indices arity))]
- #let [[definition instantiation] (..with_closure closureG+ @selfG @selfL
- ($_ _.then
- (_.set! @num_args (_.func_num_args/0 []))
- (_.set! @curried (_.func_get_args/0 []))
- (_.cond (list [(|> @num_args (_.=== arityG))
- ($_ _.then
- initialize!
- (_.set_label @scope)
- body!)]
- [(|> @num_args (_.> arityG))
- (let [arity_inputs (_.array_slice/3 [@curried (_.int +0) arityG])
- extra_inputs (_.array_slice/2 [@curried arityG])
- next (_.call_user_func_array/2 [@selfL arity_inputs])]
- (_.return (_.call_user_func_array/2 [next extra_inputs])))])
- ## (|> @num_args (_.< arityG))
- (let [@missing (_.var "missing")]
- (_.return (<| (_.closure (list (_.reference @selfL) (_.reference @curried)) (list))
- ($_ _.then
- (_.set! @missing (_.func_get_args/0 []))
- (_.return (_.call_user_func_array/2 [@selfL (_.array_merge/+ @curried (list @missing))])))))))
- ))]
- _ (/////generation.execute! definition)
- _ (/////generation.save! (product.right function_name) definition)]
- (wrap instantiation)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux
deleted file mode 100644
index b1fb94050..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux
+++ /dev/null
@@ -1,121 +0,0 @@
-(.module:
- [lux (#- Scope)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." set (#+ Set)]]]
- [math
- [number
- ["n" nat]]]
- [target
- ["_" php (#+ Var Expression Label Statement)]]]
- ["." // #_
- [runtime (#+ Operation Phase Phase! Generator Generator!)]
- ["#." case]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- [synthesis
- ["." case]]
- ["/#" // #_
- ["."synthesis (#+ Scope Synthesis)]
- ["#." generation]
- ["//#" /// #_
- ["#." phase]
- [meta
- [archive (#+ Archive)]]
- [reference
- [variable (#+ Register)]]]]]]])
-
-(def: @scope
- (-> Nat Label)
- (|>> %.nat (format "scope") _.label))
-
-(def: (setup offset bindings body)
- (-> Register (List Expression) Statement Statement)
- (|> bindings
- list.enumeration
- (list\map (function (_ [register value])
- (let [variable (//case.register (n.+ offset register))]
- (_.set! variable value))))
- list.reverse
- (list\fold _.then body)))
-
-(def: #export (scope! statement expression archive [start initsS+ bodyS])
- (Generator! (Scope Synthesis))
- (case initsS+
- ## function/false/non-independent loop
- #.Nil
- (statement expression archive bodyS)
-
- ## true loop
- _
- (do {! ///////phase.monad}
- [@scope (\ ! map ..@scope /////generation.next)
- initsO+ (monad.map ! (expression archive) initsS+)
- body! (/////generation.with_anchor [start @scope]
- (statement expression archive bodyS))]
- (wrap (..setup start initsO+
- ($_ _.then
- (_.set_label @scope)
- body!))))))
-
-(def: #export (scope statement expression archive [start initsS+ bodyS])
- (-> Phase! (Generator (Scope Synthesis)))
- (case initsS+
- ## function/false/non-independent loop
- #.Nil
- (expression archive bodyS)
-
- ## true loop
- _
- (do {! ///////phase.monad}
- [[[loop_module loop_artifact] scope!] (/////generation.with_new_context archive
- (..scope! statement expression archive [start initsS+ bodyS]))
- #let [locals (|> initsS+
- list.enumeration
- (list\map (|>> product.left (n.+ start) //case.register _.parameter)))
- @loop (_.constant (///reference.artifact [loop_module loop_artifact]))
- loop_variables (set.from_list _.hash (list\map product.right locals))
- referenced_variables (: (-> Synthesis (Set Var))
- (|>> synthesis.path/then
- //case.dependencies
- (set.from_list _.hash)))
- [directive instantiation] (: [Statement Expression]
- (case (|> (list\map referenced_variables initsS+)
- (list\fold set.union (referenced_variables bodyS))
- (set.difference loop_variables)
- set.to_list)
- #.Nil
- [(_.define_function @loop (list) scope!)
- @loop]
-
- foreigns
- [(<| (_.define_function @loop (list\map _.parameter foreigns))
- (_.return (_.closure (list\map _.parameter foreigns) (list) scope!)))
- (_.apply/* foreigns @loop)]))]
- _ (/////generation.execute! directive)
- _ (/////generation.save! loop_artifact directive)]
- (wrap (_.apply/* (list) instantiation)))))
-
-(def: @temp
- (_.var "lux_recur_values"))
-
-(def: #export (recur! statement expression archive argsS+)
- (Generator! (List Synthesis))
- (do {! ///////phase.monad}
- [[offset @scope] /////generation.anchor
- argsO+ (monad.map ! (expression archive) argsS+)]
- (wrap ($_ _.then
- (_.set! @temp (_.array/* argsO+))
- (..setup offset
- (|> argsO+
- list.enumeration
- (list\map (function (_ [idx _])
- (_.nth (_.int (.int idx)) @temp))))
- (_.go_to @scope))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux
deleted file mode 100644
index 242519aa9..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux
+++ /dev/null
@@ -1,31 +0,0 @@
-(.module:
- [lux (#- i64)
- [control
- [pipe (#+ cond> new>)]]
- [math
- [number
- ["." frac]]]
- [target
- ["_" php (#+ Literal Expression)]]]
- ["." // #_
- ["#." runtime]])
-
-(def: #export bit
- (-> Bit Literal)
- _.bool)
-
-(def: #export (i64 value)
- (-> (I64 Any) Expression)
- (let [h32 (|> value //runtime.high .int _.int)
- l32 (|> value //runtime.low .int _.int)]
- (|> h32
- (_.bit_shl (_.int +32))
- (_.bit_or l32))))
-
-(def: #export f64
- (-> Frac Literal)
- _.float)
-
-(def: #export text
- (-> Text Literal)
- _.string)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/reference.lux
deleted file mode 100644
index de532a9dc..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/reference.lux
+++ /dev/null
@@ -1,12 +0,0 @@
-(.module:
- [lux #*
- [target
- ["_" php (#+ Expression)]]]
- [///
- [reference (#+ System)]])
-
-(implementation: #export system
- (System Expression)
-
- (def: constant _.global)
- (def: variable _.var))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux
deleted file mode 100644
index 041993fb5..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux
+++ /dev/null
@@ -1,609 +0,0 @@
-(.module:
- [lux (#- Location inc)
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<.>" code]]]
- [data
- ["." product]
- ["." text ("#\." hash)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." list ("#\." functor)]
- ["." row]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number (#+ hex)
- ["." i64]]]
- ["@" target
- ["_" php (#+ Expression Label Constant Var Computation Literal Statement)]]]
- ["." /// #_
- ["#." reference]
- ["//#" /// #_
- ["#." synthesis (#+ Synthesis)]
- ["#." generation]
- ["//#" ///
- ["#." phase]
- [reference
- [variable (#+ Register)]]
- [meta
- [archive (#+ Output Archive)
- ["." artifact (#+ Registry)]]]]]])
-
-(template [<name> <base>]
- [(type: #export <name>
- (<base> [Nat Label] Expression Statement))]
-
- [Operation /////generation.Operation]
- [Phase /////generation.Phase]
- [Handler /////generation.Handler]
- [Bundle /////generation.Bundle]
- )
-
-(type: #export (Generator i)
- (-> Phase Archive i (Operation Expression)))
-
-(type: #export Phase!
- (-> Phase Archive Synthesis (Operation Statement)))
-
-(type: #export (Generator! i)
- (-> Phase! Phase Archive i (Operation Statement)))
-
-(def: #export unit
- (_.string /////synthesis.unit))
-
-(def: (flag value)
- (-> Bit Literal)
- (if value
- ..unit
- _.null))
-
-(def: (feature name definition)
- (-> Constant (-> Constant Statement) Statement)
- (definition name))
-
-(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
- body)
- (do {! meta.monad}
- [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
- (wrap (list (` (let [(~+ (|> vars
- (list.zip/2 ids)
- (list\map (function (_ [id var])
- (list (code.local_identifier var)
- (` (_.var (~ (code.text (format "v" (%.nat id)))))))))
- list.concat))]
- (~ body)))))))
-
-(def: module_id
- 0)
-
-(syntax: (runtime: {declaration (<>.or <code>.local_identifier
- (<code>.form (<>.and <code>.local_identifier
- (<>.some <code>.local_identifier))))}
- code)
- (do meta.monad
- [runtime_id meta.count]
- (macro.with_gensyms [g!_]
- (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id]))
- runtime_name (` (_.constant (~ (code.text (%.code runtime)))))]
- (case declaration
- (#.Left name)
- (macro.with_gensyms [g!_]
- (let [g!name (code.local_identifier name)]
- (wrap (list (` (def: #export (~ g!name)
- Var
- (~ runtime_name)))
-
- (` (def: (~ (code.local_identifier (format "@" name)))
- Statement
- (..feature (~ runtime_name)
- (function ((~ g!_) (~ g!name))
- (_.define (~ g!name) (~ code))))))))))
-
- (#.Right [name inputs])
- (macro.with_gensyms [g!_]
- (let [g!name (code.local_identifier name)
- inputsC (list\map code.local_identifier inputs)
- inputs_typesC (list\map (function.constant (` _.Expression))
- inputs)]
- (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
- (-> (~+ inputs_typesC) Computation)
- (_.apply/* (list (~+ inputsC)) (~ runtime_name))))
-
- (` (def: (~ (code.local_identifier (format "@" name)))
- Statement
- (..feature (~ runtime_name)
- (function ((~ g!_) (~ g!_))
- (..with_vars [(~+ inputsC)]
- (_.define_function (~ g!_)
- (list (~+ (list\map (|>> (~) [false] (`)) inputsC)))
- (~ code))))))))))))))))
-
-(runtime: (io//log! message)
- ($_ _.then
- (_.echo message)
- (_.echo (_.string text.new_line))
- (_.return ..unit)))
-
-(runtime: (io//throw! message)
- ($_ _.then
- (_.throw (_.new (_.constant "Exception") (list message)))
- (_.return ..unit)))
-
-(def: runtime//io
- Statement
- ($_ _.then
- @io//log!
- @io//throw!
- ))
-
-(def: #export tuple_size_field
- "_lux_size")
-
-(def: tuple_size
- (_.nth (_.string ..tuple_size_field)))
-
-(def: jphp?
- (_.=== (_.string "5.6.99") (_.phpversion/0 [])))
-
-(runtime: (array//length array)
- ## TODO: Get rid of this as soon as JPHP is no longer necessary.
- (_.if ..jphp?
- (_.return (..tuple_size array))
- (_.return (_.count/1 array))))
-
-(runtime: (array//write idx value array)
- ($_ _.then
- (_.set! (_.nth idx array) value)
- (_.return array)))
-
-(def: runtime//array
- Statement
- ($_ _.then
- @array//length
- @array//write
- ))
-
-(def: jphp_last_index
- (|>> ..tuple_size (_.- (_.int +1))))
-
-(def: normal_last_index
- (|>> _.count/1 (_.- (_.int +1))))
-
-(with_expansions [<recur> (as_is ($_ _.then
- (_.set! lefts (_.- last_index_right lefts))
- (_.set! tuple (_.nth last_index_right tuple))))]
- (runtime: (tuple//make size values)
- (_.if ..jphp?
- ($_ _.then
- (_.set! (..tuple_size values) size)
- (_.return values))
- ## https://www.php.net/manual/en/language.operators.assignment.php
- ## https://www.php.net/manual/en/language.references.php
- ## https://www.php.net/manual/en/functions.arguments.php
- ## https://www.php.net/manual/en/language.oop5.references.php
- ## https://www.php.net/manual/en/class.arrayobject.php
- (_.return (_.new (_.constant "ArrayObject") (list values)))))
-
- (runtime: (tuple//left lefts tuple)
- (with_vars [last_index_right]
- (<| (_.while (_.bool true))
- ($_ _.then
- (_.if ..jphp?
- (_.set! last_index_right (..jphp_last_index tuple))
- (_.set! last_index_right (..normal_last_index tuple)))
- (_.if (_.> lefts last_index_right)
- ## No need for recursion
- (_.return (_.nth lefts tuple))
- ## Needs recursion
- <recur>)))))
-
- ## TODO: Get rid of this as soon as JPHP is no longer necessary.
- (runtime: (tuple//slice offset input)
- (with_vars [size index output]
- ($_ _.then
- (_.set! size (..array//length input))
- (_.set! index (_.int +0))
- (_.set! output (_.array/* (list)))
- (<| (_.while (|> index (_.+ offset) (_.< size)))
- ($_ _.then
- (_.set! (_.nth index output) (_.nth (_.+ offset index) input))
- (_.set! index (_.+ (_.int +1) index))
- ))
- (_.return (..tuple//make (_.- offset size) output))
- )))
-
- (runtime: (tuple//right lefts tuple)
- (with_vars [last_index_right right_index]
- (<| (_.while (_.bool true))
- ($_ _.then
- (_.if ..jphp?
- (_.set! last_index_right (..jphp_last_index tuple))
- (_.set! last_index_right (..normal_last_index tuple)))
- (_.set! right_index (_.+ (_.int +1) lefts))
- (_.cond (list [(_.=== last_index_right right_index)
- (_.return (_.nth right_index tuple))]
- [(_.> last_index_right right_index)
- ## Needs recursion.
- <recur>])
- (_.if ..jphp?
- (_.return (..tuple//make (_.- right_index (..tuple_size tuple))
- (..tuple//slice right_index tuple)))
- (_.return (..tuple//make (_.- right_index (_.count/1 tuple))
- (_.array_slice/2 [(_.do "getArrayCopy" (list) tuple) right_index])))))
- )))))
-
-(def: #export variant_tag_field "_lux_tag")
-(def: #export variant_flag_field "_lux_flag")
-(def: #export variant_value_field "_lux_value")
-
-(runtime: (sum//make tag last? value)
- (_.return (_.array/** (list [(_.string ..variant_tag_field) tag]
- [(_.string ..variant_flag_field) last?]
- [(_.string ..variant_value_field) value]))))
-
-(def: #export (variant tag last? value)
- (-> Nat Bit Expression Computation)
- (sum//make (_.int (.int tag))
- (..flag last?)
- value))
-
-(def: #export none
- Computation
- (..variant 0 #0 ..unit))
-
-(def: #export some
- (-> Expression Computation)
- (..variant 1 #1))
-
-(def: #export left
- (-> Expression Computation)
- (..variant 0 #0))
-
-(def: #export right
- (-> Expression Computation)
- (..variant 1 #1))
-
-(runtime: (sum//get sum wantsLast wantedTag)
- (let [no_match! (_.return _.null)
- sum_tag (_.nth (_.string ..variant_tag_field) sum)
- ## sum_tag (_.nth (_.int +0) sum)
- sum_flag (_.nth (_.string ..variant_flag_field) sum)
- ## sum_flag (_.nth (_.int +1) sum)
- sum_value (_.nth (_.string ..variant_value_field) sum)
- ## sum_value (_.nth (_.int +2) sum)
- is_last? (_.=== ..unit sum_flag)
- test_recursion! (_.if is_last?
- ## Must recurse.
- ($_ _.then
- (_.set! wantedTag (_.- sum_tag wantedTag))
- (_.set! sum sum_value))
- no_match!)]
- (<| (_.while (_.bool true))
- (_.cond (list [(_.=== sum_tag wantedTag)
- (_.if (_.=== wantsLast sum_flag)
- (_.return sum_value)
- test_recursion!)]
-
- [(_.< wantedTag sum_tag)
- test_recursion!]
-
- [(_.=== ..unit wantsLast)
- (_.return (sum//make (_.- wantedTag sum_tag) sum_flag sum_value))])
- no_match!))))
-
-(def: runtime//adt
- Statement
- ($_ _.then
- @tuple//make
- @tuple//left
- @tuple//slice
- @tuple//right
- @sum//make
- @sum//get
- ))
-
-(runtime: (lux//try op)
- (with_vars [value]
- (_.try ($_ _.then
- (_.set! value (_.apply/1 op [..unit]))
- (_.return (..right value)))
- (list (with_vars [error]
- {#_.class (_.constant "Exception")
- #_.exception error
- #_.handler (_.return (..left (_.do "getMessage" (list) error)))})))))
-
-(runtime: (lux//program_args inputs)
- (with_vars [head tail]
- ($_ _.then
- (_.set! tail ..none)
- (<| (_.for_each (_.array_reverse/1 inputs) head)
- (_.set! tail (..some (_.array/* (list head tail)))))
- (_.return tail))))
-
-(def: runtime//lux
- Statement
- ($_ _.then
- @lux//try
- @lux//program_args
- ))
-
-(def: #export high
- (-> (I64 Any) (I64 Any))
- (i64.right_shift 32))
-
-(def: #export low
- (-> (I64 Any) (I64 Any))
- (let [mask (dec (i64.left_shift 32 1))]
- (|>> (i64.and mask))))
-
-(runtime: (i64//right_shift param subject)
- (let [## The mask has to be calculated this way instead of in a more straightforward way
- ## because in some languages, 1<<63 = max_negative_value
- ## and max_negative_value-1 = max_positive_value.
- ## And bitwise, max_positive_value works out to the mask that is desired when param = 0.
- ## However, in PHP, max_negative_value-1 underflows and gets cast into a float.
- ## And this messes up the computation.
- ## This slightly more convoluted calculation avoids that problem.
- mask (|> (_.int +1)
- (_.bit_shl (_.- param (_.int +63)))
- (_.- (_.int +1))
- (_.bit_shl (_.int +1))
- (_.+ (_.int +1)))]
- ($_ _.then
- (_.set! param (_.% (_.int +64) param))
- (_.if (_.=== (_.int +0) param)
- (_.return subject)
- (_.return (|> subject
- (_.bit_shr param)
- (_.bit_and mask)))))))
-
-(runtime: (i64//char code)
- (_.if ..jphp?
- (_.return (_.chr/1 [code]))
- (_.return (|> code
- [(_.string "V")]
- _.pack/2
- [(_.string "UTF-32LE") (_.string "UTF-8")]
- _.iconv/3))))
-
-(runtime: (i64//+ parameter subject)
- (let [high_16 (..i64//right_shift (_.int +16))
- low_16 (_.bit_and (_.int (.int (hex "FFFF"))))
-
- cap_16 low_16
- hh (..i64//right_shift (_.int +48))
- hl (|>> (..i64//right_shift (_.int +32)) cap_16)
- lh (|>> (..i64//right_shift (_.int +16)) cap_16)
- ll cap_16
-
- up_16 (_.bit_shl (_.int +16))]
- (with_vars [l48 l32 l16 l00
- r48 r32 r16 r00
- x48 x32 x16 x00]
- ($_ _.then
- (_.set! l48 (hh subject))
- (_.set! l32 (hl subject))
- (_.set! l16 (lh subject))
- (_.set! l00 (ll subject))
-
- (_.set! r48 (hh parameter))
- (_.set! r32 (hl parameter))
- (_.set! r16 (lh parameter))
- (_.set! r00 (ll parameter))
-
- (_.set! x00 (_.+ l00 r00))
-
- (_.set! x16 (|> (high_16 x00)
- (_.+ l16)
- (_.+ r16)))
- (_.set! x00 (low_16 x00))
-
- (_.set! x32 (|> (high_16 x16)
- (_.+ l32)
- (_.+ r32)))
- (_.set! x16 (low_16 x16))
-
- (_.set! x48 (|> (high_16 x32)
- (_.+ l48)
- (_.+ r48)
- low_16))
- (_.set! x32 (low_16 x32))
-
- (let [high32 (_.bit_or (up_16 x48) x32)
- low32 (_.bit_or (up_16 x16) x00)]
- (_.return (|> high32
- (_.bit_shl (_.int +32))
- (_.bit_or low32))))
- ))))
-
-(runtime: (i64//negate value)
- (let [i64//min (_.int (.int (hex "80,00,00,00,00,00,00,00")))]
- (_.if (_.=== i64//min value)
- (_.return i64//min)
- (_.return (..i64//+ (_.int +1) (_.bit_not value))))))
-
-(runtime: (i64//- parameter subject)
- (_.return (..i64//+ (..i64//negate parameter) subject)))
-
-(runtime: (i64//* parameter subject)
- (let [high_16 (..i64//right_shift (_.int +16))
- low_16 (_.bit_and (_.int (.int (hex "FFFF"))))
-
- cap_16 low_16
- hh (..i64//right_shift (_.int +48))
- hl (|>> (..i64//right_shift (_.int +32)) cap_16)
- lh (|>> (..i64//right_shift (_.int +16)) cap_16)
- ll cap_16
-
- up_16 (_.bit_shl (_.int +16))]
- (with_vars [l48 l32 l16 l00
- r48 r32 r16 r00
- x48 x32 x16 x00]
- ($_ _.then
- (_.set! l48 (hh subject))
- (_.set! l32 (hl subject))
- (_.set! l16 (lh subject))
- (_.set! l00 (ll subject))
-
- (_.set! r48 (hh parameter))
- (_.set! r32 (hl parameter))
- (_.set! r16 (lh parameter))
- (_.set! r00 (ll parameter))
-
- (_.set! x00 (_.* l00 r00))
- (_.set! x16 (high_16 x00))
- (_.set! x00 (low_16 x00))
-
- (_.set! x16 (|> x16 (_.+ (_.* l16 r00))))
- (_.set! x32 (high_16 x16)) (_.set! x16 (low_16 x16))
- (_.set! x16 (|> x16 (_.+ (_.* l00 r16))))
- (_.set! x32 (|> x32 (_.+ (high_16 x16)))) (_.set! x16 (low_16 x16))
-
- (_.set! x32 (|> x32 (_.+ (_.* l32 r00))))
- (_.set! x48 (high_16 x32)) (_.set! x32 (low_16 x32))
- (_.set! x32 (|> x32 (_.+ (_.* l16 r16))))
- (_.set! x48 (|> x48 (_.+ (high_16 x32)))) (_.set! x32 (low_16 x32))
- (_.set! x32 (|> x32 (_.+ (_.* l00 r32))))
- (_.set! x48 (|> x48 (_.+ (high_16 x32)))) (_.set! x32 (low_16 x32))
-
- (_.set! x48 (|> x48
- (_.+ (_.* l48 r00))
- (_.+ (_.* l32 r16))
- (_.+ (_.* l16 r32))
- (_.+ (_.* l00 r48))
- low_16))
-
- (let [high32 (_.bit_or (up_16 x48) x32)
- low32 (_.bit_or (up_16 x16) x00)]
- (_.return (|> high32
- (_.bit_shl (_.int +32))
- (_.bit_or low32))))
- ))))
-
-(def: runtime//i64
- Statement
- ($_ _.then
- @i64//right_shift
- @i64//char
- @i64//+
- @i64//negate
- @i64//-
- @i64//*
- ))
-
-(runtime: (text//size value)
- (_.if ..jphp?
- (_.return (_.strlen/1 [value]))
- (_.return (_.iconv_strlen/1 [value]))))
-
-(runtime: (text//index subject param start)
- (_.if (_.=== (_.string "") param)
- (_.return (..some (_.int +0)))
- (with_vars [idx]
- (_.if ..jphp?
- ($_ _.then
- (_.set! idx (_.strpos/3 [subject param start]))
- (_.if (_.=== (_.bool false) idx)
- (_.return ..none)
- (_.return (..some idx))))
- ($_ _.then
- (_.set! idx (_.iconv_strpos/3 [subject param start]))
- (_.if (_.=== (_.bool false) idx)
- (_.return ..none)
- (_.return (..some idx))))))))
-
-(def: (within? top value)
- (-> Expression Expression Computation)
- (_.and (|> value (_.>= (_.int +0)))
- (|> value (_.< top))))
-
-(runtime: (text//clip offset length text)
- (_.if ..jphp?
- (_.return (_.substr/3 [text offset length]))
- (_.return (_.iconv_substr/3 [text offset length]))))
-
-(runtime: (text//char idx text)
- (_.if (|> idx (within? (text//size text)))
- (_.if ..jphp?
- (_.return (_.ord/1 (_.substr/3 [text idx (_.int +1)])))
- (_.return (|> (_.iconv_substr/3 [text idx (_.int +1)])
- [(_.string "UTF-8") (_.string "UTF-32LE")]
- _.iconv/3
- [(_.string "V")]
- _.unpack/2
- (_.nth (_.int +1)))))
- (_.throw (_.new (_.constant "Exception") (list (_.string "[Lux Error] Cannot get char from text."))))))
-
-(def: runtime//text
- Statement
- ($_ _.then
- @text//size
- @text//index
- @text//clip
- @text//char
- ))
-
-(runtime: (f64//decode value)
- (with_vars [output]
- ($_ _.then
- (_.set! output (_.floatval/1 value))
- (_.if (_.=== (_.float +0.0) output)
- (_.if ($_ _.or
- (_.=== (_.string "0.0") output)
- (_.=== (_.string "+0.0") output)
- (_.=== (_.string "-0.0") output)
- (_.=== (_.string "0") output)
- (_.=== (_.string "+0") output)
- (_.=== (_.string "-0") output))
- (_.return (..some output))
- (_.return ..none))
- (_.return (..some output)))
- )))
-
-(def: runtime//f64
- Statement
- ($_ _.then
- @f64//decode
- ))
-
-(def: check_necessary_conditions!
- Statement
- (let [i64_support? (_.=== (_.int +8) (_.constant "PHP_INT_SIZE"))
- i64_error (_.string (format "Cannot run program!" text.new_line
- "Lux/PHP programs require 64-bit PHP builds!"))]
- (_.when (_.not i64_support?)
- (_.throw (_.new (_.constant "Exception") (list i64_error))))))
-
-(def: runtime
- Statement
- ($_ _.then
- check_necessary_conditions!
- runtime//array
- runtime//adt
- runtime//lux
- runtime//i64
- runtime//f64
- runtime//text
- runtime//io
- ))
-
-(def: #export generate
- (Operation [Registry Output])
- (do ///////phase.monad
- [_ (/////generation.execute! ..runtime)
- _ (/////generation.save! ..module_id ..runtime)]
- (wrap [(|> artifact.empty
- artifact.resource
- product.right)
- (row.row [..module_id
- (|> ..runtime
- _.code
- (\ utf8.codec encode))])])))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/structure.lux
deleted file mode 100644
index 5f7a4e358..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/structure.lux
+++ /dev/null
@@ -1,41 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [data
- [collection
- ["." list]]]
- [target
- ["_" php (#+ Expression)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." primitive]
- ["///#" //// #_
- [analysis (#+ Variant Tuple)]
- ["#." synthesis (#+ Synthesis)]
- ["//#" /// #_
- ["#." phase ("#\." monad)]]]])
-
-(def: #export (tuple expression archive elemsS+)
- (Generator (Tuple Synthesis))
- (case elemsS+
- #.Nil
- (///////phase\wrap (//primitive.text /////synthesis.unit))
-
- (#.Cons singletonS #.Nil)
- (expression archive singletonS)
-
- _
- (let [size (_.int (.int (list.size elemsS+)))]
- (|> elemsS+
- (monad.map ///////phase.monad (expression archive))
- (///////phase\map (|>> _.array/*
- (//runtime.tuple//make size)))))))
-
-(def: #export (variant expression archive [lefts right? valueS])
- (Generator (Variant Synthesis))
- (let [tag (if right?
- (inc lefts)
- lefts)]
- (///////phase\map (//runtime.variant tag right?)
- (expression archive valueS))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux
deleted file mode 100644
index 2e86ad107..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux
+++ /dev/null
@@ -1,112 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." exception (#+ exception:)]]
- [target
- ["_" python]]]
- ["." / #_
- [runtime (#+ Phase Phase!)]
- ["#." primitive]
- ["#." structure]
- ["#." reference]
- ["#." function]
- ["#." case]
- ["#." loop]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- ["#." extension]
- ["/#" // #_
- [analysis (#+)]
- ["#." synthesis]
- ["//#" /// #_
- ["#." phase ("#\." monad)]
- [reference (#+)
- [variable (#+)]]]]]]])
-
-(def: (statement expression archive synthesis)
- Phase!
- (case synthesis
- (^template [<tag>]
- [(^ (<tag> value))
- (//////phase\map _.return (expression archive synthesis))])
- ([////synthesis.bit]
- [////synthesis.i64]
- [////synthesis.f64]
- [////synthesis.text]
- [////synthesis.variant]
- [////synthesis.tuple]
- [#////synthesis.Reference]
- [////synthesis.branch/get]
- [////synthesis.function/apply]
- [#////synthesis.Extension])
-
- (^ (////synthesis.branch/case case))
- (/case.case! false statement expression archive case)
-
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (<generator> statement expression archive value)])
- ([////synthesis.branch/let /case.let!]
- [////synthesis.branch/if /case.if!]
- [////synthesis.loop/scope /loop.scope!]
- [////synthesis.loop/recur /loop.recur!])
-
- (^ (////synthesis.function/abstraction abstraction))
- (//////phase\map _.return (/function.function statement expression archive abstraction))
- ))
-
-(exception: #export cannot-recur-as-an-expression)
-
-(def: #export (expression archive synthesis)
- Phase
- (case synthesis
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (//////phase\wrap (<generator> value))])
- ([////synthesis.bit /primitive.bit]
- [////synthesis.i64 /primitive.i64]
- [////synthesis.f64 /primitive.f64]
- [////synthesis.text /primitive.text])
-
- (^ (////synthesis.variant variantS))
- (/structure.variant expression archive variantS)
-
- (^ (////synthesis.tuple members))
- (/structure.tuple expression archive members)
-
- (#////synthesis.Reference value)
- (//reference.reference /reference.system archive value)
-
- (^ (////synthesis.branch/case case))
- (/case.case ..statement expression archive case)
-
- (^ (////synthesis.branch/let let))
- (/case.let expression archive let)
-
- (^ (////synthesis.branch/if if))
- (/case.if expression archive if)
-
- (^ (////synthesis.branch/get get))
- (/case.get expression archive get)
-
- (^ (////synthesis.loop/scope scope))
- (/loop.scope ..statement expression archive scope)
-
- (^ (////synthesis.loop/recur updates))
- (//////phase.throw ..cannot-recur-as-an-expression [])
-
- (^ (////synthesis.function/abstraction abstraction))
- (/function.function ..statement expression archive abstraction)
-
- (^ (////synthesis.function/apply application))
- (/function.apply expression archive application)
-
- (#////synthesis.Extension extension)
- (///extension.apply archive expression extension)))
-
-(def: #export generate
- Phase
- ..expression)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux
deleted file mode 100644
index 28ffbb624..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux
+++ /dev/null
@@ -1,317 +0,0 @@
-(.module:
- [lux (#- case let if)
- [abstract
- ["." monad (#+ do)]]
- [control
- [exception (#+ exception:)]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." set]]]
- [math
- [number
- ["n" nat]
- ["i" int]]]
- [target
- ["_" python (#+ Expression SVar Statement)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator Phase! Generator!)]
- ["#." reference]
- ["#." primitive]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- [synthesis
- ["." case]]
- ["/#" // #_
- ["#." synthesis (#+ Member Synthesis Path)]
- ["#." generation]
- ["//#" /// #_
- [reference
- ["#." variable (#+ Register)]]
- ["#." phase ("#\." monad)]
- [meta
- [archive (#+ Archive)]]]]]]])
-
-(def: #export (gensym prefix)
- (-> Text (Operation SVar))
- (///////phase\map (|>> %.nat (format prefix) _.var) /////generation.next))
-
-(def: #export register
- (-> Register SVar)
- (|>> (///reference.local //reference.system) :assume))
-
-(def: #export capture
- (-> Register SVar)
- (|>> (///reference.foreign //reference.system) :assume))
-
-(def: #export (let expression archive [valueS register bodyS])
- (Generator [Synthesis Register Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)
- bodyO (expression archive bodyS)]
- ## TODO: Find some way to do 'let' without paying the price of the closure.
- (wrap (_.apply/* (_.lambda (list (..register register))
- bodyO)
- (list valueO)))))
-
-(def: #export (let! statement expression archive [valueS register bodyS])
- (Generator! [Synthesis Register Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)
- bodyO (statement expression archive bodyS)]
- (wrap ($_ _.then
- (_.set (list (..register register)) valueO)
- bodyO))))
-
-(def: #export (if expression archive [testS thenS elseS])
- (Generator [Synthesis Synthesis Synthesis])
- (do ///////phase.monad
- [testO (expression archive testS)
- thenO (expression archive thenS)
- elseO (expression archive elseS)]
- (wrap (_.? testO thenO elseO))))
-
-(def: #export (if! statement expression archive [testS thenS elseS])
- (Generator! [Synthesis Synthesis Synthesis])
- (do ///////phase.monad
- [test! (expression archive testS)
- then! (statement expression archive thenS)
- else! (statement expression archive elseS)]
- (wrap (_.if test!
- then!
- else!))))
-
-(def: #export (get expression archive [pathP valueS])
- (Generator [(List Member) Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)]
- (wrap (list\fold (function (_ side source)
- (.let [method (.case side
- (^template [<side> <accessor>]
- [(<side> lefts)
- (<accessor> (_.int (.int lefts)))])
- ([#.Left //runtime.tuple::left]
- [#.Right //runtime.tuple::right]))]
- (method source)))
- valueO
- (list.reverse pathP)))))
-
-(def: @savepoint (_.var "lux_pm_savepoint"))
-(def: @cursor (_.var "lux_pm_cursor"))
-(def: @temp (_.var "lux_pm_temp"))
-
-(def: (push! value)
- (-> (Expression Any) (Statement Any))
- (_.statement (|> @cursor (_.do "append" (list value)))))
-
-(def: peek_and_pop
- (Expression Any)
- (|> @cursor (_.do "pop" (list))))
-
-(def: pop!
- (Statement Any)
- (_.statement ..peek_and_pop))
-
-(def: peek
- (Expression Any)
- (_.nth (_.int -1) @cursor))
-
-(def: save!
- (Statement Any)
- (.let [cursor (_.slice_from (_.int +0) @cursor)]
- (_.statement (|> @savepoint (_.do "append" (list cursor))))))
-
-(def: restore!
- (Statement Any)
- (_.set (list @cursor) (|> @savepoint (_.do "pop" (list)))))
-
-(def: fail_pm! _.break)
-
-(def: (multi_pop! pops)
- (-> Nat (Statement Any))
- (_.delete (_.slice_from (_.int (i.* -1 (.int pops))) @cursor)))
-
-(template [<name> <flag> <prep>]
- [(def: (<name> simple? idx)
- (-> Bit Nat (Statement Any))
- ($_ _.then
- (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum::get ..peek <flag>)))
- (.if simple?
- (_.when (_.= _.none @temp)
- fail_pm!)
- (_.if (_.= _.none @temp)
- fail_pm!
- (..push! @temp))
- )))]
-
- [left_choice _.none (<|)]
- [right_choice (_.string "") inc]
- )
-
-(def: (with_looping in_closure? g!once body!)
- (-> Bit SVar (Statement Any) (Statement Any))
- (.if in_closure?
- (_.while (_.bool true)
- body!
- #.None)
- ($_ _.then
- (_.set (list g!once) (_.bool true))
- (_.while g!once
- ($_ _.then
- (_.set (list g!once) (_.bool false))
- body!)
- (#.Some _.continue)))))
-
-(def: (alternation in_closure? g!once pre! post!)
- (-> Bit SVar (Statement Any) (Statement Any) (Statement Any))
- ($_ _.then
- (..with_looping in_closure? g!once
- ($_ _.then
- ..save!
- pre!))
- ..restore!
- post!))
-
-(def: (pattern_matching' in_closure? statement expression archive)
- (-> Bit Phase! Phase Archive Path (Operation (Statement Any)))
- (function (recur pathP)
- (.case pathP
- (#/////synthesis.Then bodyS)
- (statement expression archive bodyS)
-
- #/////synthesis.Pop
- (///////phase\wrap ..pop!)
-
- (#/////synthesis.Bind register)
- (///////phase\wrap (_.set (list (..register register)) ..peek))
-
- (#/////synthesis.Bit_Fork when thenP elseP)
- (do {! ///////phase.monad}
- [then! (recur thenP)
- else! (.case elseP
- (#.Some elseP)
- (recur elseP)
-
- #.None
- (wrap ..fail_pm!))]
- (wrap (.if when
- (_.if ..peek
- then!
- else!)
- (_.if ..peek
- else!
- then!))))
-
- (^template [<tag> <format>]
- [(<tag> cons)
- (do {! ///////phase.monad}
- [clauses (monad.map ! (function (_ [match then])
- (\ ! map
- (|>> [(_.= (|> match <format>)
- ..peek)])
- (recur then)))
- (#.Cons cons))]
- (wrap (_.cond clauses
- ..fail_pm!)))])
- ([#/////synthesis.I64_Fork (<| //primitive.i64 .int)]
- [#/////synthesis.F64_Fork (<| //primitive.f64)]
- [#/////synthesis.Text_Fork (<| //primitive.text)])
-
- (^template [<complex> <simple> <choice>]
- [(^ (<complex> idx))
- (///////phase\wrap (<choice> false idx))
-
- (^ (<simple> idx nextP))
- (|> nextP
- recur
- (///////phase\map (_.then (<choice> true idx))))])
- ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice]
- [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice])
-
- (^ (/////synthesis.member/left 0))
- (///////phase\wrap (|> ..peek (_.nth (_.int +0)) ..push!))
-
- (^template [<pm> <getter>]
- [(^ (<pm> lefts))
- (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))])
- ([/////synthesis.member/left //runtime.tuple::left]
- [/////synthesis.member/right //runtime.tuple::right])
-
- (^ (/////synthesis.!bind_top register thenP))
- (do ///////phase.monad
- [then! (recur thenP)]
- (///////phase\wrap ($_ _.then
- (_.set (list (..register register)) ..peek_and_pop)
- then!)))
-
- (^ (/////synthesis.!multi_pop nextP))
- (.let [[extra_pops nextP'] (case.count_pops nextP)]
- (do ///////phase.monad
- [next! (recur nextP')]
- (///////phase\wrap ($_ _.then
- (..multi_pop! (n.+ 2 extra_pops))
- next!))))
-
- (^ (/////synthesis.path/seq preP postP))
- (do ///////phase.monad
- [pre! (recur preP)
- post! (recur postP)]
- (wrap (_.then pre! post!)))
-
- (^ (/////synthesis.path/alt preP postP))
- (do ///////phase.monad
- [pre! (recur preP)
- post! (recur postP)
- g!once (..gensym "once")]
- (wrap (..alternation in_closure? g!once pre! post!))))))
-
-(def: (pattern_matching in_closure? statement expression archive pathP)
- (-> Bit Phase! Phase Archive Path (Operation (Statement Any)))
- (do ///////phase.monad
- [pattern_matching! (pattern_matching' in_closure? statement expression archive pathP)
- g!once (..gensym "once")]
- (wrap ($_ _.then
- (..with_looping in_closure? g!once
- pattern_matching!)
- (_.raise (_.Exception/1 (_.string case.pattern_matching_error)))))))
-
-(def: #export dependencies
- (-> Path (List SVar))
- (|>> case.storage
- (get@ #case.dependencies)
- set.to_list
- (list\map (function (_ variable)
- (.case variable
- (#///////variable.Local register)
- (..register register)
-
- (#///////variable.Foreign register)
- (..capture register))))))
-
-(def: #export (case! in_closure? statement expression archive [valueS pathP])
- (-> Bit (Generator! [Synthesis Path]))
- (do ///////phase.monad
- [stack_init (expression archive valueS)
- pattern_matching! (pattern_matching in_closure? statement expression archive pathP)]
- (wrap ($_ _.then
- (_.set (list @cursor) (_.list (list stack_init)))
- (_.set (list @savepoint) (_.list (list)))
- pattern_matching!
- ))))
-
-(def: #export (case statement expression archive [valueS pathP])
- (-> Phase! (Generator [Synthesis Path]))
- (do ///////phase.monad
- [[[case_module case_artifact] pattern_matching!] (/////generation.with_new_context archive
- (case! true statement expression archive [valueS pathP]))
- #let [@case (_.var (///reference.artifact [case_module case_artifact]))
- @dependencies+ (..dependencies (/////synthesis.path/seq (/////synthesis.path/then valueS)
- pathP))
- directive (_.def @case @dependencies+
- pattern_matching!)]
- _ (/////generation.execute! directive)
- _ (/////generation.save! case_artifact directive)]
- (wrap (_.apply/* @case @dependencies+))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux
deleted file mode 100644
index cc670d277..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux
+++ /dev/null
@@ -1,111 +0,0 @@
-(.module:
- [lux (#- function)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [target
- ["_" python (#+ SVar Expression Statement)]]]
- ["." // #_
- [runtime (#+ Operation Phase Generator Phase! Generator!)]
- ["#." reference]
- ["#." case]
- ["#." loop]
- ["/#" // #_
- ["#." reference]
- ["//#" /// #_
- [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)]
- [synthesis (#+ Synthesis)]
- ["#." generation (#+ Context)]
- ["//#" /// #_
- [arity (#+ Arity)]
- ["#." phase]
- [reference
- [variable (#+ Register Variable)]]
- [meta
- [archive (#+ Archive)
- ["." artifact]]]]]]])
-
-(def: #export (apply expression archive [functionS argsS+])
- (Generator (Application Synthesis))
- (do {! ///////phase.monad}
- [functionO (expression archive functionS)
- argsO+ (monad.map ! (expression archive) argsS+)]
- (wrap (_.apply/* functionO argsO+))))
-
-(def: #export capture
- (-> Register SVar)
- (|>> (///reference.foreign //reference.system) :assume))
-
-(def: (with_closure function_id @function inits function_definition)
- (-> artifact.ID SVar (List (Expression Any)) (Statement Any) (Operation (Expression Any)))
- (case inits
- #.Nil
- (do ///////phase.monad
- [_ (/////generation.execute! function_definition)
- _ (/////generation.save! function_id function_definition)]
- (wrap @function))
-
- _
- (do {! ///////phase.monad}
- [#let [directive (_.def @function
- (|> (list.enumeration inits)
- (list\map (|>> product.left ..capture)))
- ($_ _.then
- function_definition
- (_.return @function)))]
- _ (/////generation.execute! directive)
- _ (/////generation.save! function_id directive)]
- (wrap (_.apply/* @function inits)))))
-
-(def: input
- (|>> inc //case.register))
-
-(def: #export (function statement expression archive [environment arity bodyS])
- (-> Phase! (Generator (Abstraction Synthesis)))
- (do {! ///////phase.monad}
- [[[function_module function_artifact] body!] (/////generation.with_new_context archive
- (/////generation.with_anchor 1
- (statement expression archive bodyS)))
- environment (monad.map ! (expression archive) environment)
- #let [@curried (_.var "curried")
- arityO (|> arity .int _.int)
- @num_args (_.var "num_args")
- @self (_.var (///reference.artifact [function_module function_artifact]))
- apply_poly (.function (_ args func)
- (_.apply_poly (list) args func))
- initialize_self! (_.set (list (//case.register 0)) @self)
- initialize! (list\fold (.function (_ post pre!)
- ($_ _.then
- pre!
- (_.set (list (..input post)) (_.nth (|> post .int _.int) @curried))))
- initialize_self!
- (list.indices arity))]]
- (with_closure function_artifact @self environment
- (_.def @self (list (_.poly @curried))
- ($_ _.then
- (_.set (list @num_args) (_.len/1 @curried))
- (_.cond (list [(|> @num_args (_.= arityO))
- (<| (_.then initialize!)
- //loop.set_scope
- body!)]
- [(|> @num_args (_.> arityO))
- (let [arity_inputs (_.slice (_.int +0) arityO @curried)
- extra_inputs (_.slice arityO @num_args @curried)]
- (_.return (|> @self
- (apply_poly arity_inputs)
- (apply_poly extra_inputs))))])
- ## (|> @num_args (_.< arityO))
- (let [@next (_.var "next")
- @missing (_.var "missing")]
- ($_ _.then
- (_.def @next (list (_.poly @missing))
- (_.return (|> @self (apply_poly (|> @curried (_.+ @missing))))))
- (_.return @next)
- )))
- )))
- ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux
deleted file mode 100644
index 0f932ee38..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux
+++ /dev/null
@@ -1,121 +0,0 @@
-(.module:
- [lux (#- Scope)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." set]]]
- [math
- [number
- ["n" nat]]]
- [target
- ["_" python (#+ Expression SVar Statement)]]]
- ["." // #_
- [runtime (#+ Operation Phase Generator Phase! Generator!)]
- ["#." case]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- [synthesis
- ["." case]]
- ["/#" // #_
- ["." synthesis (#+ Scope Synthesis)]
- ["#." generation]
- ["//#" /// #_
- ["#." phase]
- [reference
- ["#." variable (#+ Register)]]]]]]])
-
-(def: (setup offset bindings body)
- (-> Register (List (Expression Any)) (Statement Any) (Statement Any))
- (|> bindings
- list.enumeration
- (list\map (function (_ [register value])
- (_.set (list (//case.register (n.+ offset register)))
- value)))
- list.reverse
- (list\fold _.then body)))
-
-(def: #export (set_scope body!)
- (-> (Statement Any) (Statement Any))
- (_.while (_.bool true)
- body!
- #.None))
-
-(def: #export (scope! statement expression archive [start initsS+ bodyS])
- (Generator! (Scope Synthesis))
- (case initsS+
- ## function/false/non-independent loop
- #.Nil
- (statement expression archive bodyS)
-
- ## true loop
- _
- (do {! ///////phase.monad}
- [initsO+ (monad.map ! (expression archive) initsS+)
- body! (/////generation.with_anchor start
- (statement expression archive bodyS))]
- (wrap (<| (..setup start initsO+)
- ..set_scope
- body!)))))
-
-(def: #export (scope statement expression archive [start initsS+ bodyS])
- (-> Phase! (Generator (Scope Synthesis)))
- (case initsS+
- ## function/false/non-independent loop
- #.Nil
- (expression archive bodyS)
-
- ## true loop
- _
- (do {! ///////phase.monad}
- [initsO+ (monad.map ! (expression archive) initsS+)
- [[loop_module loop_artifact] body!] (/////generation.with_new_context archive
- (/////generation.with_anchor start
- (statement expression archive bodyS)))
- #let [@loop (_.var (///reference.artifact [loop_module loop_artifact]))
- locals (|> initsS+
- list.enumeration
- (list\map (|>> product.left (n.+ start) //case.register)))
- actual_loop (<| (_.def @loop locals)
- ..set_scope
- body!)
- [directive instantiation] (: [(Statement Any) (Expression Any)]
- (case (|> (synthesis.path/then bodyS)
- //case.dependencies
- (set.from_list _.hash)
- (set.difference (set.from_list _.hash locals))
- set.to_list)
- #.Nil
- [actual_loop
- @loop]
-
- foreigns
- [(_.def @loop foreigns
- ($_ _.then
- actual_loop
- (_.return @loop)
- ))
- (_.apply/* @loop foreigns)]))]
- _ (/////generation.execute! directive)
- _ (/////generation.save! loop_artifact directive)]
- (wrap (_.apply/* instantiation initsO+)))))
-
-(def: #export (recur! statement expression archive argsS+)
- (Generator! (List Synthesis))
- (do {! ///////phase.monad}
- [offset /////generation.anchor
- @temp (//case.gensym "lux_recur_values")
- argsO+ (monad.map ! (expression archive) argsS+)
- #let [re_binds (|> argsO+
- list.enumeration
- (list\map (function (_ [idx _])
- (_.nth (_.int (.int idx)) @temp))))]]
- (wrap ($_ _.then
- (_.set (list @temp) (_.list argsO+))
- (..setup offset re_binds
- _.continue)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux
deleted file mode 100644
index ec8889281..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux
+++ /dev/null
@@ -1,17 +0,0 @@
-(.module:
- [lux (#- i64)
- [target
- ["_" python (#+ Expression)]]]
- ["." // #_
- ["#." runtime]])
-
-(template [<type> <name> <implementation>]
- [(def: #export <name>
- (-> <type> (Expression Any))
- <implementation>)]
-
- [Bit bit _.bool]
- [(I64 Any) i64 (|>> .int _.int //runtime.i64::64)]
- [Frac f64 _.float]
- [Text text _.unicode]
- )
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/reference.lux
deleted file mode 100644
index 1fe57fb8c..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/reference.lux
+++ /dev/null
@@ -1,12 +0,0 @@
-(.module:
- [lux #*
- [target
- ["_" python (#+ Expression)]]]
- [///
- [reference (#+ System)]])
-
-(implementation: #export system
- (System (Expression Any))
-
- (def: constant _.var)
- (def: variable _.var))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux
deleted file mode 100644
index b77d0c915..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux
+++ /dev/null
@@ -1,455 +0,0 @@
-(.module:
- [lux (#- inc)
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<.>" code]]]
- [data
- ["." product]
- ["." text ("#\." hash)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." list ("#\." functor)]
- ["." row]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number (#+ hex)
- ["f" frac]
- ["." i64]]]
- ["@" target
- ["_" python (#+ Expression SVar Computation Literal Statement)]]]
- ["." /// #_
- ["#." reference]
- ["//#" /// #_
- ["$" version]
- ["#." synthesis (#+ Synthesis)]
- ["#." generation]
- ["//#" ///
- ["#." phase]
- [reference
- [variable (#+ Register)]]
- [meta
- [archive (#+ Output Archive)
- ["." artifact (#+ Registry)]]]]]])
-
-(template [<name> <base>]
- [(type: #export <name>
- (<base> Register (Expression Any) (Statement Any)))]
-
- [Operation /////generation.Operation]
- [Phase /////generation.Phase]
- [Handler /////generation.Handler]
- [Bundle /////generation.Bundle]
- )
-
-(type: #export Phase!
- (-> Phase Archive Synthesis (Operation (Statement Any))))
-
-(type: #export (Generator! i)
- (-> Phase! Phase Archive i (Operation (Statement Any))))
-
-(type: #export (Generator i)
- (-> Phase Archive i (Operation (Expression Any))))
-
-(def: prefix
- "LuxRuntime")
-
-(def: #export
- unit
- (_.unicode /////synthesis.unit))
-
-(def: (flag value)
- (-> Bit Literal)
- (if value
- ..unit
- _.none))
-
-(def: (variant' tag last? value)
- (-> (Expression Any) (Expression Any) (Expression Any) Literal)
- (_.tuple (list tag last? value)))
-
-(def: #export (variant tag last? value)
- (-> Nat Bit (Expression Any) Literal)
- (variant' (_.int (.int tag))
- (flag last?)
- value))
-
-(def: #export none
- Literal
- (..variant 0 #0 unit))
-
-(def: #export some
- (-> (Expression Any) Literal)
- (..variant 1 #1))
-
-(def: #export left
- (-> (Expression Any) Literal)
- (..variant 0 #0))
-
-(def: #export right
- (-> (Expression Any) Literal)
- (..variant 1 #1))
-
-(def: (runtime_name name)
- (-> Text SVar)
- (let [identifier (format ..prefix
- "_" (%.nat $.version)
- "_" (%.nat (text\hash name)))]
- (_.var identifier)))
-
-(def: (feature name definition)
- (-> SVar (-> SVar (Statement Any)) (Statement Any))
- (definition name))
-
-(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
- body)
- (do {! meta.monad}
- [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
- (wrap (list (` (let [(~+ (|> vars
- (list.zip/2 ids)
- (list\map (function (_ [id var])
- (list (code.local_identifier var)
- (` (_.var (~ (code.text (format "v" (%.nat id)))))))))
- list.concat))]
- (~ body)))))))
-
-(syntax: (runtime: {declaration (<>.or <code>.local_identifier
- (<code>.form (<>.and <code>.local_identifier
- (<>.some <code>.local_identifier))))}
- code)
- (case declaration
- (#.Left name)
- (macro.with_gensyms [g!_]
- (let [nameC (code.local_identifier name)
- code_nameC (code.local_identifier (format "@" name))
- runtime_nameC (` (runtime_name (~ (code.text name))))]
- (wrap (list (` (def: #export (~ nameC) SVar (~ runtime_nameC)))
- (` (def: (~ code_nameC)
- (Statement Any)
- (..feature (~ runtime_nameC)
- (function ((~ g!_) (~ g!_))
- (_.set (list (~ g!_)) (~ code))))))))))
-
- (#.Right [name inputs])
- (macro.with_gensyms [g!_]
- (let [nameC (code.local_identifier name)
- code_nameC (code.local_identifier (format "@" name))
- runtime_nameC (` (runtime_name (~ (code.text name))))
- inputsC (list\map code.local_identifier inputs)
- inputs_typesC (list\map (function.constant (` (_.Expression Any)))
- inputs)]
- (wrap (list (` (def: #export ((~ nameC) (~+ inputsC))
- (-> (~+ inputs_typesC) (Computation Any))
- (_.apply/* (~ runtime_nameC) (list (~+ inputsC)))))
- (` (def: (~ code_nameC)
- (Statement Any)
- (..feature (~ runtime_nameC)
- (function ((~ g!_) (~ g!_))
- (..with_vars [(~+ inputsC)]
- (_.def (~ g!_) (list (~+ inputsC))
- (~ code)))))))))))))
-
-(runtime: (lux::try op)
- (with_vars [exception]
- (_.try (_.return (..right (_.apply/* op (list ..unit))))
- (list [(list (_.var "Exception")) exception
- (_.return (..left (_.str/1 exception)))]))))
-
-(runtime: (lux::program_args program_args)
- (with_vars [inputs value]
- ($_ _.then
- (_.set (list inputs) ..none)
- (<| (_.for_in value (_.apply/* (_.var "reversed") (list program_args)))
- (_.set (list inputs)
- (..some (_.list (list value inputs)))))
- (_.return inputs))))
-
-(runtime: (lux::exec code globals)
- ($_ _.then
- (_.exec code (#.Some globals))
- (_.return ..unit)))
-
-(def: runtime::lux
- (Statement Any)
- ($_ _.then
- @lux::try
- @lux::program_args
- @lux::exec
- ))
-
-(runtime: (io::log! message)
- ($_ _.then
- (_.print message)
- (_.return ..unit)))
-
-(runtime: (io::throw! message)
- (_.raise (_.Exception/1 message)))
-
-(def: runtime::io
- (Statement Any)
- ($_ _.then
- @io::log!
- @io::throw!
- ))
-
-(def: last_index
- (|>> _.len/1 (_.- (_.int +1))))
-
-(with_expansions [<recur> (as_is ($_ _.then
- (_.set (list lefts) (_.- last_index_right lefts))
- (_.set (list tuple) (_.nth last_index_right tuple))))]
- (runtime: (tuple::left lefts tuple)
- (with_vars [last_index_right]
- (_.while (_.bool true)
- ($_ _.then
- (_.set (list last_index_right) (..last_index tuple))
- (_.if (_.> lefts last_index_right)
- ## No need for recursion
- (_.return (_.nth lefts tuple))
- ## Needs recursion
- <recur>))
- #.None)))
-
- (runtime: (tuple::right lefts tuple)
- (with_vars [last_index_right right_index]
- (_.while (_.bool true)
- ($_ _.then
- (_.set (list last_index_right) (..last_index tuple))
- (_.set (list right_index) (_.+ (_.int +1) lefts))
- (_.cond (list [(_.= last_index_right right_index)
- (_.return (_.nth right_index tuple))]
- [(_.> last_index_right right_index)
- ## Needs recursion.
- <recur>])
- (_.return (_.slice_from right_index tuple))))
- #.None))))
-
-(runtime: (sum::get sum wantsLast wantedTag)
- (let [no_match! (_.return _.none)
- sum_tag (_.nth (_.int +0) sum)
- sum_flag (_.nth (_.int +1) sum)
- sum_value (_.nth (_.int +2) sum)
- is_last? (_.= ..unit sum_flag)
- test_recursion! (_.if is_last?
- ## Must recurse.
- ($_ _.then
- (_.set (list wantedTag) (_.- sum_tag wantedTag))
- (_.set (list sum) sum_value))
- no_match!)]
- (_.while (_.bool true)
- (_.cond (list [(_.= wantedTag sum_tag)
- (_.if (_.= wantsLast sum_flag)
- (_.return sum_value)
- test_recursion!)]
-
- [(_.< wantedTag sum_tag)
- test_recursion!]
-
- [(_.= ..unit wantsLast)
- (_.return (variant' (_.- wantedTag sum_tag) sum_flag sum_value))])
-
- no_match!)
- #.None)))
-
-(def: runtime::adt
- (Statement Any)
- ($_ _.then
- @tuple::left
- @tuple::right
- @sum::get
- ))
-
-(def: i64::+limit (_.manual "+0x7FFFFFFFFFFFFFFF"))
-(def: i64::-limit (_.manual "-0x8000000000000000"))
-(def: i64::+iteration (_.manual "+0x10000000000000000"))
-(def: i64::-iteration (_.manual "-0x10000000000000000"))
-(def: i64::+cap (_.manual "+0x8000000000000000"))
-(def: i64::-cap (_.manual "-0x8000000000000001"))
-
-(runtime: (i64::64 input)
- (with_vars [temp]
- (`` (<| (~~ (template [<scenario> <iteration> <cap> <entrance>]
- [(_.if (|> input <scenario>)
- ($_ _.then
- (_.set (list temp) (_.% <iteration> input))
- (_.return (_.? (|> temp <scenario>)
- (|> temp (_.- <cap>) (_.+ <entrance>))
- temp))))]
-
- [(_.> ..i64::+limit) ..i64::+iteration ..i64::+cap ..i64::-limit]
- [(_.< ..i64::-limit) ..i64::-iteration ..i64::-cap ..i64::+limit]
- ))
- (_.return (for {@.python input}
- ## This +- is only necessary to guarantee that values within the limits are always longs in Python 2
- (|> input (_.+ ..i64::+limit) (_.- ..i64::+limit))))))))
-
-(def: as_nat
- (_.% ..i64::+iteration))
-
-(runtime: (i64::left_shift param subject)
- (_.return (|> subject
- (_.bit_shl (_.% (_.int +64) param))
- ..i64::64)))
-
-(runtime: (i64::right_shift param subject)
- ($_ _.then
- (_.set (list param) (_.% (_.int +64) param))
- (_.return (_.? (_.= (_.int +0) param)
- subject
- (|> subject
- ..as_nat
- (_.bit_shr param))))))
-
-(runtime: (i64::division param subject)
- (with_vars [floored]
- ($_ _.then
- (_.set (list floored) (_.// param subject))
- (_.return (let [potentially_floored? (_.< (_.int +0) floored)
- inexact? (|> subject
- (_.% param)
- (_.= (_.int +0))
- _.not)]
- (_.? (_.and potentially_floored?
- inexact?)
- (_.+ (_.int +1) floored)
- floored))))))
-
-(runtime: (i64::remainder param subject)
- (_.return (_.- (|> subject (..i64::division param) (_.* param))
- subject)))
-
-(template [<runtime> <host>]
- [(runtime: (<runtime> left right)
- (_.return (..i64::64 (<host> (..as_nat left) (..as_nat right)))))]
-
- [i64::and _.bit_and]
- [i64::or _.bit_or]
- [i64::xor _.bit_xor]
- )
-
-(def: python_version
- (Expression Any)
- (|> (_.__import__/1 (_.unicode "sys"))
- (_.the "version_info")
- (_.the "major")))
-
-(runtime: (i64::char value)
- (_.return (_.? (_.= (_.int +3) ..python_version)
- (_.chr/1 value)
- (_.unichr/1 value))))
-
-(def: runtime::i64
- (Statement Any)
- ($_ _.then
- @i64::64
- @i64::left_shift
- @i64::right_shift
- @i64::division
- @i64::remainder
- @i64::and
- @i64::or
- @i64::xor
- @i64::char
- ))
-
-(runtime: (f64::/ parameter subject)
- (_.return (_.? (_.= (_.float +0.0) parameter)
- (<| (_.? (_.> (_.float +0.0) subject)
- (_.float f.positive_infinity))
- (_.? (_.< (_.float +0.0) subject)
- (_.float f.negative_infinity))
- (_.float f.not_a_number))
- (_./ parameter subject))))
-
-(runtime: (f64::decode input)
- (with_vars [ex]
- (_.try
- (_.return (..some (_.float/1 input)))
- (list [(list (_.var "Exception")) ex
- (_.return ..none)]))))
-
-(def: runtime::f64
- (Statement Any)
- ($_ _.then
- @f64::/
- @f64::decode
- ))
-
-(runtime: (text::index start param subject)
- (with_vars [idx]
- ($_ _.then
- (_.set (list idx) (|> subject (_.do "find" (list param start))))
- (_.return (_.? (_.= (_.int -1) idx)
- ..none
- (..some (..i64::64 idx)))))))
-
-(def: inc
- (|>> (_.+ (_.int +1))))
-
-(def: (within? top value)
- (-> (Expression Any) (Expression Any) (Computation Any))
- (_.and (|> value (_.>= (_.int +0)))
- (|> value (_.< top))))
-
-(runtime: (text::clip @offset @length @text)
- (_.return (|> @text (_.slice @offset (_.+ @offset @length)))))
-
-(runtime: (text::char idx text)
- (_.if (|> idx (within? (_.len/1 text)))
- (_.return (|> text (_.slice idx (..inc idx)) _.ord/1 ..i64::64))
- (_.raise (_.Exception/1 (_.unicode "[Lux Error] Cannot get char from text.")))))
-
-(def: runtime::text
- (Statement Any)
- ($_ _.then
- @text::index
- @text::clip
- @text::char
- ))
-
-(runtime: (array::write idx value array)
- ($_ _.then
- (_.set (list (_.nth idx array)) value)
- (_.return array)))
-
-(def: runtime::array
- (Statement Any)
- ($_ _.then
- @array::write
- ))
-
-(def: runtime
- (Statement Any)
- ($_ _.then
- runtime::lux
- runtime::io
- runtime::adt
- runtime::i64
- runtime::f64
- runtime::text
- runtime::array
- ))
-
-(def: module_id
- 0)
-
-(def: #export generate
- (Operation [Registry Output])
- (/////generation.with_buffer
- (do ///////phase.monad
- [_ (/////generation.execute! ..runtime)
- _ (/////generation.save! ..module_id ..runtime)]
- (wrap [(|> artifact.empty
- artifact.resource
- product.right)
- (row.row [..module_id
- (|> ..runtime
- _.code
- (\ utf8.codec encode))])]))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/structure.lux
deleted file mode 100644
index c5edce4a7..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/structure.lux
+++ /dev/null
@@ -1,36 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [target
- ["_" python (#+ Expression)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." primitive]
- ["///#" //// #_
- [analysis (#+ Variant Tuple)]
- ["#." synthesis (#+ Synthesis)]
- ["//#" /// #_
- ["#." phase ("#\." monad)]]]])
-
-(def: #export (tuple generate archive elemsS+)
- (Generator (Tuple Synthesis))
- (case elemsS+
- #.Nil
- (///////phase\wrap (//primitive.text /////synthesis.unit))
-
- (#.Cons singletonS #.Nil)
- (generate archive singletonS)
-
- _
- (|> elemsS+
- (monad.map ///////phase.monad (generate archive))
- (///////phase\map _.list))))
-
-(def: #export (variant generate archive [lefts right? valueS])
- (Generator (Variant Synthesis))
- (let [tag (if right?
- (inc lefts)
- lefts)]
- (///////phase\map (//runtime.variant tag right?)
- (generate archive valueS))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux
deleted file mode 100644
index b4b3e6423..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux
+++ /dev/null
@@ -1,58 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [target
- ["_" r]]]
- ["." / #_
- [runtime (#+ Phase)]
- ["#." primitive]
- ["#." structure]
- ["#." reference]
- ["#." case]
- ["#." loop]
- ["#." function]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- ["#." extension]
- ["/#" // #_
- [analysis (#+)]
- ["#." synthesis]
- ["//#" /// #_
- ["#." phase ("#\." monad)]
- [reference (#+)
- [variable (#+)]]]]]]])
-
-(def: #export (generate archive synthesis)
- Phase
- (case synthesis
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (//////phase\wrap (<generator> value))])
- ([////synthesis.bit /primitive.bit]
- [////synthesis.i64 /primitive.i64]
- [////synthesis.f64 /primitive.f64]
- [////synthesis.text /primitive.text])
-
- (#////synthesis.Reference value)
- (//reference.reference /reference.system archive value)
-
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (<generator> generate archive value)])
- ([////synthesis.variant /structure.variant]
- [////synthesis.tuple /structure.tuple]
- [////synthesis.branch/let /case.let]
- [////synthesis.branch/if /case.if]
- [////synthesis.branch/get /case.get]
- [////synthesis.function/apply /function.apply]
-
- [////synthesis.branch/case /case.case]
- [////synthesis.loop/scope /loop.scope]
- [////synthesis.loop/recur /loop.recur]
- [////synthesis.function/abstraction /function.function])
-
- (#////synthesis.Extension extension)
- (///extension.apply archive generate extension)
- ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux
deleted file mode 100644
index fe4e4a7c2..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux
+++ /dev/null
@@ -1,239 +0,0 @@
-(.module:
- [lux (#- case let if)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." set]]]
- [macro
- ["." template]]
- [math
- [number
- ["i" int]]]
- [target
- ["_" r (#+ Expression SVar)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." reference]
- ["#." primitive]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- ["#." synthesis #_
- ["#/." case]]
- ["/#" // #_
- ["#." synthesis (#+ Member Synthesis Path)]
- ["#." generation]
- ["//#" /// #_
- [reference
- ["#." variable (#+ Register)]]
- ["#." phase ("#\." monad)]
- [meta
- [archive (#+ Archive)]]]]]]])
-
-(def: #export register
- (-> Register SVar)
- (|>> (///reference.local //reference.system) :assume))
-
-(def: #export capture
- (-> Register SVar)
- (|>> (///reference.foreign //reference.system) :assume))
-
-(def: #export (let expression archive [valueS register bodyS])
- (Generator [Synthesis Register Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)
- bodyO (expression archive bodyS)]
- (wrap (_.block
- ($_ _.then
- (_.set! (..register register) valueO)
- bodyO)))))
-
-(def: #export (if expression archive [testS thenS elseS])
- (Generator [Synthesis Synthesis Synthesis])
- (do ///////phase.monad
- [testO (expression archive testS)
- thenO (expression archive thenS)
- elseO (expression archive elseS)]
- (wrap (_.if testO thenO elseO))))
-
-(def: #export (get expression archive [pathP valueS])
- (Generator [(List Member) Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)]
- (wrap (list\fold (function (_ side source)
- (.let [method (.case side
- (^template [<side> <accessor>]
- [(<side> lefts)
- (<accessor> (_.int (.int lefts)))])
- ([#.Left //runtime.tuple::left]
- [#.Right //runtime.tuple::right]))]
- (method source)))
- valueO
- (list.reverse pathP)))))
-
-(def: $savepoint (_.var "lux_pm_cursor_savepoint"))
-(def: $cursor (_.var "lux_pm_cursor"))
-(def: $temp (_.var "lux_pm_temp"))
-(def: $alt_error (_.var "alt_error"))
-
-(def: top
- _.length)
-
-(def: next
- (|>> _.length (_.+ (_.int +1))))
-
-(def: (push! value var)
- (-> Expression SVar Expression)
- (_.set_nth! (next var) value var))
-
-(def: (pop! var)
- (-> SVar Expression)
- (_.set_nth! (top var) _.null var))
-
-(def: (push_cursor! value)
- (-> Expression Expression)
- (push! value $cursor))
-
-(def: save_cursor!
- Expression
- (push! (_.slice (_.float +1.0) (_.length $cursor) $cursor)
- $savepoint))
-
-(def: restore_cursor!
- Expression
- (_.set! $cursor (_.nth (top $savepoint) $savepoint)))
-
-(def: peek
- Expression
- (|> $cursor (_.nth (top $cursor))))
-
-(def: pop_cursor!
- Expression
- (pop! $cursor))
-
-(def: error
- (_.string (template.with_locals [error]
- (template.text [error]))))
-
-(def: fail!
- (_.stop ..error))
-
-(def: (catch handler)
- (-> Expression Expression)
- (_.function (list $alt_error)
- (_.if (|> $alt_error (_.= ..error))
- handler
- (_.stop $alt_error))))
-
-(def: (pattern_matching' expression archive)
- (Generator Path)
- (function (recur pathP)
- (.case pathP
- (#/////synthesis.Then bodyS)
- (expression archive bodyS)
-
- #/////synthesis.Pop
- (///////phase\wrap ..pop_cursor!)
-
- (#/////synthesis.Bind register)
- (///////phase\wrap (_.set! (..register register) ..peek))
-
- (#/////synthesis.Bit_Fork when thenP elseP)
- (do {! ///////phase.monad}
- [then! (recur thenP)
- else! (.case elseP
- (#.Some elseP)
- (recur elseP)
-
- #.None
- (wrap ..fail!))]
- (wrap (.if when
- (_.if ..peek
- then!
- else!)
- (_.if ..peek
- else!
- then!))))
-
- (^template [<tag> <format> <=>]
- [(<tag> cons)
- (do {! ///////phase.monad}
- [clauses (monad.map ! (function (_ [match then])
- (do !
- [then! (recur then)]
- (wrap [(<=> (|> match <format>)
- ..peek)
- then!])))
- (#.Cons cons))]
- (wrap (list\fold (function (_ [when then] else)
- (_.if when then else))
- ..fail!
- clauses)))])
- ([#/////synthesis.I64_Fork //primitive.i64 //runtime.i64::=]
- [#/////synthesis.F64_Fork //primitive.f64 _.=]
- [#/////synthesis.Text_Fork //primitive.text _.=])
-
- (^template [<pm> <flag> <prep>]
- [(^ (<pm> idx))
- (///////phase\wrap ($_ _.then
- (_.set! $temp (|> idx <prep> .int _.int (//runtime.sum::get ..peek (//runtime.flag <flag>))))
- (_.if (_.= _.null $temp)
- ..fail!
- (..push_cursor! $temp))))])
- ([/////synthesis.side/left false (<|)]
- [/////synthesis.side/right true inc])
-
- (^ (/////synthesis.member/left 0))
- (///////phase\wrap (_.nth (_.int +1) ..peek))
-
- (^template [<pm> <getter>]
- [(^ (<pm> lefts))
- (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push_cursor!))])
- ([/////synthesis.member/left //runtime.tuple::left]
- [/////synthesis.member/right //runtime.tuple::right])
-
- (^ (/////synthesis.path/seq leftP rightP))
- (do ///////phase.monad
- [leftO (recur leftP)
- rightO (recur rightP)]
- (wrap ($_ _.then
- leftO
- rightO)))
-
- (^ (/////synthesis.path/alt leftP rightP))
- (do {! ///////phase.monad}
- [leftO (recur leftP)
- rightO (recur rightP)]
- (wrap (_.try ($_ _.then
- ..save_cursor!
- leftO)
- #.None
- (#.Some (..catch ($_ _.then
- ..restore_cursor!
- rightO)))
- #.None)))
- )))
-
-(def: (pattern_matching expression archive pathP)
- (Generator Path)
- (do ///////phase.monad
- [pattern_matching! (pattern_matching' expression archive pathP)]
- (wrap (_.try pattern_matching!
- #.None
- (#.Some (..catch (_.stop (_.string "Invalid expression for pattern-matching."))))
- #.None))))
-
-(def: #export (case expression archive [valueS pathP])
- (Generator [Synthesis Path])
- (do {! ///////phase.monad}
- [valueO (expression archive valueS)]
- (<| (\ ! map (|>> ($_ _.then
- (_.set! $cursor (_.list (list valueO)))
- (_.set! $savepoint (_.list (list))))
- _.block))
- (pattern_matching expression archive pathP))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux
deleted file mode 100644
index c89ffaf0a..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux
+++ /dev/null
@@ -1,116 +0,0 @@
-(.module:
- [lux (#- function)
- [abstract
- ["." monad (#+ do)]]
- [control
- pipe]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [target
- ["_" r (#+ Expression SVar)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." reference]
- ["#." case]
- ["/#" // #_
- ["#." reference]
- ["//#" /// #_
- [analysis (#+ Variant Tuple Abstraction Application Analysis)]
- [synthesis (#+ Synthesis)]
- ["#." generation (#+ Context)]
- ["//#" /// #_
- [arity (#+ Arity)]
- ["#." phase ("#\." monad)]
- [reference
- [variable (#+ Register Variable)]]
- [meta
- [archive
- ["." artifact]]]]]]])
-
-(def: #export (apply expression archive [functionS argsS+])
- (Generator (Application Synthesis))
- (do {! ///////phase.monad}
- [functionO (expression archive functionS)
- argsO+ (monad.map ! (expression archive) argsS+)]
- (wrap (_.apply argsO+ functionO))))
-
-(def: (with_closure function_id $function inits function_definition)
- (-> artifact.ID SVar (List Expression) Expression (Operation Expression))
- (case inits
- #.Nil
- (do ///////phase.monad
- [_ (/////generation.execute! function_definition)
- _ (/////generation.save! (%.nat function_id)
- function_definition)]
- (wrap $function))
-
- _
- (do ///////phase.monad
- [#let [closure_definition (_.set! $function
- (_.function (|> inits
- list.size
- list.indices
- (list\map //case.capture))
- ($_ _.then
- function_definition
- $function)))]
- _ (/////generation.execute! closure_definition)
- _ (/////generation.save! (%.nat function_id) closure_definition)]
- (wrap (_.apply inits $function)))))
-
-(def: $curried (_.var "curried"))
-(def: $missing (_.var "missing"))
-
-(def: (input_declaration register)
- (-> Register Expression)
- (_.set! (|> register inc //case.register)
- (|> $curried (_.nth (|> register inc .int _.int)))))
-
-(def: #export (function expression archive [environment arity bodyS])
- (Generator (Abstraction Synthesis))
- (do {! ///////phase.monad}
- [[[function_module function_artifact] bodyO] (/////generation.with_new_context archive
- (do !
- [$self (\ ! map (|>> ///reference.artifact _.var)
- (/////generation.context archive))]
- (/////generation.with_anchor $self
- (expression archive bodyS))))
- closureO+ (monad.map ! (expression archive) environment)
- #let [arityO (|> arity .int _.int)
- $num_args (_.var "num_args")
- $self (_.var (///reference.artifact [function_module function_artifact]))
- apply_poly (.function (_ args func)
- (_.apply (list func args) (_.var "do.call")))]]
- (with_closure function_artifact $self closureO+
- (_.set! $self (_.function (list _.var_args)
- ($_ _.then
- (_.set! $curried (_.list (list _.var_args)))
- (_.set! $num_args (_.length $curried))
- (_.cond (list [(|> $num_args (_.= arityO))
- ($_ _.then
- (_.set! (//case.register 0) $self)
- (|> arity
- list.indices
- (list\map input_declaration)
- (list\fold _.then bodyO)))]
- [(|> $num_args (_.> arityO))
- (let [arity_args (_.slice (_.int +1) arityO $curried)
- output_func_args (_.slice (|> arityO (_.+ (_.int +1)))
- $num_args
- $curried)]
- (|> $self
- (apply_poly arity_args)
- (apply_poly output_func_args)))])
- ## (|> $num_args (_.< arityO))
- (let [$missing (_.var "missing")]
- (_.function (list _.var_args)
- ($_ _.then
- (_.set! $missing (_.list (list _.var_args)))
- (|> $self
- (apply_poly (_.apply (list $curried $missing)
- (_.var "append"))))))))))))
- ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux
deleted file mode 100644
index c8f8bd1d5..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux
+++ /dev/null
@@ -1,64 +0,0 @@
-(.module:
- [lux (#- Scope)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." set (#+ Set)]]]
- [math
- [number
- ["n" nat]]]
- [target
- ["_" r]]]
- ["." // #_
- [runtime (#+ Operation Phase Generator)]
- ["#." case]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- [synthesis
- ["." case]]
- ["/#" // #_
- ["."synthesis (#+ Scope Synthesis)]
- ["#." generation]
- ["//#" /// #_
- ["#." phase]
- [meta
- [archive (#+ Archive)]]
- [reference
- [variable (#+ Register)]]]]]]])
-
-(def: #export (scope expression archive [offset initsS+ bodyS])
- (Generator (Scope Synthesis))
- (case initsS+
- ## function/false/non-independent loop
- #.Nil
- (expression archive bodyS)
-
- ## true loop
- _
- (do {! ///////phase.monad}
- [$scope (\ ! map _.var (/////generation.gensym "loop_scope"))
- initsO+ (monad.map ! (expression archive) initsS+)
- bodyO (/////generation.with_anchor $scope
- (expression archive bodyS))]
- (wrap (_.block
- ($_ _.then
- (_.set! $scope
- (_.function (|> initsS+
- list.size
- list.indices
- (list\map (|>> (n.+ offset) //case.register)))
- bodyO))
- (_.apply initsO+ $scope)))))))
-
-(def: #export (recur expression archive argsS+)
- (Generator (List Synthesis))
- (do {! ///////phase.monad}
- [$scope /////generation.anchor
- argsO+ (monad.map ! (expression archive) argsS+)]
- (wrap (_.apply argsO+ $scope))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux
deleted file mode 100644
index efbd569f4..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux
+++ /dev/null
@@ -1,17 +0,0 @@
-(.module:
- [lux (#- i64)
- [target
- ["_" r (#+ Expression)]]]
- ["." // #_
- ["#." runtime]])
-
-(template [<name> <type> <code>]
- [(def: #export <name>
- (-> <type> Expression)
- <code>)]
-
- [bit Bit _.bool]
- [i64 (I64 Any) (|>> .int //runtime.i64)]
- [f64 Frac _.float]
- [text Text _.string]
- )
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux
deleted file mode 100644
index 85ccd90dc..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux
+++ /dev/null
@@ -1,339 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:]
- ["p" parser])
- (data ["e" error]
- [text]
- text/format
- [number]
- (coll [list "list/" Functor<List>]
- (dictionary ["dict" unordered #+ Dict])))
- [macro #+ with-gensyms]
- (macro [code]
- ["s" syntax #+ syntax:])
- [host])
- (luxc ["&" lang]
- (lang ["la" analysis]
- ["ls" synthesis]
- (host [r #+ Expression])))
- [///]
- (/// [".T" runtime]
- [".T" case]
- [".T" function]
- [".T" loop]))
-
-## [Types]
-(type: #export Translator
- (-> ls.Synthesis (Meta Expression)))
-
-(type: #export Proc
- (-> Translator (List ls.Synthesis) (Meta Expression)))
-
-(type: #export Bundle
- (Dict Text Proc))
-
-(syntax: (Vector {size s.nat} elemT)
- (wrap (list (` [(~+ (list.repeat size elemT))]))))
-
-(type: #export Nullary (-> (Vector +0 Expression) Expression))
-(type: #export Unary (-> (Vector +1 Expression) Expression))
-(type: #export Binary (-> (Vector +2 Expression) Expression))
-(type: #export Trinary (-> (Vector +3 Expression) Expression))
-(type: #export Variadic (-> (List Expression) Expression))
-
-## [Utils]
-(def: #export (install name unnamed)
- (-> Text (-> Text Proc)
- (-> Bundle Bundle))
- (dict.put name (unnamed name)))
-
-(def: #export (prefix prefix bundle)
- (-> Text Bundle Bundle)
- (|> bundle
- dict.entries
- (list/map (function (_ [key val]) [(format prefix " " key) val]))
- (dict.from-list text.Hash<Text>)))
-
-(def: (wrong-arity proc expected actual)
- (-> Text Nat Nat Text)
- (format "Wrong number of arguments for " (%t proc) "\n"
- "Expected: " (|> expected .int %i) "\n"
- " Actual: " (|> actual .int %i)))
-
-(syntax: (arity: {name s.local-identifier} {arity s.nat})
- (with-gensyms [g!_ g!proc g!name g!translate g!inputs]
- (do {@ macro.monad}
- [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))]
- (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!proc))
- (-> (-> (..Vector (~ (code.nat arity)) Expression) Expression)
- (-> Text ..Proc))
- (function ((~ g!_) (~ g!name))
- (function ((~ g!_) (~ g!translate) (~ g!inputs))
- (case (~ g!inputs)
- (^ (list (~+ g!input+)))
- (do macro.Monad<Meta>
- [(~+ (|> g!input+
- (list/map (function (_ g!input)
- (list g!input (` ((~ g!translate) (~ g!input))))))
- list.concat))]
- ((~' wrap) ((~ g!proc) [(~+ g!input+)])))
-
- (~' _)
- (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs))))))))))))))
-
-(arity: nullary +0)
-(arity: unary +1)
-(arity: binary +2)
-(arity: trinary +3)
-
-(def: #export (variadic proc)
- (-> Variadic (-> Text Proc))
- (function (_ proc-name)
- (function (_ translate inputsS)
- (do {@ macro.Monad<Meta>}
- [inputsI (monad.map @ translate inputsS)]
- (wrap (proc inputsI))))))
-
-## [Procedures]
-## [[Lux]]
-(def: (lux//is [leftO rightO])
- Binary
- (r.apply (list leftO rightO)
- (r.global "identical")))
-
-(def: (lux//if [testO thenO elseO])
- Trinary
- (caseT.translate-if testO thenO elseO))
-
-(def: (lux//try riskyO)
- Unary
- (runtimeT.lux//try riskyO))
-
-(exception: #export (Wrong-Syntax {message Text})
- message)
-
-(def: #export (wrong-syntax procedure args)
- (-> Text (List ls.Synthesis) Text)
- (format "Procedure: " procedure "\n"
- "Arguments: " (%code (code.tuple args))))
-
-(def: lux//loop
- (-> Text Proc)
- (function (_ proc-name)
- (function (_ translate inputsS)
- (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any))
- (#e.Success [offset initsS+ bodyS])
- (loopT.translate-loop translate offset initsS+ bodyS)
-
- (#e.Error error)
- (&.throw Wrong-Syntax (wrong-syntax proc-name inputsS)))
- )))
-
-(def: lux//recur
- (-> Text Proc)
- (function (_ proc-name)
- (function (_ translate inputsS)
- (loopT.translate-recur translate inputsS))))
-
-(def: lux-procs
- Bundle
- (|> (dict.new text.Hash<Text>)
- (install "is" (binary lux//is))
- (install "try" (unary lux//try))
- (install "if" (trinary lux//if))
- (install "loop" lux//loop)
- (install "recur" lux//recur)
- ))
-
-## [[Bits]]
-(template [<name> <op>]
- [(def: (<name> [subjectO paramO])
- Binary
- (<op> paramO subjectO))]
-
- [bit//and runtimeT.bit//and]
- [bit//or runtimeT.bit//or]
- [bit//xor runtimeT.bit//xor]
- )
-
-(template [<name> <op>]
- [(def: (<name> [subjectO paramO])
- Binary
- (<op> (runtimeT.int64-low paramO) subjectO))]
-
- [bit//left-shift runtimeT.bit//left-shift]
- [bit//arithmetic-right-shift runtimeT.bit//arithmetic-right-shift]
- [bit//logical-right-shift runtimeT.bit//logical-right-shift]
- )
-
-(def: bit-procs
- Bundle
- (<| (prefix "bit")
- (|> (dict.new text.Hash<Text>)
- (install "and" (binary bit//and))
- (install "or" (binary bit//or))
- (install "xor" (binary bit//xor))
- (install "left-shift" (binary bit//left-shift))
- (install "logical-right-shift" (binary bit//logical-right-shift))
- (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift))
- )))
-
-## [[Numbers]]
-(host.import: java/lang/Double
- (#static MIN_VALUE Double)
- (#static MAX_VALUE Double))
-
-(template [<name> <const> <encode>]
- [(def: (<name> _)
- Nullary
- (<encode> <const>))]
-
- [frac//smallest Double::MIN_VALUE r.float]
- [frac//min (f/* -1.0 Double::MAX_VALUE) r.float]
- [frac//max Double::MAX_VALUE r.float]
- )
-
-(template [<name> <op>]
- [(def: (<name> [subjectO paramO])
- Binary
- (|> subjectO (<op> paramO)))]
-
- [int//add runtimeT.int//+]
- [int//sub runtimeT.int//-]
- [int//mul runtimeT.int//*]
- [int//div runtimeT.int///]
- [int//rem runtimeT.int//%]
- )
-
-(template [<name> <op>]
- [(def: (<name> [subjectO paramO])
- Binary
- (<op> paramO subjectO))]
-
- [frac//add r.+]
- [frac//sub r.-]
- [frac//mul r.*]
- [frac//div r./]
- [frac//rem r.%%]
- [frac//= r.=]
- [frac//< r.<]
-
- [text//= r.=]
- [text//< r.<]
- )
-
-(template [<name> <cmp>]
- [(def: (<name> [subjectO paramO])
- Binary
- (<cmp> paramO subjectO))]
-
- [int//= runtimeT.int//=]
- [int//< runtimeT.int//<]
- )
-
-(def: (apply1 func)
- (-> Expression (-> Expression Expression))
- (function (_ value)
- (r.apply (list value) func)))
-
-(def: int//char (|>> runtimeT.int64-low (apply1 (r.global "intToUtf8"))))
-
-(def: int-procs
- Bundle
- (<| (prefix "int")
- (|> (dict.new text.Hash<Text>)
- (install "+" (binary int//add))
- (install "-" (binary int//sub))
- (install "*" (binary int//mul))
- (install "/" (binary int//div))
- (install "%" (binary int//rem))
- (install "=" (binary int//=))
- (install "<" (binary int//<))
- (install "to-frac" (unary runtimeT.int//to-float))
- (install "char" (unary int//char)))))
-
-(def: (frac//encode value)
- (-> Expression Expression)
- (r.apply (list (r.string "%f") value) (r.global "sprintf")))
-
-(def: frac-procs
- Bundle
- (<| (prefix "frac")
- (|> (dict.new text.Hash<Text>)
- (install "+" (binary frac//add))
- (install "-" (binary frac//sub))
- (install "*" (binary frac//mul))
- (install "/" (binary frac//div))
- (install "%" (binary frac//rem))
- (install "=" (binary frac//=))
- (install "<" (binary frac//<))
- (install "smallest" (nullary frac//smallest))
- (install "min" (nullary frac//min))
- (install "max" (nullary frac//max))
- (install "to-int" (unary (apply1 (r.global "as.integer"))))
- (install "encode" (unary frac//encode))
- (install "decode" (unary runtimeT.frac//decode)))))
-
-## [[Text]]
-(def: (text//concat [subjectO paramO])
- Binary
- (r.apply (list subjectO paramO) (r.global "paste0")))
-
-(def: (text//char [subjectO paramO])
- Binary
- (runtimeT.text//char subjectO paramO))
-
-(def: (text//clip [subjectO paramO extraO])
- Trinary
- (runtimeT.text//clip subjectO paramO extraO))
-
-(def: (text//index [textO partO startO])
- Trinary
- (runtimeT.text//index textO partO startO))
-
-(def: text-procs
- Bundle
- (<| (prefix "text")
- (|> (dict.new text.Hash<Text>)
- (install "=" (binary text//=))
- (install "<" (binary text//<))
- (install "concat" (binary text//concat))
- (install "index" (trinary text//index))
- (install "size" (unary (|>> (apply1 (r.global "nchar")) runtimeT.int//from-float)))
- (install "char" (binary text//char))
- (install "clip" (trinary text//clip))
- )))
-
-## [[IO]]
-(def: (io//exit input)
- Unary
- (r.apply-kw (list)
- (list ["status" (runtimeT.int//to-float input)])
- (r.global "quit")))
-
-(def: (void code)
- (-> Expression Expression)
- (r.block (r.then code runtimeT.unit)))
-
-(def: io-procs
- Bundle
- (<| (prefix "io")
- (|> (dict.new text.Hash<Text>)
- (install "log" (unary (|>> r.print ..void)))
- (install "error" (unary r.stop))
- (install "exit" (unary io//exit))
- (install "current-time" (nullary (function (_ _)
- (runtimeT.io//current-time! runtimeT.unit)))))))
-
-## [Bundles]
-(def: #export procedures
- Bundle
- (<| (prefix "lux")
- (|> lux-procs
- (dict.merge bit-procs)
- (dict.merge int-procs)
- (dict.merge frac-procs)
- (dict.merge text-procs)
- (dict.merge io-procs)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux
deleted file mode 100644
index 3bd33955f..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux
+++ /dev/null
@@ -1,89 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do])
- (data [text]
- text/format
- (coll [list "list/" Functor<List>]
- (dictionary ["dict" unordered #+ Dict])))
- [macro "macro/" Monad<Meta>])
- (luxc ["&" lang]
- (lang ["la" analysis]
- ["ls" synthesis]
- (host [ruby #+ Ruby Expression Statement])))
- [///]
- (/// [".T" runtime])
- (// ["@" common]))
-
-## (template [<name> <lua>]
-## [(def: (<name> _) @.Nullary <lua>)]
-
-## [lua//nil "nil"]
-## [lua//table "{}"]
-## )
-
-## (def: (lua//global proc translate inputs)
-## (-> Text @.Proc)
-## (case inputs
-## (^ (list [_ (#.Text name)]))
-## (do macro.Monad<Meta>
-## []
-## (wrap name))
-
-## _
-## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
-
-## (def: (lua//call proc translate inputs)
-## (-> Text @.Proc)
-## (case inputs
-## (^ (list& functionS argsS+))
-## (do {@ macro.Monad<Meta>}
-## [functionO (translate functionS)
-## argsO+ (monad.map @ translate argsS+)]
-## (wrap (lua.apply functionO argsO+)))
-
-## _
-## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
-
-## (def: lua-procs
-## @.Bundle
-## (|> (dict.new text.Hash<Text>)
-## (@.install "nil" (@.nullary lua//nil))
-## (@.install "table" (@.nullary lua//table))
-## (@.install "global" lua//global)
-## (@.install "call" lua//call)))
-
-## (def: (table//call proc translate inputs)
-## (-> Text @.Proc)
-## (case inputs
-## (^ (list& tableS [_ (#.Text field)] argsS+))
-## (do {@ macro.Monad<Meta>}
-## [tableO (translate tableS)
-## argsO+ (monad.map @ translate argsS+)]
-## (wrap (lua.method field tableO argsO+)))
-
-## _
-## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
-
-## (def: (table//get [fieldO tableO])
-## @.Binary
-## (runtimeT.lua//get tableO fieldO))
-
-## (def: (table//set [fieldO valueO tableO])
-## @.Trinary
-## (runtimeT.lua//set tableO fieldO valueO))
-
-## (def: table-procs
-## @.Bundle
-## (<| (@.prefix "table")
-## (|> (dict.new text.Hash<Text>)
-## (@.install "call" table//call)
-## (@.install "get" (@.binary table//get))
-## (@.install "set" (@.trinary table//set)))))
-
-(def: #export procedures
- @.Bundle
- (<| (@.prefix "lua")
- (dict.new text.Hash<Text>)
- ## (|> lua-procs
- ## (dict.merge table-procs))
- ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux
deleted file mode 100644
index c986bc2a0..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux
+++ /dev/null
@@ -1,12 +0,0 @@
-(.module:
- [lux #*
- [target
- ["_" r (#+ Expression)]]]
- [///
- [reference (#+ System)]])
-
-(implementation: #export system
- (System Expression)
-
- (def: constant _.var)
- (def: variable _.var))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux
deleted file mode 100644
index ac0efe5ef..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux
+++ /dev/null
@@ -1,854 +0,0 @@
-(.module:
- [lux (#- Location inc i64)
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<.>" code]]]
- [data
- ["." product]
- ["." text ("#\." hash)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." list ("#\." functor)]
- ["." row]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number (#+ hex)
- ["n" nat]
- ["i" int ("#\." interval)]
- ["." i64]]]
- ["@" target
- ["_" r (#+ SVar Expression)]]]
- ["." /// #_
- ["#." reference]
- ["//#" /// #_
- [analysis (#+ Variant)]
- ["#." synthesis (#+ Synthesis)]
- ["#." generation]
- ["//#" ///
- ["#." phase]
- [reference
- [variable (#+ Register)]]
- [meta
- [archive (#+ Output Archive)
- ["." artifact (#+ Registry)]]]]]])
-
-(def: module_id
- 0)
-
-(template [<name> <base>]
- [(type: #export <name>
- (<base> _.SVar _.Expression _.Expression))]
-
- [Operation /////generation.Operation]
- [Phase /////generation.Phase]
- [Handler /////generation.Handler]
- [Bundle /////generation.Bundle]
- )
-
-(type: #export (Generator i)
- (-> Phase Archive i (Operation Expression)))
-
-(def: #export unit
- Expression
- (_.string /////synthesis.unit))
-
-(def: full_32 (hex "FFFFFFFF"))
-(def: half_32 (hex "7FFFFFFF"))
-(def: post_32 (hex "100000000"))
-
-(def: (cap_32 input)
- (-> Nat Int)
- (cond (n.> full_32 input)
- (|> input (i64.and full_32) cap_32)
-
- (n.> half_32 input)
- (|> post_32 (n.- input) .int (i.* -1))
-
- ## else
- (.int input)))
-
-(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
- body)
- (do {! meta.monad}
- [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
- (wrap (list (` (let [(~+ (|> vars
- (list.zip/2 ids)
- (list\map (function (_ [id var])
- (list (code.local_identifier var)
- (` (_.var (~ (code.text (format "v" (%.nat id)))))))))
- list.concat))]
- (~ body)))))))
-
-(syntax: (runtime: {declaration (<>.or <code>.local_identifier
- (<code>.form (<>.and <code>.local_identifier
- (<>.some <code>.local_identifier))))}
- code)
- (do meta.monad
- [runtime_id meta.count]
- (macro.with_gensyms [g!_]
- (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id]))
- runtime_name (` (_.var (~ (code.text (%.code runtime)))))]
- (case declaration
- (#.Left name)
- (let [g!name (code.local_identifier name)]
- (wrap (list (` (def: #export (~ g!name)
- _.SVar
- (~ runtime_name)))
-
- (` (def: (~ (code.local_identifier (format "@" name)))
- _.Expression
- (_.set! (~ runtime_name) (~ code)))))))
-
- (#.Right [name inputs])
- (let [g!name (code.local_identifier name)
- inputsC (list\map code.local_identifier inputs)
- inputs_typesC (list\map (function.constant (` _.Expression))
- inputs)]
- (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
- (-> (~+ inputs_typesC) _.Expression)
- (_.apply (list (~+ inputsC)) (~ runtime_name))))
-
- (` (def: (~ (code.local_identifier (format "@" name)))
- _.Expression
- (..with_vars [(~+ inputsC)]
- (_.set! (~ runtime_name)
- (_.function (list (~+ inputsC))
- (~ code))))))))))))))
-
-(def: #export variant_tag_field "luxVT")
-(def: #export variant_flag_field "luxVF")
-(def: #export variant_value_field "luxVV")
-
-(def: #export (flag value)
- (-> Bit Expression)
- (if value
- (_.string "")
- _.null))
-
-(runtime: (adt::variant tag last? value)
- (_.named_list (list [..variant_tag_field (_.as::integer tag)]
- [..variant_flag_field last?]
- [..variant_value_field value])))
-
-(def: #export (variant tag last? value)
- (-> Nat Bit Expression Expression)
- (adt::variant (_.int (.int tag))
- (flag last?)
- value))
-
-(def: #export none
- Expression
- (variant 0 #0 ..unit))
-
-(def: #export some
- (-> Expression Expression)
- (variant 1 #1))
-
-(def: #export left
- (-> Expression Expression)
- (variant 0 #0))
-
-(def: #export right
- (-> Expression Expression)
- (variant 1 #1))
-
-(def: high_shift (_.bit_shl (_.int +32)))
-
-(template [<name> <power>]
- [(runtime: <name> (|> (_.as::integer (_.int +2)) (_.** (_.as::integer (_.int <power>)))))]
-
- [f2^32 +32]
- [f2^63 +63]
- )
-
-(def: (as_double value)
- (-> Expression Expression)
- (_.apply (list value) (_.var "as.double")))
-
-(def: #export i64_high_field "luxIH")
-(def: #export i64_low_field "luxIL")
-
-(runtime: (i64::unsigned_low input)
- (with_vars [low]
- ($_ _.then
- (_.set! low (|> input (_.nth (_.string ..i64_low_field))))
- (_.if (|> low (_.>= (_.int +0)))
- low
- (|> low (_.+ f2^32))))))
-
-(runtime: (i64::to_float input)
- (let [high (|> input
- (_.nth (_.string ..i64_high_field))
- high_shift)
- low (|> input
- i64::unsigned_low)]
- (|> high (_.+ low) as_double)))
-
-(runtime: (i64::new high low)
- (_.named_list (list [..i64_high_field (_.as::integer high)]
- [..i64_low_field (_.as::integer low)])))
-
-(def: high_32
- (-> Nat Nat)
- (i64.right_shift 32))
-
-(def: low_32
- (-> Nat Nat)
- (|>> (i64.and (hex "FFFFFFFF"))))
-
-(def: #export (i64 value)
- (-> Int Expression)
- (let [value (.nat value)]
- (i64::new (|> value ..high_32 ..cap_32 _.int)
- (|> value ..low_32 ..cap_32 _.int))))
-
-(def: #export (lux_i64 high low)
- (-> Int Int Int)
- (|> high
- (i64.left_shift 32)
- (i64.or low)))
-
-(template [<name> <value>]
- [(runtime: <name>
- (..i64 <value>))]
-
- [i64::zero +0]
- [i64::one +1]
- [i64::min i\bottom]
- [i64::max i\top]
- )
-
-(def: #export i64_high (_.nth (_.string ..i64_high_field)))
-(def: #export i64_low (_.nth (_.string ..i64_low_field)))
-
-(runtime: (i64::not input)
- (i64::new (|> input i64_high _.bit_not)
- (|> input i64_low _.bit_not)))
-
-(runtime: (i64::+ param subject)
- (with_vars [sH sL pH pL
- x00 x16 x32 x48]
- ($_ _.then
- (_.set! sH (|> subject i64_high))
- (_.set! sL (|> subject i64_low))
- (_.set! pH (|> param i64_high))
- (_.set! pL (|> param i64_low))
- (let [bits16 (_.manual "0xFFFF")
- move_top_16 (_.bit_shl (_.int +16))
- top_16 (_.bit_ushr (_.int +16))
- bottom_16 (_.bit_and bits16)
- split_16 (function (_ source)
- [(|> source top_16)
- (|> source bottom_16)])
- split_int (function (_ high low)
- [(split_16 high)
- (split_16 low)])
-
- [[s48 s32] [s16 s00]] (split_int sH sL)
- [[p48 p32] [p16 p00]] (split_int pH pL)
- new_half (function (_ top bottom)
- (|> top bottom_16 move_top_16
- (_.bit_or (bottom_16 bottom))))]
- ($_ _.then
- (_.set! x00 (|> s00 (_.+ p00)))
- (_.set! x16 (|> x00 top_16 (_.+ s16) (_.+ p16)))
- (_.set! x32 (|> x16 top_16 (_.+ s32) (_.+ p32)))
- (_.set! x48 (|> x32 top_16 (_.+ s48) (_.+ p48)))
- (i64::new (new_half x48 x32)
- (new_half x16 x00)))))))
-
-(runtime: (i64::= reference sample)
- (let [n/a? (function (_ value)
- (_.apply (list value) (_.var "is.na")))
- isTRUE? (function (_ value)
- (_.apply (list value) (_.var "isTRUE")))
- comparison (: (-> (-> Expression Expression) Expression)
- (function (_ field)
- (|> (|> (field sample) (_.= (field reference)))
- (_.or (|> (n/a? (field sample))
- (_.and (n/a? (field reference))))))))]
- (|> (comparison i64_high)
- (_.and (comparison i64_low))
- isTRUE?)))
-
-(runtime: (i64::negate input)
- (_.if (|> input (i64::= i64::min))
- i64::min
- (|> input i64::not (i64::+ i64::one))))
-
-(runtime: i64::-one
- (i64::negate i64::one))
-
-(runtime: (i64::- param subject)
- (i64::+ (i64::negate param) subject))
-
-(runtime: (i64::< reference sample)
- (with_vars [r_? s_?]
- ($_ _.then
- (_.set! s_? (|> sample ..i64_high (_.< (_.int +0))))
- (_.set! r_? (|> reference ..i64_high (_.< (_.int +0))))
- (|> (|> s_? (_.and (_.not r_?)))
- (_.or (|> (_.not s_?) (_.and r_?) _.not))
- (_.or (|> sample
- (i64::- reference)
- ..i64_high
- (_.< (_.int +0))))))))
-
-(runtime: (i64::from_float input)
- (_.cond (list [(_.apply (list input) (_.var "is.nan"))
- i64::zero]
- [(|> input (_.<= (_.negate f2^63)))
- i64::min]
- [(|> input (_.+ (_.float +1.0)) (_.>= f2^63))
- i64::max]
- [(|> input (_.< (_.float +0.0)))
- (|> input _.negate i64::from_float i64::negate)])
- (i64::new (|> input (_./ f2^32))
- (|> input (_.%% f2^32)))))
-
-(runtime: (i64::* param subject)
- (with_vars [sH sL pH pL
- x00 x16 x32 x48]
- ($_ _.then
- (_.set! sH (|> subject i64_high))
- (_.set! pH (|> param i64_high))
- (let [negative_subject? (|> sH (_.< (_.int +0)))
- negative_param? (|> pH (_.< (_.int +0)))]
- (_.cond (list [negative_subject?
- (_.if negative_param?
- (i64::* (i64::negate param)
- (i64::negate subject))
- (i64::negate (i64::* param
- (i64::negate subject))))]
-
- [negative_param?
- (i64::negate (i64::* (i64::negate param)
- subject))])
- ($_ _.then
- (_.set! sL (|> subject i64_low))
- (_.set! pL (|> param i64_low))
- (let [bits16 (_.manual "0xFFFF")
- move_top_16 (_.bit_shl (_.int +16))
- top_16 (_.bit_ushr (_.int +16))
- bottom_16 (_.bit_and bits16)
- split_16 (function (_ source)
- [(|> source top_16)
- (|> source bottom_16)])
- split_int (function (_ high low)
- [(split_16 high)
- (split_16 low)])
- new_half (function (_ top bottom)
- (|> top bottom_16 move_top_16
- (_.bit_or (bottom_16 bottom))))
- x16_top (|> x16 top_16)
- x32_top (|> x32 top_16)]
- (with_vars [s48 s32 s16 s00
- p48 p32 p16 p00]
- (let [[[_s48 _s32] [_s16 _s00]] (split_int sH sL)
- [[_p48 _p32] [_p16 _p00]] (split_int pH pL)
- set_subject_chunks! ($_ _.then (_.set! s48 _s48) (_.set! s32 _s32) (_.set! s16 _s16) (_.set! s00 _s00))
- set_param_chunks! ($_ _.then (_.set! p48 _p48) (_.set! p32 _p32) (_.set! p16 _p16) (_.set! p00 _p00))]
- ($_ _.then
- set_subject_chunks!
- set_param_chunks!
- (_.set! x00 (|> s00 (_.* p00)))
- (_.set! x16 (|> x00 top_16 (_.+ (|> s16 (_.* p00)))))
- (_.set! x32 x16_top)
- (_.set! x16 (|> x16 bottom_16 (_.+ (|> s00 (_.* p16)))))
- (_.set! x32 (|> x32 (_.+ x16_top) (_.+ (|> s32 (_.* p00)))))
- (_.set! x48 x32_top)
- (_.set! x32 (|> x32 bottom_16 (_.+ (|> s16 (_.* p16)))))
- (_.set! x48 (|> x48 (_.+ x32_top)))
- (_.set! x32 (|> x32 bottom_16 (_.+ (|> s00 (_.* p32)))))
- (_.set! x48 (|> x48 (_.+ x32_top)
- (_.+ (|> s48 (_.* p00)))
- (_.+ (|> s32 (_.* p16)))
- (_.+ (|> s16 (_.* p32)))
- (_.+ (|> s00 (_.* p48)))))
- (i64::new (new_half x48 x32)
- (new_half x16 x00)))))
- )))))))
-
-(def: (limit_shift! shift)
- (-> SVar Expression)
- (_.set! shift (|> shift (_.bit_and (_.as::integer (_.int +63))))))
-
-(def: (no_shift_clause shift input)
- (-> SVar SVar [Expression Expression])
- [(|> shift (_.= (_.int +0)))
- input])
-
-(runtime: (i64::left_shift shift input)
- ($_ _.then
- (limit_shift! shift)
- (_.cond (list (no_shift_clause shift input)
- [(|> shift (_.< (_.int +32)))
- (let [mid (|> (i64_low input) (_.bit_ushr (|> (_.int +32) (_.- shift))))
- high (|> (i64_high input)
- (_.bit_shl shift)
- (_.bit_or mid))
- low (|> (i64_low input)
- (_.bit_shl shift))]
- (i64::new high low))])
- (let [high (|> (i64_high input)
- (_.bit_shl (|> shift (_.- (_.int +32)))))]
- (i64::new high (_.int +0))))))
-
-(runtime: (i64::arithmetic_right_shift_32 shift input)
- (let [top_bit (|> input (_.bit_and (_.as::integer (_.int (hex "+80000000")))))]
- (|> input
- (_.bit_ushr shift)
- (_.bit_or top_bit))))
-
-(runtime: (i64::arithmetic_right_shift shift input)
- ($_ _.then
- (limit_shift! shift)
- (_.cond (list (no_shift_clause shift input)
- [(|> shift (_.< (_.int +32)))
- (let [mid (|> (i64_high input) (_.bit_shl (|> (_.int +32) (_.- shift))))
- high (|> (i64_high input)
- (i64::arithmetic_right_shift_32 shift))
- low (|> (i64_low input)
- (_.bit_ushr shift)
- (_.bit_or mid))]
- (i64::new high low))])
- (let [low (|> (i64_high input)
- (i64::arithmetic_right_shift_32 (|> shift (_.- (_.int +32)))))
- high (_.if (|> (i64_high input) (_.>= (_.int +0)))
- (_.int +0)
- (_.int -1))]
- (i64::new high low)))))
-
-(runtime: (i64::/ param subject)
- (let [negative? (|>> (i64::< i64::zero))
- valid_division_check [(|> param (i64::= i64::zero))
- (_.stop (_.string "Cannot divide by zero!"))]
- short_circuit_check [(|> subject (i64::= i64::zero))
- i64::zero]]
- (_.cond (list valid_division_check
- short_circuit_check
-
- [(|> subject (i64::= i64::min))
- (_.cond (list [(|> (|> param (i64::= i64::one))
- (_.or (|> param (i64::= i64::-one))))
- i64::min]
- [(|> param (i64::= i64::min))
- i64::one])
- (with_vars [approximation]
- ($_ _.then
- (_.set! approximation
- (|> subject
- (i64::arithmetic_right_shift (_.int +1))
- (i64::/ param)
- (i64::left_shift (_.int +1))))
- (_.if (|> approximation (i64::= i64::zero))
- (_.if (negative? param)
- i64::one
- i64::-one)
- (let [remainder (i64::- (i64::* param approximation)
- subject)]
- (|> remainder
- (i64::/ param)
- (i64::+ approximation)))))))]
- [(|> param (i64::= i64::min))
- i64::zero]
-
- [(negative? subject)
- (_.if (negative? param)
- (|> (i64::negate subject)
- (i64::/ (i64::negate param)))
- (|> (i64::negate subject)
- (i64::/ param)
- i64::negate))]
-
- [(negative? param)
- (|> param
- i64::negate
- (i64::/ subject)
- i64::negate)])
- (with_vars [result remainder approximate approximate_result log2 approximate_remainder]
- ($_ _.then
- (_.set! result i64::zero)
- (_.set! remainder subject)
- (_.while (|> (|> remainder (i64::< param))
- (_.or (|> remainder (i64::= param))))
- (let [calc_rough_estimate (_.apply (list (|> (i64::to_float remainder) (_./ (i64::to_float param))))
- (_.var "floor"))
- calc_approximate_result (i64::from_float approximate)
- calc_approximate_remainder (|> approximate_result (i64::* param))
- delta (_.if (|> (_.float +48.0) (_.<= log2))
- (_.float +1.0)
- (_.** (|> log2 (_.- (_.float +48.0)))
- (_.float +2.0)))]
- ($_ _.then
- (_.set! approximate (_.apply (list (_.float +1.0) calc_rough_estimate)
- (_.var "max")))
- (_.set! log2 (let [log (function (_ input)
- (_.apply (list input) (_.var "log")))]
- (_.apply (list (|> (log (_.int +2))
- (_./ (log approximate))))
- (_.var "ceil"))))
- (_.set! approximate_result calc_approximate_result)
- (_.set! approximate_remainder calc_approximate_remainder)
- (_.while (|> (negative? approximate_remainder)
- (_.or (|> approximate_remainder (i64::< remainder))))
- ($_ _.then
- (_.set! approximate (|> delta (_.- approximate)))
- (_.set! approximate_result calc_approximate_result)
- (_.set! approximate_remainder calc_approximate_remainder)))
- (_.set! result (|> (_.if (|> approximate_result (i64::= i64::zero))
- i64::one
- approximate_result)
- (i64::+ result)))
- (_.set! remainder (|> remainder (i64::- approximate_remainder))))))
- result))
- )))
-
-(runtime: (i64::% param subject)
- (let [flat (|> subject (i64::/ param) (i64::* param))]
- (|> subject (i64::- flat))))
-
-(runtime: (lux::try op)
- (with_vars [error value]
- (_.try ($_ _.then
- (_.set! value (_.apply (list ..unit) op))
- (..right value))
- #.None
- (#.Some (_.function (list error)
- (..left (_.nth (_.string "message")
- error))))
- #.None)))
-
-(runtime: (lux::program_args program_args)
- (with_vars [inputs value]
- ($_ _.then
- (_.set! inputs ..none)
- (<| (_.for_in value program_args)
- (_.set! inputs (..some (_.list (list value inputs)))))
- inputs)))
-
-(def: runtime::lux
- Expression
- ($_ _.then
- @lux::try
- @lux::program_args
- ))
-
-(def: current_time_float
- Expression
- (let [raw_time (_.apply (list) (_.var "Sys.time"))]
- (_.apply (list raw_time) (_.var "as.numeric"))))
-
-(runtime: (io::current_time! _)
- (|> current_time_float
- (_.* (_.float +1,000.0))
- i64::from_float))
-
-(def: runtime::io
- Expression
- ($_ _.then
- @io::current_time!
- ))
-
-(def: minimum_index_length
- (-> SVar Expression)
- (|>> (_.+ (_.int +1))))
-
-(def: (product_element product index)
- (-> Expression Expression Expression)
- (|> product (_.nth (|> index (_.+ (_.int +1))))))
-
-(def: (product_tail product)
- (-> SVar Expression)
- (|> product (_.nth (_.length product))))
-
-(def: (updated_index min_length product)
- (-> Expression Expression Expression)
- (|> min_length (_.- (_.length product))))
-
-(runtime: (tuple::left index product)
- (let [$index_min_length (_.var "index_min_length")]
- ($_ _.then
- (_.set! $index_min_length (minimum_index_length index))
- (_.if (|> (_.length product) (_.> $index_min_length))
- ## No need for recursion
- (product_element product index)
- ## Needs recursion
- (tuple::left (updated_index $index_min_length product)
- (product_tail product))))))
-
-(runtime: (tuple::right index product)
- (let [$index_min_length (_.var "index_min_length")]
- ($_ _.then
- (_.set! $index_min_length (minimum_index_length index))
- (_.cond (list [## Last element.
- (|> (_.length product) (_.= $index_min_length))
- (product_element product index)]
- [## Needs recursion
- (|> (_.length product) (_.< $index_min_length))
- (tuple::right (updated_index $index_min_length product)
- (product_tail product))])
- ## Must slice
- (|> product (_.slice_from index))))))
-
-(runtime: (sum::get sum wants_last? wanted_tag)
- (let [no_match _.null
- sum_tag (|> sum (_.nth (_.string ..variant_tag_field)))
- sum_flag (|> sum (_.nth (_.string ..variant_flag_field)))
- sum_value (|> sum (_.nth (_.string ..variant_value_field)))
- is_last? (|> sum_flag (_.= (_.string "")))
- test_recursion (_.if is_last?
- ## Must recurse.
- (|> wanted_tag
- (_.- sum_tag)
- (sum::get sum_value wants_last?))
- no_match)]
- (_.cond (list [(_.= sum_tag wanted_tag)
- (_.if (_.= wants_last? sum_flag)
- sum_value
- test_recursion)]
-
- [(|> wanted_tag (_.> sum_tag))
- test_recursion]
-
- [(|> (|> wants_last? (_.= (_.string "")))
- (_.and (|> wanted_tag (_.< sum_tag))))
- (adt::variant (|> sum_tag (_.- wanted_tag)) sum_flag sum_value)])
-
- no_match)))
-
-(def: runtime::adt
- Expression
- ($_ _.then
- @tuple::left
- @tuple::right
- @sum::get
- @adt::variant
- ))
-
-(template [<name> <op>]
- [(runtime: (<name> mask input)
- (i64::new (<op> (i64_high mask)
- (i64_high input))
- (<op> (i64_low mask)
- (i64_low input))))]
-
- [i64::and _.bit_and]
- [i64::or _.bit_or]
- [i64::xor _.bit_xor]
- )
-
-(runtime: (i64::right_shift shift input)
- ($_ _.then
- (limit_shift! shift)
- (_.cond (list (no_shift_clause shift input)
- [(|> shift (_.< (_.int +32)))
- (with_vars [$mid]
- (let [mid (|> (i64_high input) (_.bit_shl (|> (_.int +32) (_.- shift))))
- high (|> (i64_high input) (_.bit_ushr shift))
- low (|> (i64_low input)
- (_.bit_ushr shift)
- (_.bit_or (_.if (_.apply (list $mid) (_.var "is.na"))
- (_.as::integer (_.int +0))
- $mid)))]
- ($_ _.then
- (_.set! $mid mid)
- (i64::new high low))))]
- [(|> shift (_.= (_.int +32)))
- (let [high (i64_high input)]
- (i64::new (_.int +0) high))])
- (let [low (|> (i64_high input) (_.bit_ushr (|> shift (_.- (_.int +32)))))]
- (i64::new (_.int +0) low)))))
-
-(def: runtime::i64
- Expression
- ($_ _.then
- @f2^32
- @f2^63
-
- @i64::new
- @i64::from_float
-
- @i64::and
- @i64::or
- @i64::xor
- @i64::not
- @i64::left_shift
- @i64::arithmetic_right_shift_32
- @i64::arithmetic_right_shift
- @i64::right_shift
-
- @i64::zero
- @i64::one
- @i64::min
- @i64::max
- @i64::=
- @i64::<
- @i64::+
- @i64::-
- @i64::negate
- @i64::-one
- @i64::unsigned_low
- @i64::to_float
- @i64::*
- @i64::/
- @i64::%
- ))
-
-(runtime: (frac::decode input)
- (with_vars [output]
- ($_ _.then
- (_.set! output (_.apply (list input) (_.var "as.numeric")))
- (_.if (|> output (_.= _.n/a))
- ..none
- (..some output)))))
-
-(def: runtime::frac
- Expression
- ($_ _.then
- @frac::decode
- ))
-
-(def: inc
- (-> Expression Expression)
- (|>> (_.+ (_.int +1))))
-
-(template [<name> <top_cmp>]
- [(def: (<name> top value)
- (-> Expression Expression Expression)
- (|> (|> value (_.>= (_.int +0)))
- (_.and (|> value (<top_cmp> top)))))]
-
- [within? _.<]
- [up_to? _.<=]
- )
-
-(def: (text_clip start end text)
- (-> Expression Expression Expression Expression)
- (_.apply (list text start end)
- (_.var "substr")))
-
-(def: (text_length text)
- (-> Expression Expression)
- (_.apply (list text) (_.var "nchar")))
-
-(runtime: (text::index subject param start)
- (with_vars [idx startF subjectL]
- ($_ _.then
- (_.set! startF (i64::to_float start))
- (_.set! subjectL (text_length subject))
- (_.if (|> startF (within? subjectL))
- ($_ _.then
- (_.set! idx (|> (_.apply_kw (list param (_.if (|> startF (_.= (_.int +0)))
- subject
- (text_clip (inc startF)
- (inc subjectL)
- subject)))
- (list ["fixed" (_.bool #1)])
- (_.var "regexpr"))
- (_.nth (_.int +1))))
- (_.if (|> idx (_.= (_.int -1)))
- ..none
- (..some (i64::from_float (|> idx (_.+ startF))))))
- ..none))))
-
-(runtime: (text::clip text from to)
- (with_vars [length]
- ($_ _.then
- (_.set! length (_.length text))
- (_.if ($_ _.and
- (|> to (within? length))
- (|> from (up_to? to)))
- (..some (text_clip (inc from) (inc to) text))
- ..none))))
-
-(def: (char_at idx text)
- (-> Expression Expression Expression)
- (_.apply (list (text_clip idx idx text))
- (_.var "utf8ToInt")))
-
-(runtime: (text::char text idx)
- (_.if (|> idx (within? (_.length text)))
- ($_ _.then
- (_.set! idx (inc idx))
- (..some (i64::from_float (char_at idx text))))
- ..none))
-
-(def: runtime::text
- Expression
- ($_ _.then
- @text::index
- @text::clip
- @text::char
- ))
-
-(def: (check_index_out_of_bounds array idx body)
- (-> Expression Expression Expression Expression)
- (_.if (|> idx (_.<= (_.length array)))
- body
- (_.stop (_.string "Array index out of bounds!"))))
-
-(runtime: (array::new size)
- (with_vars [output]
- ($_ _.then
- (_.set! output (_.list (list)))
- (_.set_nth! (|> size (_.+ (_.int +1)))
- _.null
- output)
- output)))
-
-(runtime: (array::get array idx)
- (with_vars [temp]
- (<| (check_index_out_of_bounds array idx)
- ($_ _.then
- (_.set! temp (|> array (_.nth (_.+ (_.int +1) idx))))
- (_.if (|> temp (_.= _.null))
- ..none
- (..some temp))))))
-
-(runtime: (array::put array idx value)
- (<| (check_index_out_of_bounds array idx)
- ($_ _.then
- (_.set_nth! (_.+ (_.int +1) idx) value array)
- array)))
-
-(def: runtime::array
- Expression
- ($_ _.then
- @array::new
- @array::get
- @array::put
- ))
-
-(def: runtime
- Expression
- ($_ _.then
- runtime::lux
- runtime::i64
- runtime::adt
- runtime::frac
- runtime::text
- runtime::array
- runtime::io
- ))
-
-(def: #export generate
- (Operation [Registry Output])
- (do ///////phase.monad
- [_ (/////generation.execute! ..runtime)
- _ (/////generation.save! (%.nat ..module_id) ..runtime)]
- (wrap [(|> artifact.empty
- artifact.resource
- product.right)
- (row.row [(%.nat ..module_id)
- (|> ..runtime
- _.code
- (\ utf8.codec encode))])])))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux
deleted file mode 100644
index 5f4703836..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux
+++ /dev/null
@@ -1,39 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [data
- [collection
- ["." list]]]
- [target
- ["_" r (#+ Expression)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." primitive]
- ["///#" //// #_
- [analysis (#+ Variant Tuple)]
- ["#." synthesis (#+ Synthesis)]
- ["//#" /// #_
- ["#." phase ("#\." monad)]]]])
-
-(def: #export (tuple expression archive elemsS+)
- (Generator (Tuple Synthesis))
- (case elemsS+
- #.Nil
- (///////phase\wrap (//primitive.text /////synthesis.unit))
-
- (#.Cons singletonS #.Nil)
- (expression archive singletonS)
-
- _
- (|> elemsS+
- (monad.map ///////phase.monad (expression archive))
- (///////phase\map _.list))))
-
-(def: #export (variant expression archive [lefts right? valueS])
- (Generator (Variant Synthesis))
- (let [tag (if right?
- (inc lefts)
- lefts)]
- (///////phase\map (|>> (//runtime.variant tag right?))
- (expression archive valueS))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux
deleted file mode 100644
index cdcc5a134..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux
+++ /dev/null
@@ -1,88 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- [data
- [text
- ["%" format (#+ format)]]]]
- ["." //// #_
- ["." version]
- ["#." generation (#+ Context)]
- ["//#" /// #_
- ["." reference (#+ Reference)
- ["." variable (#+ Register Variable)]]
- ["." phase ("#\." monad)]
- [meta
- [archive (#+ Archive)]]]])
-
-## This universe constant is for languages where one can't just turn all compiled definitions
-## into the local variables of some scoping function.
-(def: #export universe
- (for {## In the case of Lua, there is a limit of 200 locals in a function's scope.
- @.lua (not ("lua script universe"))
- ## Cannot make all definitions be local variables because of limitations with JRuby.
- @.ruby (not ("ruby script universe"))
- ## Cannot make all definitions be local variables because of limitations with PHP itself.
- @.php (not ("php script universe"))
- ## Cannot make all definitions be local variables because of limitations with Kawa.
- @.scheme (not ("scheme script universe"))}
- #0))
-
-(def: universe_label
- Text
- (with_expansions [<label> (format "u" (%.nat (if ..universe 1 0)))]
- (for {@.lua <label>
- @.ruby <label>
- @.php <label>
- @.scheme <label>}
- "")))
-
-(def: #export (artifact [module artifact])
- (-> Context Text)
- (format "l" (%.nat version.version)
- ..universe_label
- "m" (%.nat module)
- "a" (%.nat artifact)))
-
-(interface: #export (System expression)
- (: (-> Text expression)
- constant)
- (: (-> Text expression)
- variable))
-
-(def: #export (constant system archive name)
- (All [anchor expression directive]
- (-> (System expression) Archive Name
- (////generation.Operation anchor expression directive expression)))
- (phase\map (|>> ..artifact (\ system constant))
- (////generation.remember archive name)))
-
-(template [<sigil> <name>]
- [(def: #export (<name> system)
- (All [expression]
- (-> (System expression)
- (-> Register expression)))
- (|>> %.nat (format <sigil>) (\ system variable)))]
-
- ["f" foreign]
- ["l" local]
- )
-
-(def: #export (variable system variable)
- (All [expression]
- (-> (System expression) Variable expression))
- (case variable
- (#variable.Local register)
- (..local system register)
-
- (#variable.Foreign register)
- (..foreign system register)))
-
-(def: #export (reference system archive reference)
- (All [anchor expression directive]
- (-> (System expression) Archive Reference (////generation.Operation anchor expression directive expression)))
- (case reference
- (#reference.Constant value)
- (..constant system archive value)
-
- (#reference.Variable value)
- (phase\wrap (..variable system value))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby.lux
deleted file mode 100644
index f1a4e3c1c..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby.lux
+++ /dev/null
@@ -1,104 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." exception (#+ exception:)]]
- [target
- ["_" ruby]]]
- ["." / #_
- [runtime (#+ Phase Phase!)]
- ["#." primitive]
- ["#." structure]
- ["#." reference]
- ["#." function]
- ["#." case]
- ["#." loop]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- ["#." extension]
- ["/#" // #_
- [analysis (#+)]
- ["#." synthesis]
- ["//#" /// #_
- ["#." phase ("#\." monad)]
- [reference (#+)
- [variable (#+)]]]]]]])
-
-(def: (statement expression archive synthesis)
- Phase!
- (case synthesis
- (^template [<tag>]
- [(^ (<tag> value))
- (//////phase\map _.return (expression archive synthesis))])
- ([////synthesis.bit]
- [////synthesis.i64]
- [////synthesis.f64]
- [////synthesis.text]
- [////synthesis.variant]
- [////synthesis.tuple]
- [#////synthesis.Reference]
- [////synthesis.branch/get]
- [////synthesis.function/apply]
- [#////synthesis.Extension])
-
- (^ (////synthesis.branch/case case))
- (/case.case! false statement expression archive case)
-
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (<generator> statement expression archive value)])
- ([////synthesis.branch/let /case.let!]
- [////synthesis.branch/if /case.if!]
- [////synthesis.loop/scope /loop.scope!]
- [////synthesis.loop/recur /loop.recur!])
-
- (^ (////synthesis.function/abstraction abstraction))
- (//////phase\map _.return (/function.function statement expression archive abstraction))
- ))
-
-(exception: #export cannot-recur-as-an-expression)
-
-(def: (expression archive synthesis)
- Phase
- (case synthesis
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (//////phase\wrap (<generator> value))])
- ([////synthesis.bit /primitive.bit]
- [////synthesis.i64 /primitive.i64]
- [////synthesis.f64 /primitive.f64]
- [////synthesis.text /primitive.text])
-
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (<generator> expression archive value)])
- ([////synthesis.variant /structure.variant]
- [////synthesis.tuple /structure.tuple]
-
- [////synthesis.branch/let /case.let]
- [////synthesis.branch/if /case.if]
- [////synthesis.branch/get /case.get]
-
- [////synthesis.function/apply /function.apply])
-
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (<generator> statement expression archive value)])
- ([////synthesis.branch/case /case.case]
- [////synthesis.loop/scope /loop.scope]
- [////synthesis.function/abstraction /function.function])
-
- (^ (////synthesis.loop/recur _))
- (//////phase.throw ..cannot-recur-as-an-expression [])
-
- (#////synthesis.Reference value)
- (//reference.reference /reference.system archive value)
-
- (#////synthesis.Extension extension)
- (///extension.apply archive expression extension)))
-
-(def: #export generate
- Phase
- ..expression)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux
deleted file mode 100644
index 2249874b5..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux
+++ /dev/null
@@ -1,311 +0,0 @@
-(.module:
- [lux (#- case let if)
- [abstract
- ["." monad (#+ do)]]
- [control
- [exception (#+ exception:)]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." set]]]
- [math
- [number
- ["n" nat]
- ["i" int]]]
- [target
- ["_" ruby (#+ Expression LVar Statement)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator Phase! Generator!)]
- ["#." reference]
- ["#." primitive]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- [synthesis
- ["." case]]
- ["/#" // #_
- ["#." synthesis (#+ Member Synthesis Path)]
- ["#." generation]
- ["//#" /// #_
- [reference
- ["#." variable (#+ Register)]]
- ["#." phase ("#\." monad)]
- [meta
- [archive (#+ Archive)]]]]]]])
-
-(def: #export (gensym prefix)
- (-> Text (Operation LVar))
- (///////phase\map (|>> %.nat (format prefix) _.local) /////generation.next))
-
-(def: #export register
- (-> Register LVar)
- (|>> (///reference.local //reference.system) :assume))
-
-(def: #export capture
- (-> Register LVar)
- (|>> (///reference.foreign //reference.system) :assume))
-
-(def: #export (let expression archive [valueS register bodyS])
- (Generator [Synthesis Register Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)
- bodyO (expression archive bodyS)]
- ## TODO: Find some way to do 'let' without paying the price of the closure.
- (wrap (|> bodyO
- _.return
- (_.lambda #.None (list (..register register)))
- (_.apply_lambda/* (list valueO))))))
-
-(def: #export (let! statement expression archive [valueS register bodyS])
- (Generator! [Synthesis Register Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)
- bodyO (statement expression archive bodyS)]
- (wrap ($_ _.then
- (_.set (list (..register register)) valueO)
- bodyO))))
-
-(def: #export (if expression archive [testS thenS elseS])
- (Generator [Synthesis Synthesis Synthesis])
- (do ///////phase.monad
- [testO (expression archive testS)
- thenO (expression archive thenS)
- elseO (expression archive elseS)]
- (wrap (_.? testO thenO elseO))))
-
-(def: #export (if! statement expression archive [testS thenS elseS])
- (Generator! [Synthesis Synthesis Synthesis])
- (do ///////phase.monad
- [test! (expression archive testS)
- then! (statement expression archive thenS)
- else! (statement expression archive elseS)]
- (wrap (_.if test!
- then!
- else!))))
-
-(def: #export (get expression archive [pathP valueS])
- (Generator [(List Member) Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)]
- (wrap (list\fold (function (_ side source)
- (.let [method (.case side
- (^template [<side> <accessor>]
- [(<side> lefts)
- (<accessor> (_.int (.int lefts)))])
- ([#.Left //runtime.tuple//left]
- [#.Right //runtime.tuple//right]))]
- (method source)))
- valueO
- (list.reverse pathP)))))
-
-(def: @savepoint (_.local "lux_pm_savepoint"))
-(def: @cursor (_.local "lux_pm_cursor"))
-(def: @temp (_.local "lux_pm_temp"))
-
-(def: (push! value)
- (-> Expression Statement)
- (_.statement (|> @cursor (_.do "push" (list value)))))
-
-(def: peek_and_pop
- Expression
- (|> @cursor (_.do "pop" (list))))
-
-(def: pop!
- Statement
- (_.statement ..peek_and_pop))
-
-(def: peek
- Expression
- (_.nth (_.int -1) @cursor))
-
-(def: save!
- Statement
- (.let [cursor (_.array_range (_.int +0) (_.int -1) @cursor)]
- (_.statement (|> @savepoint (_.do "push" (list cursor))))))
-
-(def: restore!
- Statement
- (_.set (list @cursor) (|> @savepoint (_.do "pop" (list)))))
-
-(def: fail! _.break)
-
-(def: (multi_pop! pops)
- (-> Nat Statement)
- (_.statement (_.do "slice!" (list (_.int (i.* -1 (.int pops)))
- (_.int (.int pops)))
- @cursor)))
-
-(template [<name> <flag> <prep>]
- [(def: (<name> simple? idx)
- (-> Bit Nat Statement)
- ($_ _.then
- (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>)))
- (.if simple?
- (_.when (_.= _.nil @temp)
- fail!)
- (_.if (_.= _.nil @temp)
- fail!
- (..push! @temp)))))]
-
- [left_choice _.nil (<|)]
- [right_choice (_.string "") inc]
- )
-
-(def: (with_looping in_closure? g!once g!continue? body!)
- (-> Bit LVar LVar Statement Statement)
- (.if in_closure?
- ($_ _.then
- (_.while (_.bool true)
- body!))
- ($_ _.then
- (_.set (list g!once) (_.bool true))
- (_.set (list g!continue?) (_.bool false))
- (<| (_.while (_.bool true))
- (_.if g!once
- ($_ _.then
- (_.set (list g!once) (_.bool false))
- body!)
- ($_ _.then
- (_.set (list g!continue?) (_.bool true))
- _.break)))
- (_.when g!continue?
- _.next))))
-
-(def: (alternation in_closure? g!once g!continue? pre! post!)
- (-> Bit LVar LVar Statement Statement Statement)
- ($_ _.then
- (with_looping in_closure? g!once g!continue?
- ($_ _.then
- ..save!
- pre!))
- ..restore!
- post!))
-
-(def: (pattern_matching' in_closure? statement expression archive)
- (-> Bit (Generator! Path))
- (function (recur pathP)
- (.case pathP
- (#/////synthesis.Then bodyS)
- (statement expression archive bodyS)
-
- #/////synthesis.Pop
- (///////phase\wrap ..pop!)
-
- (#/////synthesis.Bind register)
- (///////phase\wrap (_.set (list (..register register)) ..peek))
-
- (#/////synthesis.Bit_Fork when thenP elseP)
- (do {! ///////phase.monad}
- [then! (recur thenP)
- else! (.case elseP
- (#.Some elseP)
- (recur elseP)
-
- #.None
- (wrap ..fail!))]
- (wrap (.if when
- (_.if ..peek
- then!
- else!)
- (_.if ..peek
- else!
- then!))))
-
- (^template [<tag> <format>]
- [(<tag> cons)
- (do {! ///////phase.monad}
- [clauses (monad.map ! (function (_ [match then])
- (\ ! map
- (|>> [(_.= (|> match <format>)
- ..peek)])
- (recur then)))
- (#.Cons cons))]
- (wrap (_.cond clauses
- ..fail!)))])
- ([#/////synthesis.I64_Fork (<| //primitive.i64 .int)]
- [#/////synthesis.F64_Fork (<| //primitive.f64)]
- [#/////synthesis.Text_Fork (<| //primitive.text)])
-
- (^template [<complex> <simple> <choice>]
- [(^ (<complex> idx))
- (///////phase\wrap (<choice> false idx))
-
- (^ (<simple> idx nextP))
- (|> nextP
- recur
- (///////phase\map (_.then (<choice> true idx))))])
- ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice]
- [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice])
-
- (^ (/////synthesis.member/left 0))
- (///////phase\wrap (|> ..peek (_.nth (_.int +0)) ..push!))
-
- (^template [<pm> <getter>]
- [(^ (<pm> lefts))
- (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))])
- ([/////synthesis.member/left //runtime.tuple//left]
- [/////synthesis.member/right //runtime.tuple//right])
-
- (^ (/////synthesis.!bind_top register thenP))
- (do ///////phase.monad
- [then! (recur thenP)]
- (///////phase\wrap ($_ _.then
- (_.set (list (..register register)) ..peek_and_pop)
- then!)))
-
- (^ (/////synthesis.!multi_pop nextP))
- (.let [[extra_pops nextP'] (case.count_pops nextP)]
- (do ///////phase.monad
- [next! (recur nextP')]
- (///////phase\wrap ($_ _.then
- (..multi_pop! (n.+ 2 extra_pops))
- next!))))
-
- (^ (/////synthesis.path/seq preP postP))
- (do ///////phase.monad
- [pre! (recur preP)
- post! (recur postP)]
- (wrap ($_ _.then
- pre!
- post!)))
-
- (^ (/////synthesis.path/alt preP postP))
- (do ///////phase.monad
- [pre! (recur preP)
- post! (recur postP)
- g!once (..gensym "once")
- g!continue? (..gensym "continue")]
- (wrap (..alternation in_closure? g!once g!continue? pre! post!)))
- )))
-
-(def: (pattern_matching in_closure? statement expression archive pathP)
- (-> Bit (Generator! Path))
- (do ///////phase.monad
- [pattern_matching! (pattern_matching' in_closure? statement expression archive pathP)
- g!once (..gensym "once")
- g!continue? (..gensym "continue")]
- (wrap ($_ _.then
- (..with_looping in_closure? g!once g!continue?
- pattern_matching!)
- (_.statement (_.raise (_.string case.pattern_matching_error)))))))
-
-(def: #export (case! in_closure? statement expression archive [valueS pathP])
- (-> Bit (Generator! [Synthesis Path]))
- (do ///////phase.monad
- [stack_init (expression archive valueS)
- pattern_matching! (pattern_matching in_closure? statement expression archive pathP)]
- (wrap ($_ _.then
- (_.set (list @cursor) (_.array (list stack_init)))
- (_.set (list @savepoint) (_.array (list)))
- pattern_matching!
- ))))
-
-(def: #export (case statement expression archive case)
- (-> Phase! (Generator [Synthesis Path]))
- (|> case
- (case! true statement expression archive)
- (\ ///////phase.monad map
- (|>> (_.lambda #.None (list))
- (_.apply_lambda/* (list))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux
deleted file mode 100644
index 535453f2e..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux
+++ /dev/null
@@ -1,111 +0,0 @@
-(.module:
- [lux (#- function)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [target
- ["_" ruby (#+ LVar GVar Expression Statement)]]]
- ["." // #_
- [runtime (#+ Operation Phase Generator Phase! Generator!)]
- ["#." reference]
- ["#." case]
- ["#." loop]
- ["/#" // #_
- ["#." reference]
- ["//#" /// #_
- [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)]
- [synthesis (#+ Synthesis)]
- ["#." generation (#+ Context)]
- ["//#" /// #_
- [arity (#+ Arity)]
- ["#." phase]
- [reference
- [variable (#+ Register Variable)]]
- [meta
- [archive (#+ Archive)
- ["." artifact]]]]]]])
-
-(def: #export (apply expression archive [functionS argsS+])
- (Generator (Application Synthesis))
- (do {! ///////phase.monad}
- [functionO (expression archive functionS)
- argsO+ (monad.map ! (expression archive) argsS+)]
- (wrap (_.apply_lambda/* argsO+ functionO))))
-
-(def: #export capture
- (-> Register LVar)
- (|>> (///reference.foreign //reference.system) :assume))
-
-(def: (with_closure inits self function_definition)
- (-> (List Expression) Text Expression [Statement Expression])
- (case inits
- #.Nil
- (let [@self (_.global self)]
- [(_.set (list @self) function_definition)
- @self])
-
- _
- (let [@self (_.local self)]
- [(_.function @self
- (|> (list.enumeration inits)
- (list\map (|>> product.left ..capture)))
- ($_ _.then
- (_.set (list @self) function_definition)
- (_.return @self)))
- (_.apply/* inits @self)])))
-
-(def: input
- (|>> inc //case.register))
-
-(def: #export (function statement expression archive [environment arity bodyS])
- (-> Phase! (Generator (Abstraction Synthesis)))
- (do {! ///////phase.monad}
- [[[function_module function_artifact] body!] (/////generation.with_new_context archive
- (/////generation.with_anchor 1
- (statement expression archive bodyS)))
- closureO+ (monad.map ! (expression archive) environment)
- #let [function_name (///reference.artifact [function_module function_artifact])
- @curried (_.local "curried")
- arityO (|> arity .int _.int)
- limitO (|> arity dec .int _.int)
- @num_args (_.local "num_args")
- @self (_.local function_name)
- initialize_self! (_.set (list (//case.register 0)) @self)
- initialize! (list\fold (.function (_ post pre!)
- ($_ _.then
- pre!
- (_.set (list (..input post)) (_.nth (|> post .int _.int) @curried))))
- initialize_self!
- (list.indices arity))
- [declaration instatiation] (with_closure closureO+ function_name
- (_.lambda (#.Some @self) (list (_.variadic @curried))
- ($_ _.then
- (_.set (list @num_args) (_.the "length" @curried))
- (_.cond (list [(|> @num_args (_.= arityO))
- (<| (_.then initialize!)
- //loop.with_scope
- body!)]
- [(|> @num_args (_.> arityO))
- (let [slice (.function (_ from to)
- (_.array_range from to @curried))
- arity_args (_.splat (slice (_.int +0) limitO))
- output_func_args (_.splat (slice arityO @num_args))]
- (_.return (|> @self
- (_.apply_lambda/* (list arity_args))
- (_.apply_lambda/* (list output_func_args)))))])
- ## (|> @num_args (_.< arityO))
- (let [@missing (_.local "missing")]
- (_.return (_.lambda #.None (list (_.variadic @missing))
- (_.return (|> @self
- (_.apply_lambda/* (list (_.splat (|> (_.array (list))
- (_.do "concat" (list @curried))
- (_.do "concat" (list @missing))))))))))))
- )))]
- _ (/////generation.execute! declaration)
- _ (/////generation.save! function_artifact declaration)]
- (wrap instatiation)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux
deleted file mode 100644
index a2df0884a..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux
+++ /dev/null
@@ -1,95 +0,0 @@
-(.module:
- [lux (#- Scope)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." set]]]
- [math
- [number
- ["n" nat]]]
- [target
- ["_" ruby (#+ Expression LVar Statement)]]]
- ["." // #_
- [runtime (#+ Operation Phase Generator Phase! Generator!)]
- ["#." case]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- [synthesis
- ["." case]]
- ["/#" // #_
- ["." synthesis (#+ Scope Synthesis)]
- ["#." generation]
- ["//#" /// #_
- ["#." phase]
- [reference
- ["#." variable (#+ Register)]]]]]]])
-
-(def: (setup offset bindings body)
- (-> Register (List Expression) Statement Statement)
- (|> bindings
- list.enumeration
- (list\map (function (_ [register value])
- (_.set (list (//case.register (n.+ offset register)))
- value)))
- list.reverse
- (list\fold _.then body)))
-
-(def: symbol
- (_.symbol "lux_continue"))
-
-(def: #export with_scope
- (-> Statement Statement)
- (_.while (_.bool true)))
-
-(def: #export (scope! statement expression archive [start initsS+ bodyS])
- (Generator! (Scope Synthesis))
- (case initsS+
- ## function/false/non-independent loop
- #.Nil
- (statement expression archive bodyS)
-
- ## true loop
- _
- (do {! ///////phase.monad}
- [initsO+ (monad.map ! (expression archive) initsS+)
- body! (/////generation.with_anchor start
- (statement expression archive bodyS))]
- (wrap (<| (..setup start initsO+)
- ..with_scope
- body!)))))
-
-(def: #export (scope statement expression archive [start initsS+ bodyS])
- (-> Phase! (Generator (Scope Synthesis)))
- (case initsS+
- ## function/false/non-independent loop
- #.Nil
- (expression archive bodyS)
-
- ## true loop
- _
- (do {! ///////phase.monad}
- [body! (scope! statement expression archive [start initsS+ bodyS])]
- (wrap (|> body!
- (_.lambda #.None (list))
- (_.apply_lambda/* (list)))))))
-
-(def: #export (recur! statement expression archive argsS+)
- (Generator! (List Synthesis))
- (do {! ///////phase.monad}
- [offset /////generation.anchor
- @temp (//case.gensym "lux_recur_values")
- argsO+ (monad.map ! (expression archive) argsS+)
- #let [re_binds (|> argsO+
- list.enumeration
- (list\map (function (_ [idx _])
- (_.nth (_.int (.int idx)) @temp))))]]
- (wrap ($_ _.then
- (_.set (list @temp) (_.array argsO+))
- (..setup offset re_binds
- _.next)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux
deleted file mode 100644
index 59efdb9fb..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux
+++ /dev/null
@@ -1,15 +0,0 @@
-(.module:
- [lux (#- i64)
- [target
- ["_" ruby (#+ Literal)]]])
-
-(template [<type> <name> <implementation>]
- [(def: #export <name>
- (-> <type> Literal)
- <implementation>)]
-
- [Bit bit _.bool]
- [(I64 Any) i64 (|>> .int _.int)]
- [Frac f64 _.float]
- [Text text _.string]
- )
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux
deleted file mode 100644
index 1ea2cca00..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux
+++ /dev/null
@@ -1,12 +0,0 @@
-(.module:
- [lux #*
- [target
- ["_" ruby (#+ Expression)]]]
- [///
- [reference (#+ System)]])
-
-(implementation: #export system
- (System Expression)
-
- (def: constant _.global)
- (def: variable _.local))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux
deleted file mode 100644
index 2eb8ec79c..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux
+++ /dev/null
@@ -1,402 +0,0 @@
-(.module:
- [lux (#- inc)
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<.>" code]]]
- [data
- ["." product]
- ["." text ("#\." hash)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." list ("#\." functor)]
- ["." row]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number (#+ hex)
- ["." i64]]]
- ["@" target
- ["_" ruby (#+ Expression LVar Computation Literal Statement)]]]
- ["." /// #_
- ["#." reference]
- ["//#" /// #_
- ["$" version]
- ["#." synthesis (#+ Synthesis)]
- ["#." generation]
- ["//#" ///
- ["#." phase]
- [reference
- [variable (#+ Register)]]
- [meta
- [archive (#+ Output Archive)
- ["." artifact (#+ Registry)]]]]]])
-
-(template [<name> <base>]
- [(type: #export <name>
- (<base> Register Expression Statement))]
-
- [Operation /////generation.Operation]
- [Phase /////generation.Phase]
- [Handler /////generation.Handler]
- [Bundle /////generation.Bundle]
- )
-
-(type: #export (Generator i)
- (-> Phase Archive i (Operation Expression)))
-
-(type: #export Phase!
- (-> Phase Archive Synthesis (Operation Statement)))
-
-(type: #export (Generator! i)
- (-> Phase! Phase Archive i (Operation Statement)))
-
-(def: #export unit
- (_.string /////synthesis.unit))
-
-(def: (flag value)
- (-> Bit Literal)
- (if value
- ..unit
- _.nil))
-
-(def: (feature name definition)
- (-> LVar (-> LVar Statement) Statement)
- (definition name))
-
-(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
- body)
- (do {! meta.monad}
- [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
- (wrap (list (` (let [(~+ (|> vars
- (list.zip/2 ids)
- (list\map (function (_ [id var])
- (list (code.local_identifier var)
- (` (_.local (~ (code.text (format "v" (%.nat id)))))))))
- list.concat))]
- (~ body)))))))
-
-(def: module_id
- 0)
-
-(syntax: (runtime: {declaration (<>.or <code>.local_identifier
- (<code>.form (<>.and <code>.local_identifier
- (<>.some <code>.local_identifier))))}
- code)
- (do meta.monad
- [runtime_id meta.count]
- (macro.with_gensyms [g!_]
- (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id]))
- runtime_name (` (_.local (~ (code.text (%.code runtime)))))]
- (case declaration
- (#.Left name)
- (macro.with_gensyms [g!_]
- (let [g!name (code.local_identifier name)]
- (wrap (list (` (def: #export (~ g!name) LVar (~ runtime_name)))
- (` (def: (~ (code.local_identifier (format "@" name)))
- Statement
- (..feature (~ runtime_name)
- (function ((~ g!_) (~ g!name))
- (_.set (list (~ g!name)) (~ code))))))))))
-
- (#.Right [name inputs])
- (macro.with_gensyms [g!_]
- (let [g!name (code.local_identifier name)
- inputsC (list\map code.local_identifier inputs)
- inputs_typesC (list\map (function.constant (` _.Expression))
- inputs)]
- (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
- (-> (~+ inputs_typesC) Computation)
- (_.apply/* (list (~+ inputsC)) (~ runtime_name))))
-
- (` (def: (~ (code.local_identifier (format "@" name)))
- Statement
- (..feature (~ runtime_name)
- (function ((~ g!_) (~ g!_))
- (..with_vars [(~+ inputsC)]
- (_.function (~ g!_) (list (~+ inputsC))
- (~ code))))))))))))))))
-
-(def: tuple_size
- (_.the "length"))
-
-(def: last_index
- (|>> ..tuple_size (_.- (_.int +1))))
-
-(with_expansions [<recur> (as_is ($_ _.then
- (_.set (list lefts) (_.- last_index_right lefts))
- (_.set (list tuple) (_.nth last_index_right tuple))))]
- (runtime: (tuple//left lefts tuple)
- (with_vars [last_index_right]
- (<| (_.while (_.bool true))
- ($_ _.then
- (_.set (list last_index_right) (..last_index tuple))
- (_.if (_.> lefts last_index_right)
- ## No need for recursion
- (_.return (_.nth lefts tuple))
- ## Needs recursion
- <recur>)))))
-
- (runtime: (tuple//right lefts tuple)
- (with_vars [last_index_right right_index]
- (<| (_.while (_.bool true))
- ($_ _.then
- (_.set (list last_index_right) (..last_index tuple))
- (_.set (list right_index) (_.+ (_.int +1) lefts))
- (_.cond (list [(_.= last_index_right right_index)
- (_.return (_.nth right_index tuple))]
- [(_.> last_index_right right_index)
- ## Needs recursion.
- <recur>])
- (_.return (_.array_range right_index (..tuple_size tuple) tuple)))
- )))))
-
-(def: #export variant_tag_field "_lux_tag")
-(def: #export variant_flag_field "_lux_flag")
-(def: #export variant_value_field "_lux_value")
-
-(runtime: (sum//make tag last? value)
- (_.return (_.hash (list [(_.string ..variant_tag_field) tag]
- [(_.string ..variant_flag_field) last?]
- [(_.string ..variant_value_field) value]))))
-
-(def: #export (variant tag last? value)
- (-> Nat Bit Expression Computation)
- (sum//make (_.int (.int tag)) (..flag last?) value))
-
-(def: #export none
- Computation
- (..variant 0 #0 ..unit))
-
-(def: #export some
- (-> Expression Computation)
- (..variant 1 #1))
-
-(def: #export left
- (-> Expression Computation)
- (..variant 0 #0))
-
-(def: #export right
- (-> Expression Computation)
- (..variant 1 #1))
-
-(runtime: (sum//get sum wantsLast wantedTag)
- (let [no_match! (_.return _.nil)
- sum_tag (_.nth (_.string ..variant_tag_field) sum)
- sum_flag (_.nth (_.string ..variant_flag_field) sum)
- sum_value (_.nth (_.string ..variant_value_field) sum)
- is_last? (_.= ..unit sum_flag)
- test_recursion! (_.if is_last?
- ## Must recurse.
- ($_ _.then
- (_.set (list wantedTag) (_.- sum_tag wantedTag))
- (_.set (list sum) sum_value))
- no_match!)]
- (<| (_.while (_.bool true))
- (_.cond (list [(_.= sum_tag wantedTag)
- (_.if (_.= wantsLast sum_flag)
- (_.return sum_value)
- test_recursion!)]
-
- [(_.< wantedTag sum_tag)
- test_recursion!]
-
- [(_.= ..unit wantsLast)
- (_.return (sum//make (_.- wantedTag sum_tag) sum_flag sum_value))])
-
- no_match!))))
-
-(def: runtime//adt
- Statement
- ($_ _.then
- @tuple//left
- @tuple//right
- @sum//make
- @sum//get
- ))
-
-(runtime: (lux//try risky)
- (with_vars [error value]
- (_.begin ($_ _.then
- (_.set (list value) (_.apply_lambda/* (list ..unit) risky))
- (_.return (..right value)))
- (list [(list) error
- (_.return (..left (_.the "message" error)))]))))
-
-(runtime: (lux//program_args raw)
- (with_vars [tail head]
- ($_ _.then
- (_.set (list tail) ..none)
- (<| (_.for_in head raw)
- (_.set (list tail) (..some (_.array (list head tail)))))
- (_.return tail))))
-
-(def: runtime//lux
- Statement
- ($_ _.then
- @lux//try
- @lux//program_args
- ))
-
-(def: i64//+limit (_.manual "+0x7FFFFFFFFFFFFFFF"))
-(def: i64//-limit (_.manual "-0x8000000000000000"))
-(def: i64//+iteration (_.manual "+0x10000000000000000"))
-(def: i64//-iteration (_.manual "-0x10000000000000000"))
-(def: i64//+cap (_.manual "+0x8000000000000000"))
-(def: i64//-cap (_.manual "-0x8000000000000001"))
-
-(runtime: (i64//64 input)
- (with_vars [temp]
- (`` (<| (~~ (template [<scenario> <iteration> <cap> <entrance>]
- [(_.if (|> input <scenario>)
- ($_ _.then
- (_.set (list temp) (_.% <iteration> input))
- (_.return (_.? (|> temp <scenario>)
- (|> temp (_.- <cap>) (_.+ <entrance>))
- temp))))]
-
- [(_.> ..i64//+limit) ..i64//+iteration ..i64//+cap ..i64//-limit]
- [(_.< ..i64//-limit) ..i64//-iteration ..i64//-cap ..i64//+limit]
- ))
- (_.return input)))))
-
-(runtime: i64//nat_top
- (|> (_.int +1)
- (_.bit_shl (_.int +64))
- (_.- (_.int +1))))
-
-(def: as_nat
- (_.% (_.manual "0x10000000000000000")))
-
-(runtime: (i64//left_shift param subject)
- (_.return (|> subject
- (_.bit_shl (_.% (_.int +64) param))
- ..i64//64)))
-
-(runtime: (i64//right_shift param subject)
- ($_ _.then
- (_.set (list param) (_.% (_.int +64) param))
- (_.return (_.? (_.= (_.int +0) param)
- subject
- (|> subject
- ..as_nat
- (_.bit_shr param))))))
-
-(template [<runtime> <host>]
- [(runtime: (<runtime> left right)
- (_.return (..i64//64 (<host> (..as_nat left) (..as_nat right)))))]
-
- [i64//and _.bit_and]
- [i64//or _.bit_or]
- [i64//xor _.bit_xor]
- )
-
-(runtime: (i64//division parameter subject)
- (let [extra (_.do "remainder" (list parameter) subject)]
- (_.return (|> subject
- (_.- extra)
- (_./ parameter)))))
-
-(def: runtime//i64
- Statement
- ($_ _.then
- @i64//64
- @i64//nat_top
- @i64//left_shift
- @i64//right_shift
- @i64//and
- @i64//or
- @i64//xor
- @i64//division
- ))
-
-(runtime: (f64//decode inputG)
- (with_vars [@input @temp]
- ($_ _.then
- (_.set (list @input) inputG)
- (_.set (list @temp) (_.do "to_f" (list) @input))
- (_.if ($_ _.or
- (_.not (_.= (_.float +0.0) @temp))
- (_.= (_.string "0") @input)
- (_.= (_.string ".0") @input)
- (_.= (_.string "0.0") @input))
- (_.return (..some @temp))
- (_.return ..none)))))
-
-(def: runtime//f64
- Statement
- ($_ _.then
- @f64//decode
- ))
-
-(runtime: (text//index subject param start)
- (with_vars [idx]
- ($_ _.then
- (_.set (list idx) (|> subject (_.do "index" (list param start))))
- (_.if (_.= _.nil idx)
- (_.return ..none)
- (_.return (..some idx))))))
-
-(def: (within? top value)
- (-> Expression Expression Computation)
- (_.and (|> value (_.>= (_.int +0)))
- (|> value (_.< top))))
-
-(runtime: (text//clip offset length text)
- (_.if (_.= (_.int +0) length)
- (_.return (_.string ""))
- (_.return (_.array_range offset (_.+ offset (_.- (_.int +1) length)) text))))
-
-(runtime: (text//char idx text)
- (_.if (|> idx (within? (_.the "length" text)))
- (_.return (|> text (_.array_range idx idx) (_.do "ord" (list))))
- (_.statement (_.raise (_.string "[Lux Error] Cannot get char from text.")))))
-
-(def: runtime//text
- Statement
- ($_ _.then
- @text//index
- @text//clip
- @text//char
- ))
-
-(runtime: (array//write idx value array)
- ($_ _.then
- (_.set (list (_.nth idx array)) value)
- (_.return array)))
-
-(def: runtime//array
- Statement
- ($_ _.then
- @array//write
- ))
-
-(def: runtime
- Statement
- ($_ _.then
- runtime//adt
- runtime//lux
- runtime//i64
- runtime//f64
- runtime//text
- runtime//array
- ))
-
-(def: #export generate
- (Operation [Registry Output])
- (do ///////phase.monad
- [_ (/////generation.execute! ..runtime)
- _ (/////generation.save! ..module_id ..runtime)]
- (wrap [(|> artifact.empty
- artifact.resource
- product.right)
- (row.row [..module_id
- (|> ..runtime
- _.code
- (\ utf8.codec encode))])])))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux
deleted file mode 100644
index e8d192326..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux
+++ /dev/null
@@ -1,36 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [target
- ["_" ruby (#+ Expression)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." primitive]
- ["///#" //// #_
- [analysis (#+ Variant Tuple)]
- ["#." synthesis (#+ Synthesis)]
- ["//#" /// #_
- ["#." phase ("#\." monad)]]]])
-
-(def: #export (tuple generate archive elemsS+)
- (Generator (Tuple Synthesis))
- (case elemsS+
- #.Nil
- (///////phase\wrap (//primitive.text /////synthesis.unit))
-
- (#.Cons singletonS #.Nil)
- (generate archive singletonS)
-
- _
- (|> elemsS+
- (monad.map ///////phase.monad (generate archive))
- (///////phase\map _.array))))
-
-(def: #export (variant generate archive [lefts right? valueS])
- (Generator (Variant Synthesis))
- (let [tag (if right?
- (inc lefts)
- lefts)]
- (///////phase\map (//runtime.variant tag right?)
- (generate archive valueS))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux
deleted file mode 100644
index 1a36df4e0..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux
+++ /dev/null
@@ -1,58 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [target
- ["_" scheme]]]
- ["." / #_
- [runtime (#+ Phase)]
- ["#." primitive]
- ["#." structure]
- ["#." reference]
- ["#." case]
- ["#." loop]
- ["#." function]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- ["#." extension]
- ["/#" // #_
- [analysis (#+)]
- ["#." synthesis]
- ["//#" /// #_
- ["#." phase ("#\." monad)]
- [reference (#+)
- [variable (#+)]]]]]]])
-
-(def: #export (generate archive synthesis)
- Phase
- (case synthesis
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (//////phase\wrap (<generator> value))])
- ([////synthesis.bit /primitive.bit]
- [////synthesis.i64 /primitive.i64]
- [////synthesis.f64 /primitive.f64]
- [////synthesis.text /primitive.text])
-
- (#////synthesis.Reference value)
- (//reference.reference /reference.system archive value)
-
- (^template [<tag> <generator>]
- [(^ (<tag> value))
- (<generator> generate archive value)])
- ([////synthesis.variant /structure.variant]
- [////synthesis.tuple /structure.tuple]
- [////synthesis.branch/let /case.let]
- [////synthesis.branch/if /case.if]
- [////synthesis.branch/get /case.get]
- [////synthesis.function/apply /function.apply]
-
- [////synthesis.branch/case /case.case]
- [////synthesis.loop/scope /loop.scope]
- [////synthesis.loop/recur /loop.recur]
- [////synthesis.function/abstraction /function.function])
-
- (#////synthesis.Extension extension)
- (///extension.apply archive generate extension)
- ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux
deleted file mode 100644
index 884e20c0f..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux
+++ /dev/null
@@ -1,222 +0,0 @@
-(.module:
- [lux (#- case let if)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." set]]]
- [macro
- ["." template]]
- [math
- [number
- ["i" int]]]
- [target
- ["_" scheme (#+ Expression Computation Var)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." reference]
- ["#." primitive]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- ["#." synthesis #_
- ["#/." case]]
- ["/#" // #_
- ["#." synthesis (#+ Member Synthesis Path)]
- ["#." generation]
- ["//#" /// #_
- [reference
- ["#." variable (#+ Register)]]
- ["#." phase ("#\." monad)]
- [meta
- [archive (#+ Archive)]]]]]]])
-
-(def: #export register
- (-> Register Var)
- (|>> (///reference.local //reference.system) :assume))
-
-(def: #export capture
- (-> Register Var)
- (|>> (///reference.foreign //reference.system) :assume))
-
-(def: #export (let expression archive [valueS register bodyS])
- (Generator [Synthesis Register Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)
- bodyO (expression archive bodyS)]
- (wrap (_.let (list [(..register register) valueO])
- bodyO))))
-
-(def: #export (if expression archive [testS thenS elseS])
- (Generator [Synthesis Synthesis Synthesis])
- (do ///////phase.monad
- [testO (expression archive testS)
- thenO (expression archive thenS)
- elseO (expression archive elseS)]
- (wrap (_.if testO thenO elseO))))
-
-(def: #export (get expression archive [pathP valueS])
- (Generator [(List Member) Synthesis])
- (do ///////phase.monad
- [valueO (expression archive valueS)]
- (wrap (list\fold (function (_ side source)
- (.let [method (.case side
- (^template [<side> <accessor>]
- [(<side> lefts)
- (<accessor> (_.int (.int lefts)))])
- ([#.Left //runtime.tuple//left]
- [#.Right //runtime.tuple//right]))]
- (method source)))
- valueO
- (list.reverse pathP)))))
-
-(def: @savepoint (_.var "lux_pm_cursor_savepoint"))
-(def: @cursor (_.var "lux_pm_cursor"))
-(def: @temp (_.var "lux_pm_temp"))
-(def: @alt_error (_.var "alt_error"))
-
-(def: (push! value var)
- (-> Expression Var Computation)
- (_.set! var (_.cons/2 value var)))
-
-(def: (push_cursor! value)
- (-> Expression Computation)
- (push! value @cursor))
-
-(def: (pop! var)
- (-> Var Computation)
- (_.set! var (_.cdr/1 var)))
-
-(def: save_cursor!
- Computation
- (push! @cursor @savepoint))
-
-(def: restore_cursor!
- Computation
- (_.begin (list (_.set! @cursor (_.car/1 @savepoint))
- (_.set! @savepoint (_.cdr/1 @savepoint)))))
-
-(def: peek
- Computation
- (_.car/1 @cursor))
-
-(def: pop_cursor!
- Computation
- (pop! @cursor))
-
-(def: pm_error
- (_.string (template.with_locals [pm_error]
- (template.text [pm_error]))))
-
-(def: fail!
- (_.raise/1 pm_error))
-
-(def: (try_pm on_failure happy_path)
- (-> Expression Expression Computation)
- (_.guard @alt_error
- (list [(_.and (list (_.string?/1 @alt_error)
- (_.string=?/2 ..pm_error @alt_error)))
- on_failure])
- #.None
- happy_path))
-
-(def: (pattern_matching' expression archive)
- (Generator Path)
- (function (recur pathP)
- (.case pathP
- (#/////synthesis.Then bodyS)
- (expression archive bodyS)
-
- #/////synthesis.Pop
- (///////phase\wrap pop_cursor!)
-
- (#/////synthesis.Bind register)
- (///////phase\wrap (_.define_constant (..register register) ..peek))
-
- (#/////synthesis.Bit_Fork when thenP elseP)
- (do {! ///////phase.monad}
- [then! (recur thenP)
- else! (.case elseP
- (#.Some elseP)
- (recur elseP)
-
- #.None
- (wrap ..fail!))]
- (wrap (.if when
- (_.if ..peek
- then!
- else!)
- (_.if ..peek
- else!
- then!))))
-
- (^template [<tag> <format> <=>]
- [(<tag> cons)
- (do {! ///////phase.monad}
- [clauses (monad.map ! (function (_ [match then])
- (do !
- [then! (recur then)]
- (wrap [(<=> (|> match <format>)
- ..peek)
- then!])))
- (#.Cons cons))]
- (wrap (list\fold (function (_ [when then] else)
- (_.if when then else))
- ..fail!
- clauses)))])
- ([#/////synthesis.I64_Fork //primitive.i64 _.=/2]
- [#/////synthesis.F64_Fork //primitive.f64 _.=/2]
- [#/////synthesis.Text_Fork //primitive.text _.string=?/2])
-
- (^template [<pm> <flag> <prep>]
- [(^ (<pm> idx))
- (///////phase\wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek (_.bool <flag>)))])
- (_.if (_.null?/1 @temp)
- ..fail!
- (push_cursor! @temp))))])
- ([/////synthesis.side/left false (<|)]
- [/////synthesis.side/right true inc])
-
- (^ (/////synthesis.member/left 0))
- (///////phase\wrap (..push_cursor! (_.vector-ref/2 ..peek (_.int +0))))
-
- (^template [<pm> <getter>]
- [(^ (<pm> lefts))
- (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push_cursor!))])
- ([/////synthesis.member/left //runtime.tuple//left]
- [/////synthesis.member/right //runtime.tuple//right])
-
- (^ (/////synthesis.path/seq leftP rightP))
- (do ///////phase.monad
- [leftO (recur leftP)
- rightO (recur rightP)]
- (wrap (_.begin (list leftO
- rightO))))
-
- (^ (/////synthesis.path/alt leftP rightP))
- (do {! ///////phase.monad}
- [leftO (recur leftP)
- rightO (recur rightP)]
- (wrap (try_pm (_.begin (list restore_cursor!
- rightO))
- (_.begin (list save_cursor!
- leftO)))))
- )))
-
-(def: (pattern_matching expression archive pathP)
- (Generator Path)
- (\ ///////phase.monad map
- (try_pm (_.raise/1 (_.string "Invalid expression for pattern-matching.")))
- (pattern_matching' expression archive pathP)))
-
-(def: #export (case expression archive [valueS pathP])
- (Generator [Synthesis Path])
- (do {! ///////phase.monad}
- [valueO (expression archive valueS)]
- (<| (\ ! map (_.let (list [@cursor (_.list/* (list valueO))]
- [@savepoint (_.list/* (list))])))
- (pattern_matching expression archive pathP))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux
deleted file mode 100644
index 3bc0a0887..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux
+++ /dev/null
@@ -1,13 +0,0 @@
-(.module:
- [lux #*
- [data
- [collection
- ["." dictionary]]]]
- [//
- [runtime (#+ Bundle)]]
- [/
- ["." common]])
-
-(def: #export bundle
- Bundle
- common.bundle)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux
deleted file mode 100644
index f7f55e260..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux
+++ /dev/null
@@ -1,222 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["ex" exception (#+ exception:)]
- [parser
- ["s" code]]]
- [data
- ["." product]
- ["." text]
- [number (#+ hex)
- ["f" frac]]
- [collection
- ["." list ("#\." functor)]
- ["dict" dictionary (#+ Dictionary)]]]
- ["." macro (#+ with-gensyms)
- ["." code]
- [syntax (#+ syntax:)]]
- [target
- ["_" scheme (#+ Expression Computation)]]]
- ["." /// #_
- ["#." runtime (#+ Operation Phase Handler Bundle)]
- ["#//" ///
- ["#." extension
- ["." bundle]]
- ["#/" // #_
- ["#." synthesis (#+ Synthesis)]]]])
-
-(syntax: (Vector {size s.nat} elemT)
- (wrap (list (` [(~+ (list.repeat size elemT))]))))
-
-(type: #export Nullary (-> (Vector 0 Expression) Computation))
-(type: #export Unary (-> (Vector 1 Expression) Computation))
-(type: #export Binary (-> (Vector 2 Expression) Computation))
-(type: #export Trinary (-> (Vector 3 Expression) Computation))
-(type: #export Variadic (-> (List Expression) Computation))
-
-(syntax: (arity: {name s.local-identifier} {arity s.nat})
- (with-gensyms [g!_ g!extension g!name g!phase g!inputs]
- (do {! macro.monad}
- [g!input+ (monad.seq ! (list.repeat arity (macro.gensym "input")))]
- (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension))
- (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation)
- Handler)
- (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs))
- (case (~ g!inputs)
- (^ (list (~+ g!input+)))
- (do /////.monad
- [(~+ (|> g!input+
- (list\map (function (_ g!input)
- (list g!input (` ((~ g!phase) (~ g!input))))))
- list.concat))]
- ((~' wrap) ((~ g!extension) [(~+ g!input+)])))
-
- (~' _)
- (/////.throw /////extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))]))))))))))
-
-(arity: nullary 0)
-(arity: unary 1)
-(arity: binary 2)
-(arity: trinary 3)
-
-(def: #export (variadic extension)
- (-> Variadic Handler)
- (function (_ extension-name)
- (function (_ phase inputsS)
- (do {! /////.monad}
- [inputsI (monad.map ! phase inputsS)]
- (wrap (extension inputsI))))))
-
-(def: bundle::lux
- Bundle
- (|> bundle.empty
- (bundle.install "is?" (binary (product.uncurry _.eq?/2)))
- (bundle.install "try" (unary ///runtime.lux//try))))
-
-(template [<name> <op>]
- [(def: (<name> [subjectO paramO])
- Binary
- (<op> paramO subjectO))]
-
- [i64::and _.bit-and/2]
- [i64::or _.bit-or/2]
- [i64::xor _.bit-xor/2]
- )
-
-(def: (i64::left-shift [subjectO paramO])
- Binary
- (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO)
- subjectO))
-
-(def: (i64::arithmetic-right-shift [subjectO paramO])
- Binary
- (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1)))
- subjectO))
-
-(def: (i64::logical-right-shift [subjectO paramO])
- Binary
- (///runtime.i64//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO))
-
-(template [<name> <op>]
- [(def: (<name> [subjectO paramO])
- Binary
- (|> subjectO (<op> paramO)))]
-
- [i64::+ _.+/2]
- [i64::- _.-/2]
- [i64::* _.*/2]
- [i64::/ _.quotient/2]
- [i64::% _.remainder/2]
- )
-
-(template [<name> <op>]
- [(def: (<name> [subjectO paramO])
- Binary
- (<op> paramO subjectO))]
-
- [f64::+ _.+/2]
- [f64::- _.-/2]
- [f64::* _.*/2]
- [f64::/ _.//2]
- [f64::% _.mod/2]
- [f64::= _.=/2]
- [f64::< _.</2]
-
- [text::= _.string=?/2]
- [text::< _.string<?/2]
- )
-
-(template [<name> <cmp>]
- [(def: (<name> [subjectO paramO])
- Binary
- (<cmp> paramO subjectO))]
-
- [i64::= _.=/2]
- [i64::< _.</2]
- )
-
-(def: i64::char (|>> _.integer->char/1 _.string/1))
-
-(def: bundle::i64
- Bundle
- (<| (bundle.prefix "i64")
- (|> bundle.empty
- (bundle.install "and" (binary i64::and))
- (bundle.install "or" (binary i64::or))
- (bundle.install "xor" (binary i64::xor))
- (bundle.install "left-shift" (binary i64::left-shift))
- (bundle.install "logical-right-shift" (binary i64::logical-right-shift))
- (bundle.install "arithmetic-right-shift" (binary i64::arithmetic-right-shift))
- (bundle.install "+" (binary i64::+))
- (bundle.install "-" (binary i64::-))
- (bundle.install "*" (binary i64::*))
- (bundle.install "/" (binary i64::/))
- (bundle.install "%" (binary i64::%))
- (bundle.install "=" (binary i64::=))
- (bundle.install "<" (binary i64::<))
- (bundle.install "f64" (unary (|>> (_.//2 (_.float +1.0)))))
- (bundle.install "char" (unary i64::char)))))
-
-(def: bundle::f64
- Bundle
- (<| (bundle.prefix "f64")
- (|> bundle.empty
- (bundle.install "+" (binary f64::+))
- (bundle.install "-" (binary f64::-))
- (bundle.install "*" (binary f64::*))
- (bundle.install "/" (binary f64::/))
- (bundle.install "%" (binary f64::%))
- (bundle.install "=" (binary f64::=))
- (bundle.install "<" (binary f64::<))
- (bundle.install "i64" (unary _.exact/1))
- (bundle.install "encode" (unary _.number->string/1))
- (bundle.install "decode" (unary ///runtime.frac//decode)))))
-
-(def: (text::char [subjectO paramO])
- Binary
- (_.string/1 (_.string-ref/2 subjectO paramO)))
-
-(def: (text::clip [subjectO startO endO])
- Trinary
- (_.substring/3 subjectO startO endO))
-
-(def: bundle::text
- Bundle
- (<| (bundle.prefix "text")
- (|> bundle.empty
- (bundle.install "=" (binary text::=))
- (bundle.install "<" (binary text::<))
- (bundle.install "concat" (binary (product.uncurry _.string-append/2)))
- (bundle.install "size" (unary _.string-length/1))
- (bundle.install "char" (binary text::char))
- (bundle.install "clip" (trinary text::clip)))))
-
-(def: (io::log input)
- Unary
- (_.begin (list (_.display/1 input)
- _.newline/0)))
-
-(def: (void code)
- (-> Expression Computation)
- (_.begin (list code (_.string //////synthesis.unit))))
-
-(def: bundle::io
- Bundle
- (<| (bundle.prefix "io")
- (|> bundle.empty
- (bundle.install "log" (unary (|>> io::log ..void)))
- (bundle.install "error" (unary _.raise/1))
- (bundle.install "exit" (unary _.exit/1))
- (bundle.install "current-time" (nullary (function (_ _) (///runtime.io//current-time (_.string //////synthesis.unit))))))))
-
-(def: #export bundle
- Bundle
- (<| (bundle.prefix "lux")
- (|> bundle::lux
- (dict.merge bundle::i64)
- (dict.merge bundle::f64)
- (dict.merge bundle::text)
- (dict.merge bundle::io)
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux
deleted file mode 100644
index 65c674ded..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux
+++ /dev/null
@@ -1,100 +0,0 @@
-(.module:
- [lux (#- function)
- [abstract
- ["." monad (#+ do)]]
- [control
- pipe]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]]]
- [target
- ["_" scheme (#+ Expression Computation Var)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." reference]
- ["#." case]
- ["/#" // #_
- ["#." reference]
- ["//#" /// #_
- [analysis (#+ Variant Tuple Abstraction Application Analysis)]
- [synthesis (#+ Synthesis)]
- ["#." generation (#+ Context)]
- ["//#" /// #_
- [arity (#+ Arity)]
- ["#." phase ("#\." monad)]
- [reference
- [variable (#+ Register Variable)]]]]]])
-
-(def: #export (apply expression archive [functionS argsS+])
- (Generator (Application Synthesis))
- (do {! ///////phase.monad}
- [functionO (expression archive functionS)
- argsO+ (monad.map ! (expression archive) argsS+)]
- (wrap (_.apply/* argsO+ functionO))))
-
-(def: capture
- (-> Register Var)
- (|>> (///reference.foreign //reference.system) :assume))
-
-(def: (with_closure inits function_definition)
- (-> (List Expression) Computation (Operation Computation))
- (///////phase\wrap
- (case inits
- #.Nil
- function_definition
-
- _
- (|> function_definition
- (_.lambda [(|> (list.enumeration inits)
- (list\map (|>> product.left ..capture)))
- #.None])
- (_.apply/* inits)))))
-
-(def: @curried (_.var "curried"))
-(def: @missing (_.var "missing"))
-
-(def: input
- (|>> inc //case.register))
-
-(def: #export (function expression archive [environment arity bodyS])
- (Generator (Abstraction Synthesis))
- (do {! ///////phase.monad}
- [[function_name bodyO] (/////generation.with_new_context archive
- (do !
- [@self (\ ! map (|>> ///reference.artifact _.var)
- (/////generation.context archive))]
- (/////generation.with_anchor @self
- (expression archive bodyS))))
- closureO+ (monad.map ! (expression archive) environment)
- #let [arityO (|> arity .int _.int)
- apply_poly (.function (_ args func)
- (_.apply/2 (_.var "apply") func args))
- @num_args (_.var "num_args")
- @self (_.var (///reference.artifact function_name))]]
- (with_closure closureO+
- (_.letrec (list [@self (_.lambda [(list) (#.Some @curried)]
- (_.let (list [@num_args (_.length/1 @curried)])
- (<| (_.if (|> @num_args (_.=/2 arityO))
- (<| (_.let (list [(//case.register 0) @self]))
- (_.let_values (list [[(|> (list.indices arity)
- (list\map ..input))
- #.None]
- (_.apply/2 (_.var "apply") (_.var "values") @curried)]))
- bodyO))
- (_.if (|> @num_args (_.>/2 arityO))
- (let [arity_args (//runtime.slice (_.int +0) arityO @curried)
- output_func_args (//runtime.slice arityO
- (|> @num_args (_.-/2 arityO))
- @curried)]
- (_.begin (list (|> @self
- (apply_poly arity_args)
- (apply_poly output_func_args))))))
- ## (|> @num_args (_.</2 arityO))
- (_.lambda [(list) (#.Some @missing)]
- (|> @self
- (apply_poly (_.append/2 @curried @missing)))))
- ))])
- @self))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux
deleted file mode 100644
index d4b964910..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux
+++ /dev/null
@@ -1,63 +0,0 @@
-(.module:
- [lux (#- Scope)
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." set (#+ Set)]]]
- [math
- [number
- ["n" nat]]]
- [target
- ["_" scheme]]]
- ["." // #_
- [runtime (#+ Operation Phase Generator)]
- ["#." case]
- ["/#" // #_
- ["#." reference]
- ["/#" // #_
- [synthesis
- ["." case]]
- ["/#" // #_
- ["."synthesis (#+ Scope Synthesis)]
- ["#." generation]
- ["//#" /// #_
- ["#." phase]
- [meta
- [archive (#+ Archive)]]
- [reference
- [variable (#+ Register)]]]]]]])
-
-(def: @scope
- (_.var "scope"))
-
-(def: #export (scope expression archive [start initsS+ bodyS])
- (Generator (Scope Synthesis))
- (case initsS+
- ## function/false/non-independent loop
- #.Nil
- (expression archive bodyS)
-
- ## true loop
- _
- (do {! ///////phase.monad}
- [initsO+ (monad.map ! (expression archive) initsS+)
- bodyO (/////generation.with_anchor @scope
- (expression archive bodyS))]
- (wrap (_.letrec (list [@scope (_.lambda [(|> initsS+
- list.enumeration
- (list\map (|>> product.left (n.+ start) //case.register)))
- #.None]
- bodyO)])
- (_.apply/* initsO+ @scope))))))
-
-(def: #export (recur expression archive argsS+)
- (Generator (List Synthesis))
- (do {! ///////phase.monad}
- [@scope /////generation.anchor
- argsO+ (monad.map ! (expression archive) argsS+)]
- (wrap (_.apply/* argsO+ @scope))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux
deleted file mode 100644
index 4bfa67161..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux
+++ /dev/null
@@ -1,15 +0,0 @@
-(.module:
- [lux (#- i64)
- [target
- ["_" scheme (#+ Expression)]]])
-
-(template [<name> <type> <code>]
- [(def: #export <name>
- (-> <type> Expression)
- <code>)]
-
- [bit Bit _.bool]
- [i64 (I64 Any) (|>> .int _.int)]
- [f64 Frac _.float]
- [text Text _.string]
- )
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux
deleted file mode 100644
index f24134d9f..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux
+++ /dev/null
@@ -1,12 +0,0 @@
-(.module:
- [lux #*
- [target
- ["_" scheme (#+ Expression)]]]
- [///
- [reference (#+ System)]])
-
-(implementation: #export system
- (System Expression)
-
- (def: constant _.var)
- (def: variable _.var))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux
deleted file mode 100644
index 7f55df9a9..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux
+++ /dev/null
@@ -1,369 +0,0 @@
-(.module:
- [lux (#- Location inc)
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["<>" parser
- ["<.>" code]]]
- [data
- ["." product]
- ["." text ("#\." hash)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." list ("#\." functor)]
- ["." row]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number (#+ hex)
- ["." i64]]]
- ["@" target
- ["_" scheme (#+ Expression Computation Var)]]]
- ["." /// #_
- ["#." reference]
- ["//#" /// #_
- [analysis (#+ Variant)]
- ["#." synthesis (#+ Synthesis)]
- ["#." generation]
- ["//#" ///
- ["#." phase]
- [reference
- [variable (#+ Register)]]
- [meta
- [archive (#+ Output Archive)
- ["." artifact (#+ Registry)]]]]]])
-
-(def: module_id
- 0)
-
-(template [<name> <base>]
- [(type: #export <name>
- (<base> Var Expression Expression))]
-
- [Operation /////generation.Operation]
- [Phase /////generation.Phase]
- [Handler /////generation.Handler]
- [Bundle /////generation.Bundle]
- )
-
-(type: #export (Generator i)
- (-> Phase Archive i (Operation Expression)))
-
-(def: #export unit
- (_.string /////synthesis.unit))
-
-(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))}
- body)
- (do {! meta.monad}
- [ids (monad.seq ! (list.repeat (list.size vars) meta.count))]
- (wrap (list (` (let [(~+ (|> vars
- (list.zip/2 ids)
- (list\map (function (_ [id var])
- (list (code.local_identifier var)
- (` (_.var (~ (code.text (format "v" (%.nat id)))))))))
- list.concat))]
- (~ body)))))))
-
-(syntax: (runtime: {declaration (<>.or <code>.local_identifier
- (<code>.form (<>.and <code>.local_identifier
- (<>.some <code>.local_identifier))))}
- code)
- (do meta.monad
- [runtime_id meta.count]
- (macro.with_gensyms [g!_]
- (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id]))
- runtime_name (` (_.var (~ (code.text (%.code runtime)))))]
- (case declaration
- (#.Left name)
- (let [g!name (code.local_identifier name)]
- (wrap (list (` (def: #export (~ g!name)
- Var
- (~ runtime_name)))
-
- (` (def: (~ (code.local_identifier (format "@" name)))
- _.Computation
- (_.define_constant (~ runtime_name) (~ code)))))))
-
- (#.Right [name inputs])
- (let [g!name (code.local_identifier name)
- inputsC (list\map code.local_identifier inputs)
- inputs_typesC (list\map (function.constant (` _.Expression))
- inputs)]
- (wrap (list (` (def: #export ((~ g!name) (~+ inputsC))
- (-> (~+ inputs_typesC) _.Computation)
- (_.apply/* (list (~+ inputsC)) (~ runtime_name))))
-
- (` (def: (~ (code.local_identifier (format "@" name)))
- _.Computation
- (..with_vars [(~+ inputsC)]
- (_.define_function (~ runtime_name) [(list (~+ inputsC)) #.None]
- (~ code)))))))))))))
-
-(def: last_index
- (-> Expression Computation)
- (|>> _.length/1 (_.-/2 (_.int +1))))
-
-(runtime: (tuple//left lefts tuple)
- (with_vars [last_index_right]
- (_.begin
- (list (_.define_constant last_index_right (..last_index tuple))
- (_.if (_.>/2 lefts last_index_right)
- ## No need for recursion
- (_.vector-ref/2 tuple lefts)
- ## Needs recursion
- (tuple//left (_.-/2 last_index_right lefts)
- (_.vector-ref/2 tuple last_index_right)))))))
-
-(runtime: (tuple//right lefts tuple)
- (with_vars [last_index_right right_index @slice]
- (_.begin
- (list (_.define_constant last_index_right (..last_index tuple))
- (_.define_constant right_index (_.+/2 (_.int +1) lefts))
- (<| (_.if (_.=/2 last_index_right right_index)
- (_.vector-ref/2 tuple right_index))
- (_.if (_.>/2 last_index_right right_index)
- ## Needs recursion.
- (tuple//right (_.-/2 last_index_right lefts)
- (_.vector-ref/2 tuple last_index_right)))
- (_.begin
- (list (_.define_constant @slice (_.make-vector/1 (_.-/2 right_index (_.length/1 tuple))))
- (_.vector-copy!/5 @slice (_.int +0) tuple right_index (_.length/1 tuple))
- @slice))))
- )))
-
-(def: (variant' tag last? value)
- (-> Expression Expression Expression Computation)
- ($_ _.cons/2
- tag
- last?
- value))
-
-(runtime: (sum//make tag last? value)
- (variant' tag last? value))
-
-(def: #export (variant [lefts right? value])
- (-> (Variant Expression) Computation)
- (..sum//make (_.int (.int lefts)) (_.bool right?) value))
-
-(runtime: (sum//get sum last? wanted_tag)
- (with_vars [sum_tag sum_flag sum_value sum_temp sum_dump]
- (let [no_match _.nil
- test_recursion (_.if sum_flag
- ## Must recurse.
- (sum//get sum_value
- last?
- (|> wanted_tag (_.-/2 sum_tag)))
- no_match)]
- (<| (_.let (list [sum_tag (_.car/1 sum)]
- [sum_temp (_.cdr/1 sum)]))
- (_.let (list [sum_flag (_.car/1 sum_temp)]
- [sum_value (_.cdr/1 sum_temp)]))
- (_.if (_.=/2 wanted_tag sum_tag)
- (_.if (_.eqv?/2 last? sum_flag)
- sum_value
- test_recursion))
- (_.if (_.</2 wanted_tag sum_tag)
- test_recursion)
- (_.if last?
- (variant' (|> sum_tag (_.-/2 wanted_tag)) sum_flag sum_value))
- no_match))))
-
-(def: runtime//adt
- Computation
- (_.begin (list @tuple//left
- @tuple//right
- @sum//get
- @sum//make)))
-
-(def: #export none
- Computation
- (|> ..unit [0 #0] variant))
-
-(def: #export some
- (-> Expression Computation)
- (|>> [1 #1] ..variant))
-
-(def: #export left
- (-> Expression Computation)
- (|>> [0 #0] ..variant))
-
-(def: #export right
- (-> Expression Computation)
- (|>> [1 #1] ..variant))
-
-(runtime: (slice offset length list)
- (<| (_.if (_.null?/1 list)
- list)
- (_.if (|> offset (_.>/2 (_.int +0)))
- (slice (|> offset (_.-/2 (_.int +1)))
- length
- (_.cdr/1 list)))
- (_.if (|> length (_.>/2 (_.int +0)))
- (_.cons/2 (_.car/1 list)
- (slice offset
- (|> length (_.-/2 (_.int +1)))
- (_.cdr/1 list))))
- _.nil))
-
-(runtime: (lux//try op)
- (with_vars [error]
- (_.with_exception_handler
- (_.lambda [(list error) #.None]
- (..left error))
- (_.lambda [(list) #.None]
- (..right (_.apply/* (list ..unit) op))))))
-
-(runtime: (lux//program_args program_args)
- (with_vars [@loop @input @output]
- (_.letrec (list [@loop (_.lambda [(list @input @output) #.None]
- (_.if (_.null?/1 @input)
- @output
- (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))])
- (_.apply/2 @loop (_.reverse/1 program_args) ..none))))
-
-(def: runtime//lux
- Computation
- (_.begin (list @lux//try
- @lux//program_args)))
-
-(def: i64//+limit (_.manual "+9223372036854775807"
- ## "+0x7FFFFFFFFFFFFFFF"
- ))
-(def: i64//-limit (_.manual "-9223372036854775808"
- ## "-0x8000000000000000"
- ))
-(def: i64//+iteration (_.manual "+18446744073709551616"
- ## "+0x10000000000000000"
- ))
-(def: i64//-iteration (_.manual "-18446744073709551616"
- ## "-0x10000000000000000"
- ))
-(def: i64//+cap (_.manual "+9223372036854775808"
- ## "+0x8000000000000000"
- ))
-(def: i64//-cap (_.manual "-9223372036854775809"
- ## "-0x8000000000000001"
- ))
-
-(runtime: (i64//64 input)
- (with_vars [temp]
- (`` (<| (~~ (template [<scenario> <iteration> <cap> <entrance>]
- [(_.if (|> input <scenario>)
- (_.let (list [temp (_.remainder/2 <iteration> input)])
- (_.if (|> temp <scenario>)
- (|> temp (_.-/2 <cap>) (_.+/2 <entrance>))
- temp)))]
-
- [(_.>/2 ..i64//+limit) ..i64//+iteration ..i64//+cap ..i64//-limit]
- [(_.</2 ..i64//-limit) ..i64//-iteration ..i64//-cap ..i64//+limit]
- ))
- input))))
-
-(runtime: (i64//left_shift param subject)
- (|> subject
- (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) param))
- ..i64//64))
-
-(def: as_nat
- (_.remainder/2 ..i64//+iteration))
-
-(runtime: (i64//right_shift shift subject)
- (_.let (list [shift (_.remainder/2 (_.int +64) shift)])
- (_.if (_.=/2 (_.int +0) shift)
- subject
- (|> subject
- ..as_nat
- (_.arithmetic-shift/2 (_.-/2 shift (_.int +0)))))))
-
-(template [<runtime> <host>]
- [(runtime: (<runtime> left right)
- (..i64//64 (<host> (..as_nat left) (..as_nat right))))]
-
- [i64//or _.bitwise-ior/2]
- [i64//xor _.bitwise-xor/2]
- [i64//and _.bitwise-and/2]
- )
-
-(runtime: (i64//division param subject)
- (|> subject (_.//2 param) _.truncate/1 ..i64//64))
-
-(def: runtime//i64
- Computation
- (_.begin (list @i64//64
- @i64//left_shift
- @i64//right_shift
- @i64//or
- @i64//xor
- @i64//and
- @i64//division)))
-
-(runtime: (f64//decode input)
- (with_vars [@output]
- (let [output_is_not_a_number? (_.not/1 (_.=/2 @output @output))
- input_is_not_a_number? (_.string=?/2 (_.string "+nan.0") input)]
- (_.let (list [@output (_.string->number/1 input)])
- (_.if (_.and (list output_is_not_a_number?
- (_.not/1 input_is_not_a_number?)))
- ..none
- (..some @output))))))
-
-(def: runtime//f64
- Computation
- (_.begin (list @f64//decode)))
-
-(runtime: (text//index offset sub text)
- (with_vars [index]
- (_.let (list [index (_.string-contains/3 text sub offset)])
- (_.if index
- (..some index)
- ..none))))
-
-(runtime: (text//clip offset length text)
- (_.substring/3 text offset (_.+/2 offset length)))
-
-(runtime: (text//char index text)
- (_.char->integer/1 (_.string-ref/2 text index)))
-
-(def: runtime//text
- (_.begin (list @text//index
- @text//clip
- @text//char)))
-
-(runtime: (array//write idx value array)
- (_.begin (list (_.vector-set!/3 array idx value)
- array)))
-
-(def: runtime//array
- Computation
- ($_ _.then
- @array//write
- ))
-
-(def: runtime
- Computation
- (_.begin (list @slice
- runtime//lux
- runtime//i64
- runtime//adt
- runtime//f64
- runtime//text
- runtime//array
- )))
-
-(def: #export generate
- (Operation [Registry Output])
- (do ///////phase.monad
- [_ (/////generation.execute! ..runtime)
- _ (/////generation.save! (%.nat ..module_id) ..runtime)]
- (wrap [(|> artifact.empty
- artifact.resource
- product.right)
- (row.row [(%.nat ..module_id)
- (|> ..runtime
- _.code
- (\ utf8.codec encode))])])))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux
deleted file mode 100644
index 951fa494d..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux
+++ /dev/null
@@ -1,39 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [data
- [collection
- ["." list]]]
- [target
- ["_" scheme (#+ Expression)]]]
- ["." // #_
- ["#." runtime (#+ Operation Phase Generator)]
- ["#." primitive]
- ["///#" //// #_
- [analysis (#+ Variant Tuple)]
- ["#." synthesis (#+ Synthesis)]
- ["//#" /// #_
- ["#." phase ("#\." monad)]]]])
-
-(def: #export (tuple expression archive elemsS+)
- (Generator (Tuple Synthesis))
- (case elemsS+
- #.Nil
- (///////phase\wrap (//primitive.text /////synthesis.unit))
-
- (#.Cons singletonS #.Nil)
- (expression archive singletonS)
-
- _
- (|> elemsS+
- (monad.map ///////phase.monad (expression archive))
- (///////phase\map _.vector/*))))
-
-(def: #export (variant expression archive [lefts right? valueS])
- (Generator (Variant Synthesis))
- (let [tag (if right?
- (inc lefts)
- lefts)]
- (///////phase\map (|>> [tag right?] //runtime.variant)
- (expression archive valueS))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux
deleted file mode 100644
index 615e7a722..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux
+++ /dev/null
@@ -1,103 +0,0 @@
-(.module:
- [lux (#- primitive)
- [abstract
- ["." monad (#+ do)]]
- [control
- [pipe (#+ case>)]
- ["." try]]
- [data
- ["." maybe]
- [collection
- ["." list ("#\." functor)]
- ["." dictionary (#+ Dictionary)]]]]
- ["." / #_
- ["#." function]
- ["#." case]
- ["#." variable]
- ["/#" // #_
- ["#." extension]
- ["/#" // #_
- ["#." analysis (#+ Analysis)]
- ["/" synthesis (#+ Synthesis Phase)]
- [///
- ["." phase ("#\." monad)]
- [reference (#+)
- [variable (#+)]]]]]])
-
-(def: (primitive analysis)
- (-> ///analysis.Primitive /.Primitive)
- (case analysis
- #///analysis.Unit
- (#/.Text /.unit)
-
- (^template [<analysis> <synthesis>]
- [(<analysis> value)
- (<synthesis> value)])
- ([#///analysis.Bit #/.Bit]
- [#///analysis.Frac #/.F64]
- [#///analysis.Text #/.Text])
-
- (^template [<analysis> <synthesis>]
- [(<analysis> value)
- (<synthesis> (.i64 value))])
- ([#///analysis.Nat #/.I64]
- [#///analysis.Int #/.I64]
- [#///analysis.Rev #/.I64])))
-
-(def: (optimization archive)
- Phase
- (function (optimization' analysis)
- (case analysis
- (#///analysis.Primitive analysis')
- (phase\wrap (#/.Primitive (..primitive analysis')))
-
- (#///analysis.Reference reference)
- (phase\wrap (#/.Reference reference))
-
- (#///analysis.Structure structure)
- (/.with_currying? false
- (case structure
- (#///analysis.Variant variant)
- (do phase.monad
- [valueS (optimization' (get@ #///analysis.value variant))]
- (wrap (/.variant (set@ #///analysis.value valueS variant))))
-
- (#///analysis.Tuple tuple)
- (|> tuple
- (monad.map phase.monad optimization')
- (phase\map (|>> /.tuple)))))
-
- (#///analysis.Case inputA branchesAB+)
- (/.with_currying? false
- (/case.synthesize optimization branchesAB+ archive inputA))
-
- (^ (///analysis.no_op value))
- (optimization' value)
-
- (#///analysis.Apply _)
- (/.with_currying? false
- (/function.apply optimization archive analysis))
-
- (#///analysis.Function environmentA bodyA)
- (/function.abstraction optimization environmentA archive bodyA)
-
- (#///analysis.Extension name args)
- (/.with_currying? false
- (function (_ state)
- (|> (//extension.apply archive optimization [name args])
- (phase.run' state)
- (case> (#try.Success output)
- (#try.Success output)
-
- (#try.Failure _)
- (|> args
- (monad.map phase.monad optimization')
- (phase\map (|>> [name] #/.Extension))
- (phase.run' state))))))
- )))
-
-(def: #export (phase archive analysis)
- Phase
- (do phase.monad
- [synthesis (..optimization archive analysis)]
- (phase.lift (/variable.optimization synthesis))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux
deleted file mode 100644
index 4d847ec2e..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux
+++ /dev/null
@@ -1,429 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- ["." monad (#+ do)]]
- [control
- [pipe (#+ when> new> case>)]]
- [data
- ["." product]
- ["." bit ("#\." equivalence)]
- ["." text ("#\." equivalence)]
- [collection
- ["." list ("#\." functor fold monoid)]
- ["." set (#+ Set)]]]
- [math
- [number
- ["n" nat]
- ["." i64]
- ["." frac ("#\." equivalence)]]]]
- ["." /// #_
- [//
- ["#." analysis (#+ Pattern Match Analysis)]
- ["/" synthesis (#+ Path Synthesis Operation Phase)]
- [///
- ["#" phase ("#\." monad)]
- ["#." reference
- ["#/." variable (#+ Register Variable)]]
- [meta
- [archive (#+ Archive)]]]]])
-
-(def: clean_up
- (-> Path Path)
- (|>> (#/.Seq #/.Pop)))
-
-(def: (path' pattern end? thenC)
- (-> Pattern Bit (Operation Path) (Operation Path))
- (case pattern
- (#///analysis.Simple simple)
- (case simple
- #///analysis.Unit
- thenC
-
- (#///analysis.Bit when)
- (///\map (function (_ then)
- (#/.Bit_Fork when then #.None))
- thenC)
-
- (^template [<from> <to> <conversion>]
- [(<from> test)
- (///\map (function (_ then)
- (<to> [(<conversion> test) then] (list)))
- thenC)])
- ([#///analysis.Nat #/.I64_Fork .i64]
- [#///analysis.Int #/.I64_Fork .i64]
- [#///analysis.Rev #/.I64_Fork .i64]
- [#///analysis.Frac #/.F64_Fork |>]
- [#///analysis.Text #/.Text_Fork |>]))
-
- (#///analysis.Bind register)
- (<| (\ ///.monad map (|>> (#/.Seq (#/.Bind register))))
- /.with_new_local
- thenC)
-
- (#///analysis.Complex (#///analysis.Variant [lefts right? value_pattern]))
- (<| (///\map (|>> (#/.Seq (#/.Access (#/.Side (if right?
- (#.Right lefts)
- (#.Left lefts)))))))
- (path' value_pattern end?)
- (when> [(new> (not end?) [])] [(///\map ..clean_up)])
- thenC)
-
- (#///analysis.Complex (#///analysis.Tuple tuple))
- (let [tuple::last (dec (list.size tuple))]
- (list\fold (function (_ [tuple::lefts tuple::member] nextC)
- (.case tuple::member
- (#///analysis.Simple #///analysis.Unit)
- nextC
-
- _
- (let [right? (n.= tuple::last tuple::lefts)
- end?' (and end? right?)]
- (<| (///\map (|>> (#/.Seq (#/.Access (#/.Member (if right?
- (#.Right (dec tuple::lefts))
- (#.Left tuple::lefts)))))))
- (path' tuple::member end?')
- (when> [(new> (not end?') [])] [(///\map ..clean_up)])
- nextC))))
- thenC
- (list.reverse (list.enumeration tuple))))
- ))
-
-(def: (path archive synthesize pattern bodyA)
- (-> Archive Phase Pattern Analysis (Operation Path))
- (path' pattern true (///\map (|>> #/.Then) (synthesize archive bodyA))))
-
-(def: (weave_branch weave equivalence [new_test new_then] [[old_test old_then] old_tail])
- (All [a] (-> (-> Path Path Path) (Equivalence a) [a Path] (/.Fork a Path)
- (/.Fork a Path)))
- (if (\ equivalence = new_test old_test)
- [[old_test (weave new_then old_then)] old_tail]
- [[old_test old_then]
- (case old_tail
- #.Nil
- (list [new_test new_then])
-
- (#.Cons old_cons)
- (#.Cons (weave_branch weave equivalence [new_test new_then] old_cons)))]))
-
-(def: (weave_fork weave equivalence new_fork old_fork)
- (All [a] (-> (-> Path Path Path) (Equivalence a) (/.Fork a Path) (/.Fork a Path)
- (/.Fork a Path)))
- (list\fold (..weave_branch weave equivalence) old_fork (#.Cons new_fork)))
-
-(def: (weave new old)
- (-> Path Path Path)
- (with_expansions [<default> (as_is (#/.Alt old new))]
- (case [new old]
- [_
- (#/.Alt old_left old_right)]
- (#/.Alt old_left
- (weave new old_right))
-
- [(#/.Seq preN postN)
- (#/.Seq preO postO)]
- (case (weave preN preO)
- (#/.Alt _)
- <default>
-
- woven
- (#/.Seq woven (weave postN postO)))
-
- [#/.Pop #/.Pop]
- old
-
- [(#/.Bit_Fork new_when new_then new_else)
- (#/.Bit_Fork old_when old_then old_else)]
- (if (bit\= new_when old_when)
- (#/.Bit_Fork old_when
- (weave new_then old_then)
- (case [new_else old_else]
- [#.None #.None]
- #.None
-
- (^or [(#.Some woven_then) #.None]
- [#.None (#.Some woven_then)])
- (#.Some woven_then)
-
- [(#.Some new_else) (#.Some old_else)]
- (#.Some (weave new_else old_else))))
- (#/.Bit_Fork old_when
- (case new_else
- #.None
- old_then
-
- (#.Some new_else)
- (weave new_else old_then))
- (#.Some (case old_else
- #.None
- new_then
-
- (#.Some old_else)
- (weave new_then old_else)))))
-
- (^template [<tag> <equivalence>]
- [[(<tag> new_fork) (<tag> old_fork)]
- (<tag> (..weave_fork weave <equivalence> new_fork old_fork))])
- ([#/.I64_Fork i64.equivalence]
- [#/.F64_Fork frac.equivalence]
- [#/.Text_Fork text.equivalence])
-
- (^template [<access> <side>]
- [[(#/.Access (<access> (<side> newL)))
- (#/.Access (<access> (<side> oldL)))]
- (if (n.= newL oldL)
- old
- <default>)])
- ([#/.Side #.Left]
- [#/.Side #.Right]
- [#/.Member #.Left]
- [#/.Member #.Right])
-
- [(#/.Bind newR) (#/.Bind oldR)]
- (if (n.= newR oldR)
- old
- <default>)
-
- _
- <default>)))
-
-(def: (get patterns @selection)
- (-> (///analysis.Tuple ///analysis.Pattern) Register (List /.Member))
- (loop [lefts 0
- patterns patterns]
- (with_expansions [<failure> (as_is (list))
- <continue> (as_is (recur (inc lefts)
- tail))
- <member> (as_is (if (list.empty? tail)
- (#.Right (dec lefts))
- (#.Left lefts)))]
- (case patterns
- #.Nil
- <failure>
-
- (#.Cons head tail)
- (case head
- (#///analysis.Simple #///analysis.Unit)
- <continue>
-
- (#///analysis.Bind register)
- (if (n.= @selection register)
- (list <member>)
- <continue>)
-
- (#///analysis.Complex (#///analysis.Tuple sub_patterns))
- (case (get sub_patterns @selection)
- #.Nil
- <continue>
-
- sub_members
- (list& <member> sub_members))
-
- _
- <failure>)))))
-
-(def: #export (synthesize_case synthesize archive input [[headP headA] tailPA+])
- (-> Phase Archive Synthesis Match (Operation Synthesis))
- (do {! ///.monad}
- [headSP (path archive synthesize headP headA)
- tailSP+ (monad.map ! (product.uncurry (path archive synthesize)) tailPA+)]
- (wrap (/.branch/case [input (list\fold weave headSP tailSP+)]))))
-
-(template: (!masking <variable> <output>)
- [[(#///analysis.Bind <variable>)
- (#///analysis.Reference (///reference.local <output>))]
- (list)])
-
-(def: #export (synthesize_let synthesize archive input @variable body)
- (-> Phase Archive Synthesis Register Analysis (Operation Synthesis))
- (do ///.monad
- [body (/.with_new_local
- (synthesize archive body))]
- (wrap (/.branch/let [input @variable body]))))
-
-(def: #export (synthesize_masking synthesize archive input @variable @output)
- (-> Phase Archive Synthesis Register Register (Operation Synthesis))
- (if (n.= @variable @output)
- (///\wrap input)
- (..synthesize_let synthesize archive input @variable (#///analysis.Reference (///reference.local @output)))))
-
-(def: #export (synthesize_if synthesize archive test then else)
- (-> Phase Archive Synthesis Analysis Analysis (Operation Synthesis))
- (do ///.monad
- [then (synthesize archive then)
- else (synthesize archive else)]
- (wrap (/.branch/if [test then else]))))
-
-(template: (!get <patterns> <output>)
- [[(///analysis.pattern/tuple <patterns>)
- (#///analysis.Reference (///reference.local <output>))]
- (.list)])
-
-(def: #export (synthesize_get synthesize archive input patterns @member)
- (-> Phase Archive Synthesis (///analysis.Tuple ///analysis.Pattern) Register (Operation Synthesis))
- (case (..get patterns @member)
- #.Nil
- (..synthesize_case synthesize archive input (!get patterns @member))
-
- path
- (case input
- (^ (/.branch/get [sub_path sub_input]))
- (///\wrap (/.branch/get [(list\compose path sub_path) sub_input]))
-
- _
- (///\wrap (/.branch/get [path input])))))
-
-(def: #export (synthesize synthesize^ [headB tailB+] archive inputA)
- (-> Phase Match Phase)
- (do {! ///.monad}
- [inputS (synthesize^ archive inputA)]
- (case [headB tailB+]
- (^ (!masking @variable @output))
- (..synthesize_masking synthesize^ archive inputS @variable @output)
-
- [[(#///analysis.Bind @variable) body]
- #.Nil]
- (..synthesize_let synthesize^ archive inputS @variable body)
-
- (^or (^ [[(///analysis.pattern/bit #1) then]
- (list [(///analysis.pattern/bit #0) else])])
- (^ [[(///analysis.pattern/bit #1) then]
- (list [(///analysis.pattern/unit) else])])
-
- (^ [[(///analysis.pattern/bit #0) else]
- (list [(///analysis.pattern/bit #1) then])])
- (^ [[(///analysis.pattern/bit #0) else]
- (list [(///analysis.pattern/unit) then])]))
- (..synthesize_if synthesize^ archive inputS then else)
-
- (^ (!get patterns @member))
- (..synthesize_get synthesize^ archive inputS patterns @member)
-
- match
- (..synthesize_case synthesize^ archive inputS match))))
-
-(def: #export (count_pops path)
- (-> Path [Nat Path])
- (case path
- (^ (/.path/seq #/.Pop path'))
- (let [[pops post_pops] (count_pops path')]
- [(inc pops) post_pops])
-
- _
- [0 path]))
-
-(def: #export pattern_matching_error
- "Invalid expression for pattern-matching.")
-
-(type: #export Storage
- {#bindings (Set Register)
- #dependencies (Set Variable)})
-
-(def: empty
- Storage
- {#bindings (set.new n.hash)
- #dependencies (set.new ///reference/variable.hash)})
-
-## TODO: Use this to declare all local variables at the beginning of
-## script functions.
-## That way, it should be possible to do cheap "let" expressions,
-## since the variable will exist beforehand, so no closure will need
-## to be created for it.
-## Apply this trick to JS, Python et al.
-(def: #export (storage path)
- (-> Path Storage)
- (loop for_path
- [path path
- path_storage ..empty]
- (case path
- (^or #/.Pop (#/.Access Access))
- path_storage
-
- (^ (/.path/bind register))
- (update@ #bindings (set.add register)
- path_storage)
-
- (#/.Bit_Fork _ default otherwise)
- (|> (case otherwise
- #.None
- path_storage
-
- (#.Some otherwise)
- (for_path otherwise path_storage))
- (for_path default))
-
- (^or (#/.I64_Fork forks)
- (#/.F64_Fork forks)
- (#/.Text_Fork forks))
- (|> (#.Cons forks)
- (list\map product.right)
- (list\fold for_path path_storage))
-
- (^or (^ (/.path/seq left right))
- (^ (/.path/alt left right)))
- (list\fold for_path path_storage (list left right))
-
- (^ (/.path/then bodyS))
- (loop for_synthesis
- [bodyS bodyS
- synthesis_storage path_storage]
- (case bodyS
- (^ (/.variant [lefts right? valueS]))
- (for_synthesis valueS synthesis_storage)
-
- (^ (/.tuple members))
- (list\fold for_synthesis synthesis_storage members)
-
- (#/.Reference (#///reference.Variable (#///reference/variable.Local register)))
- (if (set.member? (get@ #bindings synthesis_storage) register)
- synthesis_storage
- (update@ #dependencies (set.add (#///reference/variable.Local register)) synthesis_storage))
-
- (#/.Reference (#///reference.Variable var))
- (update@ #dependencies (set.add var) synthesis_storage)
-
- (^ (/.function/apply [functionS argsS]))
- (list\fold for_synthesis synthesis_storage (#.Cons functionS argsS))
-
- (^ (/.function/abstraction [environment arity bodyS]))
- (list\fold for_synthesis synthesis_storage environment)
-
- (^ (/.branch/case [inputS pathS]))
- (update@ #dependencies
- (set.union (get@ #dependencies (for_path pathS synthesis_storage)))
- (for_synthesis inputS synthesis_storage))
-
- (^ (/.branch/let [inputS register exprS]))
- (update@ #dependencies
- (set.union (|> synthesis_storage
- (update@ #bindings (set.add register))
- (for_synthesis exprS)
- (get@ #dependencies)))
- (for_synthesis inputS synthesis_storage))
-
- (^ (/.branch/if [testS thenS elseS]))
- (list\fold for_synthesis synthesis_storage (list testS thenS elseS))
-
- (^ (/.branch/get [access whole]))
- (for_synthesis whole synthesis_storage)
-
- (^ (/.loop/scope [start initsS+ iterationS]))
- (update@ #dependencies
- (set.union (|> synthesis_storage
- (update@ #bindings (set.union (|> initsS+
- list.enumeration
- (list\map (|>> product.left (n.+ start)))
- (set.from_list n.hash))))
- (for_synthesis iterationS)
- (get@ #dependencies)))
- (list\fold for_synthesis synthesis_storage initsS+))
-
- (^ (/.loop/recur replacementsS+))
- (list\fold for_synthesis synthesis_storage replacementsS+)
-
- (#/.Extension [extension argsS])
- (list\fold for_synthesis synthesis_storage argsS)
-
- _
- synthesis_storage))
- )))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux
deleted file mode 100644
index d3558e9c4..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux
+++ /dev/null
@@ -1,276 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]
- ["." enum]]
- [control
- [pipe (#+ case>)]
- ["." exception (#+ exception:)]]
- [data
- ["." maybe ("#\." functor)]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor monoid fold)]]]
- [math
- [number
- ["n" nat]]]]
- ["." // #_
- ["#." loop (#+ Transform)]
- ["//#" /// #_
- ["#." analysis (#+ Environment Analysis)]
- ["/" synthesis (#+ Path Abstraction Synthesis Operation Phase)]
- [///
- [arity (#+ Arity)]
- ["#." reference
- ["#/." variable (#+ Register Variable)]]
- ["." phase ("#\." monad)]]]])
-
-(exception: #export (cannot_find_foreign_variable_in_environment {foreign Register} {environment (Environment Synthesis)})
- (exception.report
- ["Foreign" (%.nat foreign)]
- ["Environment" (exception.enumerate /.%synthesis environment)]))
-
-(def: arity_arguments
- (-> Arity (List Synthesis))
- (|>> dec
- (enum.range n.enum 1)
- (list\map (|>> /.variable/local))))
-
-(template: #export (self_reference)
- (/.variable/local 0))
-
-(def: (expanded_nested_self_reference arity)
- (-> Arity Synthesis)
- (/.function/apply [(..self_reference) (arity_arguments arity)]))
-
-(def: #export (apply phase)
- (-> Phase Phase)
- (function (_ archive exprA)
- (let [[funcA argsA] (////analysis.application exprA)]
- (do {! phase.monad}
- [funcS (phase archive funcA)
- argsS (monad.map ! (phase archive) argsA)]
- (with_expansions [<apply> (as_is (/.function/apply [funcS argsS]))]
- (case funcS
- (^ (/.function/abstraction functionS))
- (if (n.= (get@ #/.arity functionS)
- (list.size argsS))
- (do !
- [locals /.locals]
- (wrap (|> functionS
- (//loop.optimization true locals argsS)
- (maybe\map (: (-> [Nat (List Synthesis) Synthesis] Synthesis)
- (function (_ [start inits iteration])
- (case iteration
- (^ (/.loop/scope [start' inits' output]))
- (if (and (n.= start start')
- (list.empty? inits'))
- (/.loop/scope [start inits output])
- (/.loop/scope [start inits iteration]))
-
- _
- (/.loop/scope [start inits iteration])))))
- (maybe.default <apply>))))
- (wrap <apply>))
-
- (^ (/.function/apply [funcS' argsS']))
- (wrap (/.function/apply [funcS' (list\compose argsS' argsS)]))
-
- _
- (wrap <apply>)))))))
-
-(def: (find_foreign environment register)
- (-> (Environment Synthesis) Register (Operation Synthesis))
- (case (list.nth register environment)
- (#.Some aliased)
- (phase\wrap aliased)
-
- #.None
- (phase.throw ..cannot_find_foreign_variable_in_environment [register environment])))
-
-(def: (grow_path grow path)
- (-> (-> Synthesis (Operation Synthesis)) Path (Operation Path))
- (case path
- (#/.Bind register)
- (phase\wrap (#/.Bind (inc register)))
-
- (^template [<tag>]
- [(<tag> left right)
- (do phase.monad
- [left' (grow_path grow left)
- right' (grow_path grow right)]
- (wrap (<tag> left' right')))])
- ([#/.Alt] [#/.Seq])
-
- (#/.Bit_Fork when then else)
- (do {! phase.monad}
- [then (grow_path grow then)
- else (case else
- (#.Some else)
- (\ ! map (|>> #.Some) (grow_path grow else))
-
- #.None
- (wrap #.None))]
- (wrap (#/.Bit_Fork when then else)))
-
- (^template [<tag>]
- [(<tag> [[test then] elses])
- (do {! phase.monad}
- [then (grow_path grow then)
- elses (monad.map ! (function (_ [else_test else_then])
- (do !
- [else_then (grow_path grow else_then)]
- (wrap [else_test else_then])))
- elses)]
- (wrap (<tag> [[test then] elses])))])
- ([#/.I64_Fork]
- [#/.F64_Fork]
- [#/.Text_Fork])
-
- (#/.Then thenS)
- (|> thenS
- grow
- (phase\map (|>> #/.Then)))
-
- _
- (phase\wrap path)))
-
-(def: (grow environment expression)
- (-> (Environment Synthesis) Synthesis (Operation Synthesis))
- (case expression
- (#/.Structure structure)
- (case structure
- (#////analysis.Variant [lefts right? subS])
- (|> subS
- (grow environment)
- (phase\map (|>> [lefts right?] /.variant)))
-
- (#////analysis.Tuple membersS+)
- (|> membersS+
- (monad.map phase.monad (grow environment))
- (phase\map (|>> /.tuple))))
-
- (^ (..self_reference))
- (phase\wrap (/.function/apply [expression (list (/.variable/local 1))]))
-
- (#/.Reference reference)
- (case reference
- (#////reference.Variable variable)
- (case variable
- (#////reference/variable.Local register)
- (phase\wrap (/.variable/local (inc register)))
-
- (#////reference/variable.Foreign register)
- (..find_foreign environment register))
-
- (#////reference.Constant constant)
- (phase\wrap expression))
-
- (#/.Control control)
- (case control
- (#/.Branch branch)
- (case branch
- (#/.Let [inputS register bodyS])
- (do phase.monad
- [inputS' (grow environment inputS)
- bodyS' (grow environment bodyS)]
- (wrap (/.branch/let [inputS' (inc register) bodyS'])))
-
- (#/.If [testS thenS elseS])
- (do phase.monad
- [testS' (grow environment testS)
- thenS' (grow environment thenS)
- elseS' (grow environment elseS)]
- (wrap (/.branch/if [testS' thenS' elseS'])))
-
- (#/.Get members inputS)
- (do phase.monad
- [inputS' (grow environment inputS)]
- (wrap (/.branch/get [members inputS'])))
-
- (#/.Case [inputS pathS])
- (do phase.monad
- [inputS' (grow environment inputS)
- pathS' (grow_path (grow environment) pathS)]
- (wrap (/.branch/case [inputS' pathS']))))
-
- (#/.Loop loop)
- (case loop
- (#/.Scope [start initsS+ iterationS])
- (do {! phase.monad}
- [initsS+' (monad.map ! (grow environment) initsS+)
- iterationS' (grow environment iterationS)]
- (wrap (/.loop/scope [(inc start) initsS+' iterationS'])))
-
- (#/.Recur argumentsS+)
- (|> argumentsS+
- (monad.map phase.monad (grow environment))
- (phase\map (|>> /.loop/recur))))
-
- (#/.Function function)
- (case function
- (#/.Abstraction [_env _arity _body])
- (do {! phase.monad}
- [_env' (monad.map !
- (|>> (case> (#/.Reference (#////reference.Variable (#////reference/variable.Foreign register)))
- (..find_foreign environment register)
-
- captured
- (grow environment captured)))
- _env)]
- (wrap (/.function/abstraction [_env' _arity _body])))
-
- (#/.Apply funcS argsS+)
- (do {! phase.monad}
- [funcS (grow environment funcS)
- argsS+ (monad.map ! (grow environment) argsS+)]
- (wrap (/.function/apply (case funcS
- (^ (/.function/apply [(..self_reference) pre_argsS+]))
- [(..self_reference)
- (list\compose pre_argsS+ argsS+)]
-
- _
- [funcS
- argsS+]))))))
-
- (#/.Extension name argumentsS+)
- (|> argumentsS+
- (monad.map phase.monad (grow environment))
- (phase\map (|>> (#/.Extension name))))
-
- (#/.Primitive _)
- (phase\wrap expression)))
-
-(def: #export (abstraction phase environment archive bodyA)
- (-> Phase (Environment Analysis) Phase)
- (do {! phase.monad}
- [currying? /.currying?
- environment (monad.map ! (phase archive) environment)
- bodyS (/.with_currying? true
- (/.with_locals 2
- (phase archive bodyA)))
- abstraction (: (Operation Abstraction)
- (case bodyS
- (^ (/.function/abstraction [env' down_arity' bodyS']))
- (|> bodyS'
- (grow env')
- (\ ! map (function (_ body)
- {#/.environment environment
- #/.arity (inc down_arity')
- #/.body body})))
-
- _
- (wrap {#/.environment environment
- #/.arity 1
- #/.body bodyS})))]
- (wrap (if currying?
- (/.function/abstraction abstraction)
- (case (//loop.optimization false 1 (list) abstraction)
- (#.Some [startL initsL bodyL])
- (/.function/abstraction {#/.environment environment
- #/.arity (get@ #/.arity abstraction)
- #/.body (/.loop/scope [startL initsL bodyL])})
-
- #.None
- (/.function/abstraction abstraction))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux
deleted file mode 100644
index e0fbf816c..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux
+++ /dev/null
@@ -1,186 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." maybe ("#\." monad)]
- [collection
- ["." list]]]
- [math
- [number
- ["n" nat]]]]
- [////
- ["." analysis (#+ Environment)]
- ["/" synthesis (#+ Path Abstraction Synthesis)]
- [///
- [arity (#+ Arity)]
- ["." reference
- ["." variable (#+ Register Variable)]]]])
-
-(type: #export (Transform a)
- (-> a (Maybe a)))
-
-(def: #export (register_optimization offset)
- (-> Register (-> Register Register))
- (|>> dec (n.+ offset)))
-
-(def: (path_optimization body_optimization offset)
- (-> (Transform Synthesis) Register (Transform Path))
- (function (recur path)
- (case path
- (#/.Bind register)
- (#.Some (#/.Bind (register_optimization offset register)))
-
- (^template [<tag>]
- [(<tag> left right)
- (do maybe.monad
- [left' (recur left)
- right' (recur right)]
- (wrap (<tag> left' right')))])
- ([#/.Alt] [#/.Seq])
-
- (#/.Bit_Fork when then else)
- (do {! maybe.monad}
- [then (recur then)
- else (case else
- (#.Some else)
- (\ ! map (|>> #.Some) (recur else))
-
- #.None
- (wrap #.None))]
- (wrap (#/.Bit_Fork when then else)))
-
- (^template [<tag>]
- [(<tag> [[test then] elses])
- (do {! maybe.monad}
- [then (recur then)
- elses (monad.map ! (function (_ [else_test else_then])
- (do !
- [else_then (recur else_then)]
- (wrap [else_test else_then])))
- elses)]
- (wrap (<tag> [[test then] elses])))])
- ([#/.I64_Fork]
- [#/.F64_Fork]
- [#/.Text_Fork])
-
- (#/.Then body)
- (|> body
- body_optimization
- (maybe\map (|>> #/.Then)))
-
- _
- (#.Some path))))
-
-(def: (body_optimization true_loop? offset scope_environment arity expr)
- (-> Bit Register (Environment Synthesis) Arity (Transform Synthesis))
- (loop [return? true
- expr expr]
- (case expr
- (#/.Primitive _)
- (#.Some expr)
-
- (#/.Structure structure)
- (case structure
- (#analysis.Variant variant)
- (do maybe.monad
- [value' (|> variant (get@ #analysis.value) (recur false))]
- (wrap (|> variant
- (set@ #analysis.value value')
- /.variant)))
-
- (#analysis.Tuple tuple)
- (|> tuple
- (monad.map maybe.monad (recur false))
- (maybe\map (|>> /.tuple))))
-
- (#/.Reference reference)
- (case reference
- (^ (#reference.Variable (variable.self)))
- (if true_loop?
- #.None
- (#.Some expr))
-
- (^ (reference.constant constant))
- (#.Some expr)
-
- (^ (reference.local register))
- (#.Some (#/.Reference (reference.local (register_optimization offset register))))
-
- (^ (reference.foreign register))
- (if true_loop?
- (list.nth register scope_environment)
- (#.Some expr)))
-
- (^ (/.branch/case [input path]))
- (do maybe.monad
- [input' (recur false input)
- path' (path_optimization (recur return?) offset path)]
- (wrap (|> path' [input'] /.branch/case)))
-
- (^ (/.branch/let [input register body]))
- (do maybe.monad
- [input' (recur false input)
- body' (recur return? body)]
- (wrap (/.branch/let [input' (register_optimization offset register) body'])))
-
- (^ (/.branch/if [input then else]))
- (do maybe.monad
- [input' (recur false input)
- then' (recur return? then)
- else' (recur return? else)]
- (wrap (/.branch/if [input' then' else'])))
-
- (^ (/.branch/get [path record]))
- (do maybe.monad
- [record (recur false record)]
- (wrap (/.branch/get [path record])))
-
- (^ (/.loop/scope scope))
- (do {! maybe.monad}
- [inits' (|> scope
- (get@ #/.inits)
- (monad.map ! (recur false)))
- iteration' (recur return? (get@ #/.iteration scope))]
- (wrap (/.loop/scope {#/.start (|> scope (get@ #/.start) (register_optimization offset))
- #/.inits inits'
- #/.iteration iteration'})))
-
- (^ (/.loop/recur args))
- (|> args
- (monad.map maybe.monad (recur false))
- (maybe\map (|>> /.loop/recur)))
-
- (^ (/.function/abstraction [environment arity body]))
- (do {! maybe.monad}
- [environment' (monad.map ! (recur false) environment)]
- (wrap (/.function/abstraction [environment' arity body])))
-
- (^ (/.function/apply [abstraction arguments]))
- (do {! maybe.monad}
- [arguments' (monad.map maybe.monad (recur false) arguments)]
- (with_expansions [<application> (as_is (do !
- [abstraction' (recur false abstraction)]
- (wrap (/.function/apply [abstraction' arguments']))))]
- (case abstraction
- (^ (#/.Reference (#reference.Variable (variable.self))))
- (if (and return?
- (n.= arity (list.size arguments)))
- (wrap (/.loop/recur arguments'))
- (if true_loop?
- #.None
- <application>))
-
- _
- <application>)))
-
- (#/.Extension [name args])
- (|> args
- (monad.map maybe.monad (recur false))
- (maybe\map (|>> [name] #/.Extension))))))
-
-(def: #export (optimization true_loop? offset inits functionS)
- (-> Bit Register (List Synthesis) Abstraction (Maybe [Register (List Synthesis) Synthesis]))
- (|> (get@ #/.body functionS)
- (body_optimization true_loop? offset (get@ #/.environment functionS) (get@ #/.arity functionS))
- (maybe\map (|>> [offset inits]))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux
deleted file mode 100644
index 68e12745d..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux
+++ /dev/null
@@ -1,442 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." product]
- ["." maybe ("#\." functor)]
- ["." text
- ["%" format]]
- [collection
- ["." dictionary (#+ Dictionary)]
- ["." list ("#\." functor fold)]
- ["." set]]]
- [math
- [number
- ["n" nat]]]]
- [////
- ["/" synthesis (#+ Path Synthesis)]
- ["." analysis]
- [///
- [arity (#+ Arity)]
- ["." reference
- ["." variable (#+ Register Variable)]]]])
-
-(def: (prune redundant register)
- (-> Register Register Register)
- (if (n.> redundant register)
- (dec register)
- register))
-
-(type: (Remover a)
- (-> Register (-> a a)))
-
-(def: (remove_local_from_path remove_local redundant)
- (-> (Remover Synthesis) (Remover Path))
- (function (recur path)
- (case path
- (#/.Seq (#/.Bind register)
- post)
- (if (n.= redundant register)
- (recur post)
- (#/.Seq (#/.Bind (if (n.> redundant register)
- (dec register)
- register))
- (recur post)))
-
- (^or (#/.Seq (#/.Access (#/.Member member))
- (#/.Seq (#/.Bind register)
- post))
- ## This alternative form should never occur in practice.
- ## Yet, it is "technically" possible to construct it.
- (#/.Seq (#/.Seq (#/.Access (#/.Member member))
- (#/.Bind register))
- post))
- (if (n.= redundant register)
- (recur post)
- (#/.Seq (#/.Access (#/.Member member))
- (#/.Seq (#/.Bind (if (n.> redundant register)
- (dec register)
- register))
- (recur post))))
-
- (^template [<tag>]
- [(<tag> left right)
- (<tag> (recur left) (recur right))])
- ([#/.Seq]
- [#/.Alt])
-
- (#/.Bit_Fork when then else)
- (#/.Bit_Fork when (recur then) (maybe\map recur else))
-
- (^template [<tag>]
- [(<tag> [[test then] tail])
- (<tag> [[test (recur then)]
- (list\map (function (_ [test' then'])
- [test' (recur then')])
- tail)])])
- ([#/.I64_Fork]
- [#/.F64_Fork]
- [#/.Text_Fork])
-
- (^or #/.Pop
- (#/.Access _))
- path
-
- (#/.Bind register)
- (undefined)
-
- (#/.Then then)
- (#/.Then (remove_local redundant then))
- )))
-
-(def: (remove_local_from_variable redundant variable)
- (Remover Variable)
- (case variable
- (#variable.Local register)
- (#variable.Local (..prune redundant register))
-
- (#variable.Foreign register)
- variable))
-
-(def: (remove_local redundant)
- (Remover Synthesis)
- (function (recur synthesis)
- (case synthesis
- (#/.Primitive _)
- synthesis
-
- (#/.Structure structure)
- (#/.Structure (case structure
- (#analysis.Variant [lefts right value])
- (#analysis.Variant [lefts right (recur value)])
-
- (#analysis.Tuple tuple)
- (#analysis.Tuple (list\map recur tuple))))
-
- (#/.Reference reference)
- (case reference
- (#reference.Variable variable)
- (/.variable (..remove_local_from_variable redundant variable))
-
- (#reference.Constant constant)
- synthesis)
-
- (#/.Control control)
- (#/.Control (case control
- (#/.Branch branch)
- (#/.Branch (case branch
- (#/.Let input register output)
- (#/.Let (recur input)
- (..prune redundant register)
- (recur output))
-
- (#/.If test then else)
- (#/.If (recur test) (recur then) (recur else))
-
- (#/.Get path record)
- (#/.Get path (recur record))
-
- (#/.Case input path)
- (#/.Case (recur input) (remove_local_from_path remove_local redundant path))))
-
- (#/.Loop loop)
- (#/.Loop (case loop
- (#/.Scope [start inits iteration])
- (#/.Scope [(..prune redundant start)
- (list\map recur inits)
- (recur iteration)])
-
- (#/.Recur resets)
- (#/.Recur (list\map recur resets))))
-
- (#/.Function function)
- (#/.Function (case function
- (#/.Abstraction [environment arity body])
- (#/.Abstraction [(list\map recur environment)
- arity
- body])
-
- (#/.Apply abstraction inputs)
- (#/.Apply (recur abstraction) (list\map recur inputs))))))
-
- (#/.Extension name inputs)
- (#/.Extension name (list\map recur inputs)))))
-
-(type: Redundancy
- (Dictionary Register Bit))
-
-(def: initial
- Redundancy
- (dictionary.new n.hash))
-
-(def: redundant! true)
-(def: necessary! false)
-
-(def: (extended offset amount redundancy)
- (-> Register Nat Redundancy [(List Register) Redundancy])
- (let [extension (|> amount list.indices (list\map (n.+ offset)))]
- [extension
- (list\fold (function (_ register redundancy)
- (dictionary.put register ..necessary! redundancy))
- redundancy
- extension)]))
-
-(def: (default arity)
- (-> Arity Redundancy)
- (product.right (..extended 0 (inc arity) ..initial)))
-
-(type: (Optimization a)
- (-> [Redundancy a] (Try [Redundancy a])))
-
-(def: (list_optimization optimization)
- (All [a] (-> (Optimization a) (Optimization (List a))))
- (function (recur [redundancy values])
- (case values
- #.Nil
- (#try.Success [redundancy
- values])
-
- (#.Cons head tail)
- (do try.monad
- [[redundancy head] (optimization [redundancy head])
- [redundancy tail] (recur [redundancy tail])]
- (wrap [redundancy
- (#.Cons head tail)])))))
-
-(template [<name>]
- [(exception: #export (<name> {register Register})
- (exception.report
- ["Register" (%.nat register)]))]
-
- [redundant_declaration]
- [unknown_register]
- )
-
-(def: (declare register redundancy)
- (-> Register Redundancy (Try Redundancy))
- (case (dictionary.get register redundancy)
- #.None
- (#try.Success (dictionary.put register ..redundant! redundancy))
-
- (#.Some _)
- (exception.throw ..redundant_declaration [register])))
-
-(def: (observe register redundancy)
- (-> Register Redundancy (Try Redundancy))
- (case (dictionary.get register redundancy)
- #.None
- (exception.throw ..unknown_register [register])
-
- (#.Some _)
- (#try.Success (dictionary.put register ..necessary! redundancy))))
-
-(def: (format redundancy)
- (%.Format Redundancy)
- (|> redundancy
- dictionary.entries
- (list\map (function (_ [register redundant?])
- (%.format (%.nat register) ": " (%.bit redundant?))))
- (text.join_with ", ")))
-
-(def: (path_optimization optimization)
- (-> (Optimization Synthesis) (Optimization Path))
- (function (recur [redundancy path])
- (case path
- (^or #/.Pop
- (#/.Access _))
- (#try.Success [redundancy
- path])
-
- (#/.Bit_Fork when then else)
- (do {! try.monad}
- [[redundancy then] (recur [redundancy then])
- [redundancy else] (case else
- (#.Some else)
- (\ ! map
- (function (_ [redundancy else])
- [redundancy (#.Some else)])
- (recur [redundancy else]))
-
- #.None
- (wrap [redundancy #.None]))]
- (wrap [redundancy (#/.Bit_Fork when then else)]))
-
- (^template [<tag> <type>]
- [(<tag> [[test then] elses])
- (do {! try.monad}
- [[redundancy then] (recur [redundancy then])
- [redundancy elses] (..list_optimization (: (Optimization [<type> Path])
- (function (_ [redundancy [else_test else_then]])
- (do !
- [[redundancy else_then] (recur [redundancy else_then])]
- (wrap [redundancy [else_test else_then]]))))
- [redundancy elses])]
- (wrap [redundancy (<tag> [[test then] elses])]))])
- ([#/.I64_Fork (I64 Any)]
- [#/.F64_Fork Frac]
- [#/.Text_Fork Text])
-
- (#/.Bind register)
- (do try.monad
- [redundancy (..declare register redundancy)]
- (wrap [redundancy
- path]))
-
- (#/.Alt left right)
- (do try.monad
- [[redundancy left] (recur [redundancy left])
- [redundancy right] (recur [redundancy right])]
- (wrap [redundancy (#/.Alt left right)]))
-
- (#/.Seq pre post)
- (do try.monad
- [#let [baseline (|> redundancy
- dictionary.keys
- (set.from_list n.hash))]
- [redundancy pre] (recur [redundancy pre])
- #let [bindings (|> redundancy
- dictionary.keys
- (set.from_list n.hash)
- (set.difference baseline))]
- [redundancy post] (recur [redundancy post])
- #let [redundants (|> redundancy
- dictionary.entries
- (list.filter (function (_ [register redundant?])
- (and (set.member? bindings register)
- redundant?)))
- (list\map product.left))]]
- (wrap [(list\fold dictionary.remove redundancy (set.to_list bindings))
- (|> redundants
- (list.sort n.>)
- (list\fold (..remove_local_from_path ..remove_local) (#/.Seq pre post)))]))
-
- (#/.Then then)
- (do try.monad
- [[redundancy then] (optimization [redundancy then])]
- (wrap [redundancy (#/.Then then)]))
- )))
-
-(def: (optimization' [redundancy synthesis])
- (Optimization Synthesis)
- (with_expansions [<no_op> (as_is (#try.Success [redundancy
- synthesis]))]
- (case synthesis
- (#/.Primitive _)
- <no_op>
-
- (#/.Structure structure)
- (case structure
- (#analysis.Variant [lefts right value])
- (do try.monad
- [[redundancy value] (optimization' [redundancy value])]
- (wrap [redundancy
- (#/.Structure (#analysis.Variant [lefts right value]))]))
-
- (#analysis.Tuple tuple)
- (do try.monad
- [[redundancy tuple] (..list_optimization optimization' [redundancy tuple])]
- (wrap [redundancy
- (#/.Structure (#analysis.Tuple tuple))])))
-
- (#/.Reference reference)
- (case reference
- (#reference.Variable variable)
- (case variable
- (#variable.Local register)
- (do try.monad
- [redundancy (..observe register redundancy)]
- <no_op>)
-
- (#variable.Foreign register)
- <no_op>)
-
- (#reference.Constant constant)
- <no_op>)
-
- (#/.Control control)
- (case control
- (#/.Branch branch)
- (case branch
- (#/.Let input register output)
- (do try.monad
- [[redundancy input] (optimization' [redundancy input])
- redundancy (..declare register redundancy)
- [redundancy output] (optimization' [redundancy output])
- #let [redundant? (|> redundancy
- (dictionary.get register)
- (maybe.default ..necessary!))]]
- (wrap [(dictionary.remove register redundancy)
- (#/.Control (if redundant?
- (#/.Branch (#/.Case input
- (#/.Seq #/.Pop
- (#/.Then (..remove_local register output)))))
- (#/.Branch (#/.Let input register output))))]))
-
- (#/.If test then else)
- (do try.monad
- [[redundancy test] (optimization' [redundancy test])
- [redundancy then] (optimization' [redundancy then])
- [redundancy else] (optimization' [redundancy else])]
- (wrap [redundancy
- (#/.Control (#/.Branch (#/.If test then else)))]))
-
- (#/.Get path record)
- (do try.monad
- [[redundancy record] (optimization' [redundancy record])]
- (wrap [redundancy
- (#/.Control (#/.Branch (#/.Get path record)))]))
-
- (#/.Case input path)
- (do try.monad
- [[redundancy input] (optimization' [redundancy input])
- [redundancy path] (..path_optimization optimization' [redundancy path])]
- (wrap [redundancy
- (#/.Control (#/.Branch (#/.Case input path)))])))
-
- (#/.Loop loop)
- (case loop
- (#/.Scope [start inits iteration])
- (do try.monad
- [[redundancy inits] (..list_optimization optimization' [redundancy inits])
- #let [[extension redundancy] (..extended start (list.size inits) redundancy)]
- [redundancy iteration] (optimization' [redundancy iteration])]
- (wrap [(list\fold dictionary.remove redundancy extension)
- (#/.Control (#/.Loop (#/.Scope [start inits iteration])))]))
-
- (#/.Recur resets)
- (do try.monad
- [[redundancy resets] (..list_optimization optimization' [redundancy resets])]
- (wrap [redundancy
- (#/.Control (#/.Loop (#/.Recur resets)))])))
-
- (#/.Function function)
- (case function
- (#/.Abstraction [environment arity body])
- (do {! try.monad}
- [[redundancy environment] (..list_optimization optimization' [redundancy environment])
- [_ body] (optimization' [(..default arity) body])]
- (wrap [redundancy
- (#/.Control (#/.Function (#/.Abstraction [environment arity body])))]))
-
- (#/.Apply abstraction inputs)
- (do try.monad
- [[redundancy abstraction] (optimization' [redundancy abstraction])
- [redundancy inputs] (..list_optimization optimization' [redundancy inputs])]
- (wrap [redundancy
- (#/.Control (#/.Function (#/.Apply abstraction inputs)))]))))
-
- (#/.Extension name inputs)
- (do try.monad
- [[redundancy inputs] (..list_optimization optimization' [redundancy inputs])]
- (wrap [redundancy
- (#/.Extension name inputs)])))))
-
-(def: #export optimization
- (-> Synthesis (Try Synthesis))
- (|>> [..initial]
- optimization'
- (\ try.monad map product.right)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/program.lux b/stdlib/source/lux/tool/compiler/language/lux/program.lux
deleted file mode 100644
index fc384c178..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/program.lux
+++ /dev/null
@@ -1,56 +0,0 @@
-(.module:
- [lux (#- Module)
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." product]
- ["." maybe]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]]]]
- [//
- [generation (#+ Context)]
- [///
- [meta
- ["." archive (#+ Archive)
- ["." descriptor (#+ Module)]
- ["." artifact]]]]])
-
-(type: #export (Program expression directive)
- (-> Context expression directive))
-
-(def: #export name
- Text
- "")
-
-(exception: #export (cannot-find-program {modules (List Module)})
- (exception.report
- ["Modules" (exception.enumerate %.text modules)]))
-
-(def: #export (context archive)
- (-> Archive (Try Context))
- (do {! try.monad}
- [registries (|> archive
- archive.archived
- (monad.map !
- (function (_ module)
- (do !
- [id (archive.id module archive)
- [descriptor document] (archive.find module archive)]
- (wrap [[module id] (get@ #descriptor.registry descriptor)])))))]
- (case (list.one (function (_ [[module module-id] registry])
- (do maybe.monad
- [program-id (artifact.remember ..name registry)]
- (wrap [module-id program-id])))
- registries)
- (#.Some program-context)
- (wrap program-context)
-
- #.None
- (|> registries
- (list\map (|>> product.left product.left))
- (exception.throw ..cannot-find-program)))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/syntax.lux b/stdlib/source/lux/tool/compiler/language/lux/syntax.lux
deleted file mode 100644
index 00d1497a1..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/syntax.lux
+++ /dev/null
@@ -1,582 +0,0 @@
-## This is LuxC's parser.
-## It takes the source code of a Lux file in raw text form and
-## extracts the syntactic structure of the code from it.
-## It only produces Lux Code nodes, and thus removes any white-space
-## and comments while processing its inputs.
-
-## Another important aspect of the parser is that it keeps track of
-## its position within the input data.
-## That is, the parser takes into account the line and column
-## information in the input text (it doesn't really touch the
-## file-name aspect of the location, leaving it intact in whatever
-## base-line location it is given).
-
-## This particular piece of functionality is not located in one
-## function, but it is instead scattered throughout several parsers,
-## since the logic for how to update the location varies, depending on
-## what is being parsed, and the rules involved.
-
-## You will notice that several parsers have a "where" parameter, that
-## tells them the location position prior to the parser being run.
-## They are supposed to produce some parsed output, alongside an
-## updated location pointing to the end position, after the parser was run.
-
-## Lux Code nodes/tokens are annotated with location meta-data
-## [file-name, line, column] to keep track of their provenance and
-## location, which is helpful for documentation and debugging.
-(.module:
- [lux #*
- ["@" target]
- [abstract
- monad]
- [control
- ["." exception (#+ exception:)]
- [parser
- [text (#+ Offset)]]]
- [data
- ["." maybe]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list]
- ["." dictionary (#+ Dictionary)]]]
- [macro
- ["." template]]
- [math
- [number
- ["n" nat]
- ["." int]
- ["." rev]
- ["." frac]]]])
-
-(template: (inline: <declaration> <type> <body>)
- (for {@.python (def: <declaration> <type> <body>)}
- (template: <declaration> <body>)))
-
-## TODO: Implement "lux syntax char case!" as a custom extension.
-## That way, it should be possible to obtain the char without wrapping
-## it into a java.lang.Long, thereby improving performance.
-
-## TODO: Make an extension to take advantage of java/lang/String::indexOf<int,int>
-## to get better performance than the current "lux text index" extension.
-
-## TODO: Instead of always keeping a "where" location variable, keep the
-## individual components (i.e. file, line and column) separate, so
-## that updated the "where" only involved updating the components, and
-## producing the locations only involved building them, without any need
-## for pattern-matching and de-structuring.
-
-(type: Char
- Nat)
-
-(template [<name> <extension> <diff>]
- [(template: (<name> value)
- (<extension> <diff> value))]
-
- [!inc "lux i64 +" 1]
- [!inc/2 "lux i64 +" 2]
- [!dec "lux i64 -" 1]
- )
-
-(template: (!clip from to text)
- ("lux text clip" from (n.- from to) text))
-
-(template [<name> <extension>]
- [(template: (<name> reference subject)
- (<extension> reference subject))]
-
- [!n/= "lux i64 ="]
- [!i/< "lux i64 <"]
- )
-
-(template [<name> <extension>]
- [(template: (<name> param subject)
- (<extension> param subject))]
-
- [!n/+ "lux i64 +"]
- [!n/- "lux i64 -"]
- )
-
-(type: #export Aliases
- (Dictionary Text Text))
-
-(def: #export no_aliases
- Aliases
- (dictionary.new text.hash))
-
-(def: #export prelude "lux")
-
-(def: #export text_delimiter text.double_quote)
-
-(template [<char> <definition>]
- [(def: #export <definition> <char>)]
-
- ## Form delimiters
- ["(" open_form]
- [")" close_form]
-
- ## Tuple delimiters
- ["[" open_tuple]
- ["]" close_tuple]
-
- ## Record delimiters
- ["{" open_record]
- ["}" close_record]
-
- ["#" sigil]
-
- ["," digit_separator]
-
- ["+" positive_sign]
- ["-" negative_sign]
-
- ["." frac_separator]
-
- ## The parts of a name are separated by a single mark.
- ## E.g. module.short.
- ## Only one such mark may be used in an name, since there
- ## can only be 2 parts to a name (the module [before the
- ## mark], and the short [after the mark]).
- ## There are also some extra rules regarding name syntax,
- ## encoded in the parser.
- ["." name_separator]
- )
-
-(exception: #export (end_of_file {module Text})
- (exception.report
- ["Module" (%.text module)]))
-
-(def: amount_of_input_shown 64)
-
-(inline: (input_at start input)
- (-> Offset Text Text)
- (let [end (|> start (!n/+ amount_of_input_shown) (n.min ("lux text size" input)))]
- (!clip start end input)))
-
-(exception: #export (unrecognized_input {[file line column] Location} {context Text} {input Text} {offset Offset})
- (exception.report
- ["File" file]
- ["Line" (%.nat line)]
- ["Column" (%.nat column)]
- ["Context" (%.text context)]
- ["Input" (input_at offset input)]))
-
-(exception: #export (text_cannot_contain_new_lines {text Text})
- (exception.report
- ["Text" (%.text text)]))
-
-(template: (!failure parser where offset source_code)
- (#.Left [[where offset source_code]
- (exception.construct ..unrecognized_input [where (%.name (name_of parser)) source_code offset])]))
-
-(template: (!end_of_file where offset source_code current_module)
- (#.Left [[where offset source_code]
- (exception.construct ..end_of_file current_module)]))
-
-(type: (Parser a)
- (-> Source (Either [Source Text] [Source a])))
-
-(template: (!with_char+ @source_code_size @source_code @offset @char @else @body)
- (if (!i/< (:as Int @source_code_size)
- (:as Int @offset))
- (let [@char ("lux text char" @offset @source_code)]
- @body)
- @else))
-
-(template: (!with_char @source_code @offset @char @else @body)
- (!with_char+ ("lux text size" @source_code) @source_code @offset @char @else @body))
-
-(template: (!letE <binding> <computation> <body>)
- (case <computation>
- (#.Right <binding>)
- <body>
-
- ## (#.Left error)
- <<otherwise>>
- (:assume <<otherwise>>)))
-
-(template: (!horizontal where offset source_code)
- [(update@ #.column inc where)
- (!inc offset)
- source_code])
-
-(inline: (!new_line where)
- (-> Location Location)
- (let [[where::file where::line where::column] where]
- [where::file (!inc where::line) 0]))
-
-(inline: (!forward length where)
- (-> Nat Location Location)
- (let [[where::file where::line where::column] where]
- [where::file where::line (!n/+ length where::column)]))
-
-(template: (!vertical where offset source_code)
- [(!new_line where)
- (!inc offset)
- source_code])
-
-(template [<name> <close> <tag>]
- [(inline: (<name> parse where offset source_code)
- (-> (Parser Code) Location Offset Text
- (Either [Source Text] [Source Code]))
- (loop [source (: Source [(!forward 1 where) offset source_code])
- stack (: (List Code) #.Nil)]
- (case (parse source)
- (#.Right [source' top])
- (recur source' (#.Cons top stack))
-
- (#.Left [source' error])
- (if (is? <close> error)
- (#.Right [source'
- [where (<tag> (list.reverse stack))]])
- (#.Left [source' error])))))]
-
- ## Form and tuple syntax is mostly the same, differing only in the
- ## delimiters involved.
- ## They may have an arbitrary number of arbitrary Code nodes as elements.
- [parse_form ..close_form #.Form]
- [parse_tuple ..close_tuple #.Tuple]
- )
-
-(inline: (parse_record parse where offset source_code)
- (-> (Parser Code) Location Offset Text
- (Either [Source Text] [Source Code]))
- (loop [source (: Source [(!forward 1 where) offset source_code])
- stack (: (List [Code Code]) #.Nil)]
- (case (parse source)
- (#.Right [sourceF field])
- (!letE [sourceFV value] (parse sourceF)
- (recur sourceFV (#.Cons [field value] stack)))
-
- (#.Left [source' error])
- (if (is? ..close_record error)
- (#.Right [source'
- [where (#.Record (list.reverse stack))]])
- (#.Left [source' error])))))
-
-(template: (!guarantee_no_new_lines where offset source_code content body)
- (case ("lux text index" 0 (static text.new_line) content)
- #.None
- body
-
- g!_
- (#.Left [[where offset source_code]
- (exception.construct ..text_cannot_contain_new_lines content)])))
-
-(def: (parse_text where offset source_code)
- (-> Location Offset Text (Either [Source Text] [Source Code]))
- (case ("lux text index" offset (static ..text_delimiter) source_code)
- (#.Some g!end)
- (<| (let [g!content (!clip offset g!end source_code)])
- (!guarantee_no_new_lines where offset source_code g!content)
- (#.Right [[(let [size (!n/- offset g!end)]
- (update@ #.column (|>> (!n/+ size) (!n/+ 2)) where))
- (!inc g!end)
- source_code]
- [where
- (#.Text g!content)]]))
-
- _
- (!failure ..parse_text where offset source_code)))
-
-(with_expansions [<digits> (as_is "0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
- <non_name_chars> (template [<char>]
- [(~~ (static <char>))]
-
- [text.space]
- [text.new_line] [text.carriage_return]
- [..name_separator]
- [..open_form] [..close_form]
- [..open_tuple] [..close_tuple]
- [..open_record] [..close_record]
- [..text_delimiter]
- [..sigil])
- <digit_separator> (static ..digit_separator)]
- (template: (!if_digit? @char @then @else)
- ("lux syntax char case!" @char
- [[<digits>]
- @then]
-
- ## else
- @else))
-
- (template: (!if_digit?+ @char @then @else_options @else)
- (`` ("lux syntax char case!" @char
- [[<digits> <digit_separator>]
- @then
-
- (~~ (template.splice @else_options))]
-
- ## else
- @else)))
-
- (`` (template: (!if_name_char?|tail @char @then @else)
- ("lux syntax char case!" @char
- [[<non_name_chars>]
- @else]
-
- ## else
- @then)))
-
- (`` (template: (!if_name_char?|head @char @then @else)
- ("lux syntax char case!" @char
- [[<non_name_chars> <digits>]
- @else]
-
- ## else
- @then)))
- )
-
-(template: (!number_output <source_code> <start> <end> <codec> <tag>)
- (case (|> <source_code>
- (!clip <start> <end>)
- (text.replace_all ..digit_separator "")
- (\ <codec> decode))
- (#.Right output)
- (#.Right [[(let [[where::file where::line where::column] where]
- [where::file where::line (!n/+ (!n/- <start> <end>) where::column)])
- <end>
- <source_code>]
- [where (<tag> output)]])
-
- (#.Left error)
- (#.Left [[where <start> <source_code>]
- error])))
-
-(def: no_exponent Offset 0)
-
-(with_expansions [<int_output> (as_is (!number_output source_code start end int.decimal #.Int))
- <frac_output> (as_is (!number_output source_code start end frac.decimal #.Frac))
- <failure> (!failure ..parse_frac where offset source_code)
- <frac_separator> (static ..frac_separator)
- <signs> (template [<sign>]
- [(~~ (static <sign>))]
-
- [..positive_sign]
- [..negative_sign])]
- (inline: (parse_frac source_code//size start where offset source_code)
- (-> Nat Nat Location Offset Text
- (Either [Source Text] [Source Code]))
- (loop [end offset
- exponent (static ..no_exponent)]
- (<| (!with_char+ source_code//size source_code end char/0 <frac_output>)
- (!if_digit?+ char/0
- (recur (!inc end) exponent)
-
- [["e" "E"]
- (if (is? (static ..no_exponent) exponent)
- (<| (!with_char+ source_code//size source_code (!inc end) char/1 <failure>)
- (`` ("lux syntax char case!" char/1
- [[<signs>]
- (<| (!with_char+ source_code//size source_code (!n/+ 2 end) char/2 <failure>)
- (!if_digit?+ char/2
- (recur (!n/+ 3 end) char/0)
- []
- <failure>))]
- ## else
- <failure>)))
- <frac_output>)]
-
- <frac_output>))))
-
- (inline: (parse_signed source_code//size start where offset source_code)
- (-> Nat Nat Location Offset Text
- (Either [Source Text] [Source Code]))
- (loop [end offset]
- (<| (!with_char+ source_code//size source_code end char <int_output>)
- (!if_digit?+ char
- (recur (!inc end))
-
- [[<frac_separator>]
- (parse_frac source_code//size start where (!inc end) source_code)]
-
- <int_output>))))
- )
-
-(template [<parser> <codec> <tag>]
- [(inline: (<parser> source_code//size start where offset source_code)
- (-> Nat Nat Location Offset Text
- (Either [Source Text] [Source Code]))
- (loop [g!end offset]
- (<| (!with_char+ source_code//size source_code g!end g!char (!number_output source_code start g!end <codec> <tag>))
- (!if_digit?+ g!char
- (recur (!inc g!end))
- []
- (!number_output source_code start g!end <codec> <tag>)))))]
-
- [parse_nat n.decimal #.Nat]
- [parse_rev rev.decimal #.Rev]
- )
-
-(template: (!parse_signed source_code//size offset where source_code @aliases @end)
- (<| (let [g!offset/1 (!inc offset)])
- (!with_char+ source_code//size source_code g!offset/1 g!char/1 @end)
- (!if_digit? g!char/1
- (parse_signed source_code//size offset where (!inc/2 offset) source_code)
- (!parse_full_name offset [where (!inc offset) source_code] where @aliases #.Identifier))))
-
-(with_expansions [<output> (#.Right [[(update@ #.column (|>> (!n/+ (!n/- start end))) where)
- end
- source_code]
- (!clip start end source_code)])]
- (inline: (parse_name_part start where offset source_code)
- (-> Nat Location Offset Text
- (Either [Source Text] [Source Text]))
- (let [source_code//size ("lux text size" source_code)]
- (loop [end offset]
- (<| (!with_char+ source_code//size source_code end char <output>)
- (!if_name_char?|tail char
- (recur (!inc end))
- <output>))))))
-
-(template: (!parse_half_name @offset @char @module)
- (!if_name_char?|head @char
- (!letE [source' name] (..parse_name_part @offset where (!inc @offset) source_code)
- (#.Right [source' [@module name]]))
- (!failure ..!parse_half_name where @offset source_code)))
-
-(`` (def: (parse_short_name source_code//size current_module [where offset/0 source_code])
- (-> Nat Text (Parser Name))
- (<| (!with_char+ source_code//size source_code offset/0 char/0
- (!end_of_file where offset/0 source_code current_module))
- (if (!n/= (char (~~ (static ..name_separator))) char/0)
- (<| (let [offset/1 (!inc offset/0)])
- (!with_char+ source_code//size source_code offset/1 char/1
- (!end_of_file where offset/1 source_code current_module))
- (!parse_half_name offset/1 char/1 current_module))
- (!parse_half_name offset/0 char/0 (static ..prelude))))))
-
-(template: (!parse_short_name source_code//size @current_module @source @where @tag)
- (!letE [source' name] (..parse_short_name source_code//size @current_module @source)
- (#.Right [source' [@where (@tag name)]])))
-
-(with_expansions [<simple> (as_is (#.Right [source' ["" simple]]))]
- (`` (def: (parse_full_name aliases start source)
- (-> Aliases Offset (Parser Name))
- (<| (!letE [source' simple] (let [[where offset source_code] source]
- (..parse_name_part start where offset source_code)))
- (let [[where' offset' source_code'] source'])
- (!with_char source_code' offset' char/separator <simple>)
- (if (!n/= (char (~~ (static ..name_separator))) char/separator)
- (<| (let [offset'' (!inc offset')])
- (!letE [source'' complex] (..parse_name_part offset'' (!forward 1 where') offset'' source_code'))
- (if ("lux text =" "" complex)
- (let [[where offset source_code] source]
- (!failure ..parse_full_name where offset source_code))
- (#.Right [source'' [(|> aliases
- (dictionary.get simple)
- (maybe.default simple))
- complex]])))
- <simple>)))))
-
-(template: (!parse_full_name @offset @source @where @aliases @tag)
- (!letE [source' full_name] (..parse_full_name @aliases @offset @source)
- (#.Right [source' [@where (@tag full_name)]])))
-
-## TODO: Grammar macro for specifying syntax.
-## (grammar: lux_grammar
-## [expression ...]
-## [form "(" [#* expression] ")"])
-
-(with_expansions [<consume_1> (as_is where (!inc offset/0) source_code)
- <move_1> (as_is [(!forward 1 where) (!inc offset/0) source_code])
- <move_2> (as_is [(!forward 1 where) (!inc/2 offset/0) source_code])
- <recur> (as_is (parse current_module aliases source_code//size))
- <horizontal_move> (as_is (recur (!horizontal where offset/0 source_code)))]
-
- (template: (!close closer)
- (#.Left [<move_1> closer]))
-
- (def: #export (parse current_module aliases source_code//size)
- (-> Text Aliases Nat (Parser Code))
- ## The "exec []" is only there to avoid function fusion.
- ## This is to preserve the loop as much as possible and keep it tight.
- (exec []
- (function (recur [where offset/0 source_code])
- (<| (!with_char+ source_code//size source_code offset/0 char/0
- (!end_of_file where offset/0 source_code current_module))
- (with_expansions [<composites> (template [<open> <close> <parser>]
- [[(~~ (static <open>))]
- (<parser> <recur> <consume_1>)
-
- [(~~ (static <close>))]
- (!close <close>)]
-
- [..open_form ..close_form parse_form]
- [..open_tuple ..close_tuple parse_tuple]
- [..open_record ..close_record parse_record]
- )]
- (`` ("lux syntax char case!" char/0
- [[(~~ (static text.space))
- (~~ (static text.carriage_return))]
- <horizontal_move>
-
- ## New line
- [(~~ (static text.new_line))]
- (recur (!vertical where offset/0 source_code))
-
- <composites>
-
- ## Text
- [(~~ (static ..text_delimiter))]
- (parse_text where (!inc offset/0) source_code)
-
- ## Special code
- [(~~ (static ..sigil))]
- (<| (let [offset/1 (!inc offset/0)])
- (!with_char+ source_code//size source_code offset/1 char/1
- (!end_of_file where offset/1 source_code current_module))
- ("lux syntax char case!" char/1
- [[(~~ (static ..name_separator))]
- (!parse_short_name source_code//size current_module <move_2> where #.Tag)
-
- ## Single_line comment
- [(~~ (static ..sigil))]
- (case ("lux text index" (!inc offset/1) (static text.new_line) source_code)
- (#.Some end)
- (recur (!vertical where end source_code))
-
- _
- (!end_of_file where offset/1 source_code current_module))
-
- (~~ (template [<char> <bit>]
- [[<char>]
- (#.Right [[(update@ #.column (|>> !inc/2) where)
- (!inc offset/1)
- source_code]
- [where (#.Bit <bit>)]])]
-
- ["0" #0]
- ["1" #1]))]
-
- ## else
- (!if_name_char?|head char/1
- ## Tag
- (!parse_full_name offset/1 <move_2> where aliases #.Tag)
- (!failure ..parse where offset/0 source_code))))
-
- ## Coincidentally (= ..name_separator ..frac_separator)
- [(~~ (static ..name_separator))
- ## (~~ (static ..frac_separator))
- ]
- (<| (let [offset/1 (!inc offset/0)])
- (!with_char+ source_code//size source_code offset/1 char/1
- (!end_of_file where offset/1 source_code current_module))
- (!if_digit? char/1
- (parse_rev source_code//size offset/0 where (!inc offset/1) source_code)
- (!parse_short_name source_code//size current_module [where offset/1 source_code] where #.Identifier)))
-
- [(~~ (static ..positive_sign))
- (~~ (static ..negative_sign))]
- (!parse_signed source_code//size offset/0 where source_code aliases
- (!end_of_file where offset/0 source_code current_module))]
-
- ## else
- (!if_digit? char/0
- ## Natural number
- (parse_nat source_code//size offset/0 where (!inc offset/0) source_code)
- ## Identifier
- (!parse_full_name offset/0 [<consume_1>] where aliases #.Identifier))
- )))
- )))
- ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux
deleted file mode 100644
index 0b2086f25..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux
+++ /dev/null
@@ -1,808 +0,0 @@
-(.module:
- [lux (#- i64 Scope)
- [abstract
- [monad (#+ do)]
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]]
- [control
- [pipe (#+ case>)]
- ["." exception (#+ exception:)]]
- [data
- ["." sum]
- ["." product]
- ["." maybe]
- ["." bit ("#\." equivalence)]
- ["." text ("#\." equivalence)
- ["%" format (#+ Format format)]]
- [collection
- ["." list ("#\." functor)]
- ["." dictionary (#+ Dictionary)]]]
- [math
- [number
- ["." i64]
- ["n" nat]
- ["i" int]
- ["f" frac]]]]
- [//
- ["." analysis (#+ Environment Composite Analysis)]
- [phase
- ["." extension (#+ Extension)]]
- [///
- [arity (#+ Arity)]
- ["." phase]
- ["." reference (#+ Reference)
- ["." variable (#+ Register Variable)]]]])
-
-(type: #export Resolver
- (Dictionary Variable Variable))
-
-(type: #export State
- {#locals Nat
- ## https://en.wikipedia.org/wiki/Currying
- #currying? Bit})
-
-(def: #export fresh_resolver
- Resolver
- (dictionary.new variable.hash))
-
-(def: #export init
- State
- {#locals 0
- #currying? false})
-
-(type: #export Primitive
- (#Bit Bit)
- (#I64 (I64 Any))
- (#F64 Frac)
- (#Text Text))
-
-(type: #export Side
- (Either Nat Nat))
-
-(type: #export Member
- (Either Nat Nat))
-
-(type: #export Access
- (#Side Side)
- (#Member Member))
-
-(type: #export (Fork value next)
- [[value next] (List [value next])])
-
-(type: #export (Path' s)
- #Pop
- (#Access Access)
- (#Bind Register)
- (#Bit_Fork Bit (Path' s) (Maybe (Path' s)))
- (#I64_Fork (Fork (I64 Any) (Path' s)))
- (#F64_Fork (Fork Frac (Path' s)))
- (#Text_Fork (Fork Text (Path' s)))
- (#Alt (Path' s) (Path' s))
- (#Seq (Path' s) (Path' s))
- (#Then s))
-
-(type: #export (Abstraction' s)
- {#environment (Environment s)
- #arity Arity
- #body s})
-
-(type: #export (Apply' s)
- {#function s
- #arguments (List s)})
-
-(type: #export (Branch s)
- (#Let s Register s)
- (#If s s s)
- (#Get (List Member) s)
- (#Case s (Path' s)))
-
-(type: #export (Scope s)
- {#start Register
- #inits (List s)
- #iteration s})
-
-(type: #export (Loop s)
- (#Scope (Scope s))
- (#Recur (List s)))
-
-(type: #export (Function s)
- (#Abstraction (Abstraction' s))
- (#Apply s (List s)))
-
-(type: #export (Control s)
- (#Branch (Branch s))
- (#Loop (Loop s))
- (#Function (Function s)))
-
-(type: #export #rec Synthesis
- (#Primitive Primitive)
- (#Structure (Composite Synthesis))
- (#Reference Reference)
- (#Control (Control Synthesis))
- (#Extension (Extension Synthesis)))
-
-(template [<special> <general>]
- [(type: #export <special>
- (<general> ..State Analysis Synthesis))]
-
- [State+ extension.State]
- [Operation extension.Operation]
- [Phase extension.Phase]
- [Handler extension.Handler]
- [Bundle extension.Bundle]
- )
-
-(type: #export Path
- (Path' Synthesis))
-
-(def: #export path/pop
- Path
- #Pop)
-
-(template [<name> <kind>]
- [(template: #export (<name> content)
- (.<| #..Access
- <kind>
- content))]
-
- [path/side #..Side]
- [path/member #..Member]
- )
-
-(template [<name> <kind> <side>]
- [(template: #export (<name> content)
- (.<| #..Access
- <kind>
- <side>
- content))]
-
- [side/left #..Side #.Left]
- [side/right #..Side #.Right]
- [member/left #..Member #.Left]
- [member/right #..Member #.Right]
- )
-
-(template [<name> <tag>]
- [(template: #export (<name> content)
- (<tag> content))]
-
- [path/bind #..Bind]
- [path/then #..Then]
- )
-
-(template [<name> <tag>]
- [(template: #export (<name> left right)
- (<tag> [left right]))]
-
- [path/alt #..Alt]
- [path/seq #..Seq]
- )
-
-(type: #export Abstraction
- (Abstraction' Synthesis))
-
-(type: #export Apply
- (Apply' Synthesis))
-
-(def: #export unit Text "")
-
-(template [<with> <query> <tag> <type>]
- [(def: #export (<with> value)
- (-> <type> (All [a] (-> (Operation a) (Operation a))))
- (extension.temporary (set@ <tag> value)))
-
- (def: #export <query>
- (Operation <type>)
- (extension.read (get@ <tag>)))]
-
- [with_locals locals #locals Nat]
- [with_currying? currying? #currying? Bit]
- )
-
-(def: #export with_new_local
- (All [a] (-> (Operation a) (Operation a)))
- (<<| (do phase.monad
- [locals ..locals])
- (..with_locals (inc locals))))
-
-(template [<name> <tag>]
- [(template: #export (<name> content)
- (#..Primitive (<tag> content)))]
-
- [bit #..Bit]
- [i64 #..I64]
- [f64 #..F64]
- [text #..Text]
- )
-
-(template [<name> <tag>]
- [(template: #export (<name> content)
- (<| #..Structure
- <tag>
- content))]
-
- [variant #analysis.Variant]
- [tuple #analysis.Tuple]
- )
-
-(template [<name> <tag>]
- [(template: #export (<name> content)
- (.<| #..Reference
- <tag>
- content))]
-
- [variable reference.variable]
- [constant reference.constant]
- [variable/local reference.local]
- [variable/foreign reference.foreign]
- )
-
-(template [<name> <family> <tag>]
- [(template: #export (<name> content)
- (.<| #..Control
- <family>
- <tag>
- content))]
-
- [branch/case #..Branch #..Case]
- [branch/let #..Branch #..Let]
- [branch/if #..Branch #..If]
- [branch/get #..Branch #..Get]
-
- [loop/recur #..Loop #..Recur]
- [loop/scope #..Loop #..Scope]
-
- [function/abstraction #..Function #..Abstraction]
- [function/apply #..Function #..Apply]
- )
-
-(def: #export (%path' %then value)
- (All [a] (-> (Format a) (Format (Path' a))))
- (case value
- #Pop
- "_"
-
- (#Bit_Fork when then else)
- (format "(?"
- " " (%.bit when) " " (%path' %then then)
- (case else
- (#.Some else)
- (format " " (%.bit (not when)) " " (%path' %then else))
-
- #.None
- "")
- ")")
-
- (^template [<tag> <format>]
- [(<tag> cons)
- (|> (#.Cons cons)
- (list\map (function (_ [test then])
- (format (<format> test) " " (%path' %then then))))
- (text.join_with " ")
- (text.enclose ["(? " ")"]))])
- ([#I64_Fork (|>> .int %.int)]
- [#F64_Fork %.frac]
- [#Text_Fork %.text])
-
- (#Access access)
- (case access
- (#Side side)
- (case side
- (#.Left lefts)
- (format "(" (%.nat lefts) " #0" ")")
-
- (#.Right lefts)
- (format "(" (%.nat lefts) " #1" ")"))
-
- (#Member member)
- (case member
- (#.Left lefts)
- (format "[" (%.nat lefts) " #0" "]")
-
- (#.Right lefts)
- (format "[" (%.nat lefts) " #1" "]")))
-
- (#Bind register)
- (format "(@ " (%.nat register) ")")
-
- (#Alt left right)
- (format "(| " (%path' %then left) " " (%path' %then right) ")")
-
- (#Seq left right)
- (format "(& " (%path' %then left) " " (%path' %then right) ")")
-
- (#Then then)
- (|> (%then then)
- (text.enclose ["(! " ")"]))))
-
-(def: #export (%synthesis value)
- (Format Synthesis)
- (case value
- (#Primitive primitive)
- (case primitive
- (^template [<pattern> <format>]
- [(<pattern> value)
- (<format> value)])
- ([#Bit %.bit]
- [#F64 %.frac]
- [#Text %.text])
-
- (#I64 value)
- (%.int (.int value)))
-
- (#Structure structure)
- (case structure
- (#analysis.Variant [lefts right? content])
- (|> (%synthesis content)
- (format (%.nat lefts) " " (%.bit right?) " ")
- (text.enclose ["(" ")"]))
-
- (#analysis.Tuple members)
- (|> members
- (list\map %synthesis)
- (text.join_with " ")
- (text.enclose ["[" "]"])))
-
- (#Reference reference)
- (reference.format reference)
-
- (#Control control)
- (case control
- (#Function function)
- (case function
- (#Abstraction [environment arity body])
- (let [environment' (|> environment
- (list\map %synthesis)
- (text.join_with " ")
- (text.enclose ["[" "]"]))]
- (|> (format environment' " " (%.nat arity) " " (%synthesis body))
- (text.enclose ["(#function " ")"])))
-
- (#Apply func args)
- (|> args
- (list\map %synthesis)
- (text.join_with " ")
- (format (%synthesis func) " ")
- (text.enclose ["(" ")"])))
-
- (#Branch branch)
- (case branch
- (#Let input register body)
- (|> (format (%.nat register) " " (%synthesis input) " " (%synthesis body))
- (text.enclose ["(#let " ")"]))
-
- (#If test then else)
- (|> (format (%synthesis test) " " (%synthesis then) " " (%synthesis else))
- (text.enclose ["(#if " ")"]))
-
- (#Get members record)
- (|> (format (%.list (%path' %synthesis)
- (list\map (|>> #Member #Access) members))
- " " (%synthesis record))
- (text.enclose ["(#get " ")"]))
-
- (#Case input path)
- (|> (format (%synthesis input) " " (%path' %synthesis path))
- (text.enclose ["(#case " ")"])))
-
- (#Loop loop)
- (case loop
- (#Scope scope)
- (|> (format (%.nat (get@ #start scope))
- " " (|> (get@ #inits scope)
- (list\map %synthesis)
- (text.join_with " ")
- (text.enclose ["[" "]"]))
- " " (%synthesis (get@ #iteration scope)))
- (text.enclose ["(#loop " ")"]))
-
- (#Recur args)
- (|> args
- (list\map %synthesis)
- (text.join_with " ")
- (text.enclose ["(#recur " ")"]))))
-
- (#Extension [name args])
- (|> (list\map %synthesis args)
- (text.join_with " ")
- (format (%.text name) " ")
- (text.enclose ["(" ")"]))))
-
-(def: #export %path
- (Format Path)
- (%path' %synthesis))
-
-(implementation: #export primitive_equivalence
- (Equivalence Primitive)
-
- (def: (= reference sample)
- (case [reference sample]
- (^template [<tag> <eq> <format>]
- [[(<tag> reference') (<tag> sample')]
- (<eq> reference' sample')])
- ([#Bit bit\= %.bit]
- [#F64 f.= %.frac]
- [#Text text\= %.text])
-
- [(#I64 reference') (#I64 sample')]
- (i.= (.int reference') (.int sample'))
-
- _
- false)))
-
-(implementation: primitive_hash
- (Hash Primitive)
-
- (def: &equivalence ..primitive_equivalence)
-
- (def: hash
- (|>> (case> (^template [<tag> <hash>]
- [(<tag> value')
- (\ <hash> hash value')])
- ([#Bit bit.hash]
- [#F64 f.hash]
- [#Text text.hash]
- [#I64 i64.hash])))))
-
-(def: side_equivalence
- (Equivalence Side)
- (sum.equivalence n.equivalence n.equivalence))
-
-(def: member_equivalence
- (Equivalence Member)
- (sum.equivalence n.equivalence n.equivalence))
-
-(def: member_hash
- (Hash Member)
- (sum.hash n.hash n.hash))
-
-(implementation: #export access_equivalence
- (Equivalence Access)
-
- (def: (= reference sample)
- (case [reference sample]
- (^template [<tag> <equivalence>]
- [[(<tag> reference) (<tag> sample)]
- (\ <equivalence> = reference sample)])
- ([#Side ..side_equivalence]
- [#Member ..member_equivalence])
-
- _
- false)))
-
-(implementation: access_hash
- (Hash Access)
-
- (def: &equivalence ..access_equivalence)
-
- (def: (hash value)
- (let [sub_hash (sum.hash n.hash n.hash)]
- (case value
- (^template [<tag>]
- [(<tag> value)
- (\ sub_hash hash value)])
- ([#Side]
- [#Member])))))
-
-(implementation: #export (path'_equivalence equivalence)
- (All [a] (-> (Equivalence a) (Equivalence (Path' a))))
-
- (def: (= reference sample)
- (case [reference sample]
- [#Pop #Pop]
- true
-
- [(#Bit_Fork reference_when reference_then reference_else)
- (#Bit_Fork sample_when sample_then sample_else)]
- (and (bit\= reference_when sample_when)
- (= reference_then sample_then)
- (\ (maybe.equivalence =) = reference_else sample_else))
-
- (^template [<tag> <equivalence>]
- [[(<tag> reference_cons)
- (<tag> sample_cons)]
- (\ (list.equivalence (product.equivalence <equivalence> =)) =
- (#.Cons reference_cons)
- (#.Cons sample_cons))])
- ([#I64_Fork i64.equivalence]
- [#F64_Fork f.equivalence]
- [#Text_Fork text.equivalence])
-
- (^template [<tag> <equivalence>]
- [[(<tag> reference') (<tag> sample')]
- (\ <equivalence> = reference' sample')])
- ([#Access ..access_equivalence]
- [#Then equivalence])
-
- [(#Bind reference') (#Bind sample')]
- (n.= reference' sample')
-
- (^template [<tag>]
- [[(<tag> leftR rightR) (<tag> leftS rightS)]
- (and (= leftR leftS)
- (= rightR rightS))])
- ([#Alt]
- [#Seq])
-
- _
- false)))
-
-(implementation: (path'_hash super)
- (All [a] (-> (Hash a) (Hash (Path' a))))
-
- (def: &equivalence
- (..path'_equivalence (\ super &equivalence)))
-
- (def: (hash value)
- (case value
- #Pop
- 2
-
- (#Access access)
- (n.* 3 (\ ..access_hash hash access))
-
- (#Bind register)
- (n.* 5 (\ n.hash hash register))
-
- (#Bit_Fork when then else)
- ($_ n.* 7
- (\ bit.hash hash when)
- (hash then)
- (\ (maybe.hash (path'_hash super)) hash else))
-
- (^template [<factor> <tag> <hash>]
- [(<tag> cons)
- (let [case_hash (product.hash <hash>
- (path'_hash super))
- cons_hash (product.hash case_hash (list.hash case_hash))]
- (n.* <factor> (\ cons_hash hash cons)))])
- ([11 #I64_Fork i64.hash]
- [13 #F64_Fork f.hash]
- [17 #Text_Fork text.hash])
-
- (^template [<factor> <tag>]
- [(<tag> fork)
- (let [recur_hash (path'_hash super)
- fork_hash (product.hash recur_hash recur_hash)]
- (n.* <factor> (\ fork_hash hash fork)))])
- ([19 #Alt]
- [23 #Seq])
-
- (#Then body)
- (n.* 29 (\ super hash body))
- )))
-
-(implementation: (branch_equivalence (^open "\."))
- (All [a] (-> (Equivalence a) (Equivalence (Branch a))))
-
- (def: (= reference sample)
- (case [reference sample]
- [(#Let [reference_input reference_register reference_body])
- (#Let [sample_input sample_register sample_body])]
- (and (\= reference_input sample_input)
- (n.= reference_register sample_register)
- (\= reference_body sample_body))
-
- [(#If [reference_test reference_then reference_else])
- (#If [sample_test sample_then sample_else])]
- (and (\= reference_test sample_test)
- (\= reference_then sample_then)
- (\= reference_else sample_else))
-
- [(#Get [reference_path reference_record])
- (#Get [sample_path sample_record])]
- (and (\ (list.equivalence ..member_equivalence) = reference_path sample_path)
- (\= reference_record sample_record))
-
- [(#Case [reference_input reference_path])
- (#Case [sample_input sample_path])]
- (and (\= reference_input sample_input)
- (\ (path'_equivalence \=) = reference_path sample_path))
-
- _
- false)))
-
-(implementation: (branch_hash super)
- (All [a] (-> (Hash a) (Hash (Branch a))))
-
- (def: &equivalence
- (..branch_equivalence (\ super &equivalence)))
-
- (def: (hash value)
- (case value
- (#Let [input register body])
- ($_ n.* 2
- (\ super hash input)
- (\ n.hash hash register)
- (\ super hash body))
-
- (#If [test then else])
- ($_ n.* 3
- (\ super hash test)
- (\ super hash then)
- (\ super hash else))
-
- (#Get [path record])
- ($_ n.* 5
- (\ (list.hash ..member_hash) hash path)
- (\ super hash record))
-
- (#Case [input path])
- ($_ n.* 7
- (\ super hash input)
- (\ (..path'_hash super) hash path))
- )))
-
-(implementation: (loop_equivalence (^open "\."))
- (All [a] (-> (Equivalence a) (Equivalence (Loop a))))
-
- (def: (= reference sample)
- (case [reference sample]
- [(#Scope [reference_start reference_inits reference_iteration])
- (#Scope [sample_start sample_inits sample_iteration])]
- (and (n.= reference_start sample_start)
- (\ (list.equivalence \=) = reference_inits sample_inits)
- (\= reference_iteration sample_iteration))
-
- [(#Recur reference) (#Recur sample)]
- (\ (list.equivalence \=) = reference sample)
-
- _
- false)))
-
-(implementation: (loop_hash super)
- (All [a] (-> (Hash a) (Hash (Loop a))))
-
- (def: &equivalence
- (..loop_equivalence (\ super &equivalence)))
-
- (def: (hash value)
- (case value
- (#Scope [start inits iteration])
- ($_ n.* 2
- (\ n.hash hash start)
- (\ (list.hash super) hash inits)
- (\ super hash iteration))
-
- (#Recur resets)
- ($_ n.* 3
- (\ (list.hash super) hash resets))
- )))
-
-(implementation: (function_equivalence (^open "\."))
- (All [a] (-> (Equivalence a) (Equivalence (Function a))))
-
- (def: (= reference sample)
- (case [reference sample]
- [(#Abstraction [reference_environment reference_arity reference_body])
- (#Abstraction [sample_environment sample_arity sample_body])]
- (and (\ (list.equivalence \=) = reference_environment sample_environment)
- (n.= reference_arity sample_arity)
- (\= reference_body sample_body))
-
- [(#Apply [reference_abstraction reference_arguments])
- (#Apply [sample_abstraction sample_arguments])]
- (and (\= reference_abstraction sample_abstraction)
- (\ (list.equivalence \=) = reference_arguments sample_arguments))
-
- _
- false)))
-
-(implementation: (function_hash super)
- (All [a] (-> (Hash a) (Hash (Function a))))
-
- (def: &equivalence
- (..function_equivalence (\ super &equivalence)))
-
- (def: (hash value)
- (case value
- (#Abstraction [environment arity body])
- ($_ n.* 2
- (\ (list.hash super) hash environment)
- (\ n.hash hash arity)
- (\ super hash body))
-
- (#Apply [abstraction arguments])
- ($_ n.* 3
- (\ super hash abstraction)
- (\ (list.hash super) hash arguments))
- )))
-
-(implementation: (control_equivalence (^open "\."))
- (All [a] (-> (Equivalence a) (Equivalence (Control a))))
-
- (def: (= reference sample)
- (case [reference sample]
- (^template [<tag> <equivalence>]
- [[(<tag> reference) (<tag> sample)]
- (\ (<equivalence> \=) = reference sample)])
- ([#Branch ..branch_equivalence]
- [#Loop ..loop_equivalence]
- [#Function ..function_equivalence])
-
- _
- false)))
-
-(implementation: (control_hash super)
- (All [a] (-> (Hash a) (Hash (Control a))))
-
- (def: &equivalence
- (..control_equivalence (\ super &equivalence)))
-
- (def: (hash value)
- (case value
- (^template [<factor> <tag> <hash>]
- [(<tag> value)
- (n.* <factor> (\ (<hash> super) hash value))])
- ([2 #Branch ..branch_hash]
- [3 #Loop ..loop_hash]
- [5 #Function ..function_hash])
- )))
-
-(implementation: #export equivalence
- (Equivalence Synthesis)
-
- (def: (= reference sample)
- (case [reference sample]
- (^template [<tag> <equivalence>]
- [[(<tag> reference') (<tag> sample')]
- (\ <equivalence> = reference' sample')])
- ([#Primitive ..primitive_equivalence]
- [#Structure (analysis.composite_equivalence =)]
- [#Reference reference.equivalence]
- [#Control (control_equivalence =)]
- [#Extension (extension.equivalence =)])
-
- _
- false)))
-
-(def: #export path_equivalence
- (Equivalence Path)
- (path'_equivalence equivalence))
-
-(implementation: #export hash
- (Hash Synthesis)
-
- (def: &equivalence ..equivalence)
-
- (def: (hash value)
- (let [recur_hash [..equivalence hash]]
- (case value
- (^template [<tag> <hash>]
- [(<tag> value)
- (\ <hash> hash value)])
- ([#Primitive ..primitive_hash]
- [#Structure (analysis.composite_hash recur_hash)]
- [#Reference reference.hash]
- [#Control (..control_hash recur_hash)]
- [#Extension (extension.hash recur_hash)])))))
-
-(template: #export (!bind_top register thenP)
- ($_ ..path/seq
- (#..Bind register)
- #..Pop
- thenP))
-
-(template: #export (!multi_pop nextP)
- ($_ ..path/seq
- #..Pop
- #..Pop
- nextP))
-
-## TODO: There are sister patterns to the simple side checks for tuples.
-## These correspond to the situation where tuple members are accessed
-## and bound to variables, but those variables are never used, so they
-## become POPs.
-## After re-implementing unused-variable-elimination, must add those
-## pattern-optimizations again, since a lot of BINDs will become POPs
-## and thus will result in useless code being generated.
-(template [<name> <side>]
- [(template: #export (<name> idx nextP)
- ($_ ..path/seq
- (<side> idx)
- #..Pop
- nextP))]
-
- [simple_left_side ..side/left]
- [simple_right_side ..side/right]
- )
diff --git a/stdlib/source/lux/tool/compiler/language/lux/version.lux b/stdlib/source/lux/tool/compiler/language/lux/version.lux
deleted file mode 100644
index 53b3424ae..000000000
--- a/stdlib/source/lux/tool/compiler/language/lux/version.lux
+++ /dev/null
@@ -1,8 +0,0 @@
-(.module:
- [lux #*]
- [////
- [version (#+ Version)]])
-
-(def: #export version
- Version
- 00,06,00)
diff --git a/stdlib/source/lux/tool/compiler/meta.lux b/stdlib/source/lux/tool/compiler/meta.lux
deleted file mode 100644
index df3eb31a7..000000000
--- a/stdlib/source/lux/tool/compiler/meta.lux
+++ /dev/null
@@ -1,8 +0,0 @@
-(.module:
- [lux #*]
- [//
- [version (#+ Version)]])
-
-(def: #export version
- Version
- 00,01,00)
diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux
deleted file mode 100644
index 09b501ef3..000000000
--- a/stdlib/source/lux/tool/compiler/meta/archive.lux
+++ /dev/null
@@ -1,279 +0,0 @@
-(.module:
- [lux (#- Module)
- [abstract
- ["." equivalence (#+ Equivalence)]
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." function]
- ["<>" parser
- ["<b>" binary (#+ Parser)]]]
- [data
- [binary (#+ Binary)]
- ["." product]
- ["." name]
- ["." text
- ["%" format (#+ format)]]
- [format
- ["." binary (#+ Writer)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." dictionary (#+ Dictionary)]
- ["." set]
- ["." row (#+ Row)]]]
- [math
- [number
- ["n" nat ("#\." equivalence)]]]
- [type
- abstract]]
- [/
- ["." artifact]
- ["." signature (#+ Signature)]
- ["." key (#+ Key)]
- ["." descriptor (#+ Module Descriptor)]
- ["." document (#+ Document)]
- [///
- [version (#+ Version)]]])
-
-(type: #export Output
- (Row [artifact.ID Binary]))
-
-(exception: #export (unknown_document {module Module}
- {known_modules (List Module)})
- (exception.report
- ["Module" (%.text module)]
- ["Known Modules" (exception.enumerate %.text known_modules)]))
-
-(exception: #export (cannot_replace_document {module Module}
- {old (Document Any)}
- {new (Document Any)})
- (exception.report
- ["Module" (%.text module)]
- ["Old key" (signature.description (document.signature old))]
- ["New key" (signature.description (document.signature new))]))
-
-(exception: #export (module_has_already_been_reserved {module Module})
- (exception.report
- ["Module" (%.text module)]))
-
-(exception: #export (module_must_be_reserved_before_it_can_be_added {module Module})
- (exception.report
- ["Module" (%.text module)]))
-
-(exception: #export (module_is_only_reserved {module Module})
- (exception.report
- ["Module" (%.text module)]))
-
-(type: #export ID
- Nat)
-
-(def: #export runtime_module
- Module
- "")
-
-(abstract: #export Archive
- {#next ID
- #resolver (Dictionary Module [ID (Maybe [Descriptor (Document Any) Output])])}
-
- (def: next
- (-> Archive ID)
- (|>> :representation (get@ #next)))
-
- (def: #export empty
- Archive
- (:abstraction {#next 0
- #resolver (dictionary.new text.hash)}))
-
- (def: #export (id module archive)
- (-> Module Archive (Try ID))
- (let [(^slots [#..resolver]) (:representation archive)]
- (case (dictionary.get module resolver)
- (#.Some [id _])
- (#try.Success id)
-
- #.None
- (exception.throw ..unknown_document [module
- (dictionary.keys resolver)]))))
-
- (def: #export (reserve module archive)
- (-> Module Archive (Try [ID Archive]))
- (let [(^slots [#..next #..resolver]) (:representation archive)]
- (case (dictionary.get module resolver)
- (#.Some _)
- (exception.throw ..module_has_already_been_reserved [module])
-
- #.None
- (#try.Success [next
- (|> archive
- :representation
- (update@ #..resolver (dictionary.put module [next #.None]))
- (update@ #..next inc)
- :abstraction)]))))
-
- (def: #export (add module [descriptor document output] archive)
- (-> Module [Descriptor (Document Any) Output] Archive (Try Archive))
- (let [(^slots [#..resolver]) (:representation archive)]
- (case (dictionary.get module resolver)
- (#.Some [id #.None])
- (#try.Success (|> archive
- :representation
- (update@ #..resolver (dictionary.put module [id (#.Some [descriptor document output])]))
- :abstraction))
-
- (#.Some [id (#.Some [existing_descriptor existing_document existing_output])])
- (if (is? document existing_document)
- ## TODO: Find out why this code allows for the same module to be added more than once. It looks fishy...
- (#try.Success archive)
- (exception.throw ..cannot_replace_document [module existing_document document]))
-
- #.None
- (exception.throw ..module_must_be_reserved_before_it_can_be_added [module]))))
-
- (def: #export (find module archive)
- (-> Module Archive (Try [Descriptor (Document Any) Output]))
- (let [(^slots [#..resolver]) (:representation archive)]
- (case (dictionary.get module resolver)
- (#.Some [id (#.Some entry)])
- (#try.Success entry)
-
- (#.Some [id #.None])
- (exception.throw ..module_is_only_reserved [module])
-
- #.None
- (exception.throw ..unknown_document [module
- (dictionary.keys resolver)]))))
-
- (def: #export (archived? archive module)
- (-> Archive Module Bit)
- (case (..find module archive)
- (#try.Success _)
- yes
-
- (#try.Failure _)
- no))
-
- (def: #export archived
- (-> Archive (List Module))
- (|>> :representation
- (get@ #resolver)
- dictionary.entries
- (list.all (function (_ [module [id descriptor+document]])
- (case descriptor+document
- (#.Some _) (#.Some module)
- #.None #.None)))))
-
- (def: #export (reserved? archive module)
- (-> Archive Module Bit)
- (let [(^slots [#..resolver]) (:representation archive)]
- (case (dictionary.get module resolver)
- (#.Some [id _])
- yes
-
- #.None
- no)))
-
- (def: #export reserved
- (-> Archive (List Module))
- (|>> :representation
- (get@ #resolver)
- dictionary.keys))
-
- (def: #export reservations
- (-> Archive (List [Module ID]))
- (|>> :representation
- (get@ #resolver)
- dictionary.entries
- (list\map (function (_ [module [id _]])
- [module id]))))
-
- (def: #export (merge additions archive)
- (-> Archive Archive Archive)
- (let [[+next +resolver] (:representation additions)]
- (|> archive
- :representation
- (update@ #next (n.max +next))
- (update@ #resolver (function (_ resolver)
- (list\fold (function (_ [module [id entry]] resolver)
- (case entry
- (#.Some _)
- (dictionary.put module [id entry] resolver)
-
- #.None
- resolver))
- resolver
- (dictionary.entries +resolver))))
- :abstraction)))
-
- (type: Reservation [Module ID])
- (type: Frozen [Version ID (List Reservation)])
-
- (def: reader
- (Parser ..Frozen)
- ($_ <>.and
- <b>.nat
- <b>.nat
- (<b>.list (<>.and <b>.text <b>.nat))))
-
- (def: writer
- (Writer ..Frozen)
- ($_ binary.and
- binary.nat
- binary.nat
- (binary.list (binary.and binary.text binary.nat))))
-
- (def: #export (export version archive)
- (-> Version Archive Binary)
- (let [(^slots [#..next #..resolver]) (:representation archive)]
- (|> resolver
- dictionary.entries
- (list.all (function (_ [module [id descriptor+document]])
- (case descriptor+document
- (#.Some _) (#.Some [module id])
- #.None #.None)))
- [version next]
- (binary.run ..writer))))
-
- (exception: #export (version_mismatch {expected Version} {actual Version})
- (exception.report
- ["Expected" (%.nat expected)]
- ["Actual" (%.nat actual)]))
-
- (exception: #export corrupt_data)
-
- (def: (correct_modules? reservations)
- (-> (List Reservation) Bit)
- (n.= (list.size reservations)
- (|> reservations
- (list\map product.left)
- (set.from_list text.hash)
- set.size)))
-
- (def: (correct_ids? reservations)
- (-> (List Reservation) Bit)
- (n.= (list.size reservations)
- (|> reservations
- (list\map product.right)
- (set.from_list n.hash)
- set.size)))
-
- (def: (correct_reservations? reservations)
- (-> (List Reservation) Bit)
- (and (correct_modules? reservations)
- (correct_ids? reservations)))
-
- (def: #export (import expected binary)
- (-> Version Binary (Try Archive))
- (do try.monad
- [[actual next reservations] (<b>.run ..reader binary)
- _ (exception.assert ..version_mismatch [expected actual]
- (n\= expected actual))
- _ (exception.assert ..corrupt_data []
- (correct_reservations? reservations))]
- (wrap (:abstraction
- {#next next
- #resolver (list\fold (function (_ [module id] archive)
- (dictionary.put module [id #.None] archive))
- (get@ #resolver (:representation ..empty))
- reservations)}))))
- )
diff --git a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux
deleted file mode 100644
index 5592df470..000000000
--- a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux
+++ /dev/null
@@ -1,154 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- [pipe (#+ case>)]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<b>" binary (#+ Parser)]]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list]
- ["." row (#+ Row) ("#\." functor fold)]
- ["." dictionary (#+ Dictionary)]]
- [format
- ["." binary (#+ Writer)]]]
- [type
- abstract]])
-
-(type: #export ID
- Nat)
-
-(type: #export Category
- #Anonymous
- (#Definition Text)
- (#Analyser Text)
- (#Synthesizer Text)
- (#Generator Text)
- (#Directive Text))
-
-(type: #export Artifact
- {#id ID
- #category Category})
-
-(abstract: #export Registry
- {#artifacts (Row Artifact)
- #resolver (Dictionary Text ID)}
-
- (def: #export empty
- Registry
- (:abstraction {#artifacts row.empty
- #resolver (dictionary.new text.hash)}))
-
- (def: #export artifacts
- (-> Registry (Row Artifact))
- (|>> :representation (get@ #artifacts)))
-
- (def: next
- (-> Registry ID)
- (|>> ..artifacts row.size))
-
- (def: #export (resource registry)
- (-> Registry [ID Registry])
- (let [id (..next registry)]
- [id
- (|> registry
- :representation
- (update@ #artifacts (row.add {#id id
- #category #Anonymous}))
- :abstraction)]))
-
- (template [<tag> <create> <fetch>]
- [(def: #export (<create> name registry)
- (-> Text Registry [ID Registry])
- (let [id (..next registry)]
- [id
- (|> registry
- :representation
- (update@ #artifacts (row.add {#id id
- #category (<tag> name)}))
- (update@ #resolver (dictionary.put name id))
- :abstraction)]))
-
- (def: #export (<fetch> registry)
- (-> Registry (List Text))
- (|> registry
- :representation
- (get@ #artifacts)
- row.to_list
- (list.all (|>> (get@ #category)
- (case> (<tag> name) (#.Some name)
- _ #.None)))))]
-
- [#Definition definition definitions]
- [#Analyser analyser analysers]
- [#Synthesizer synthesizer synthesizers]
- [#Generator generator generators]
- [#Directive directive directives]
- )
-
- (def: #export (remember name registry)
- (-> Text Registry (Maybe ID))
- (|> (:representation registry)
- (get@ #resolver)
- (dictionary.get name)))
-
- (def: #export writer
- (Writer Registry)
- (let [category (: (Writer Category)
- (function (_ value)
- (case value
- (^template [<nat> <tag> <writer>]
- [(<tag> value) ((binary.and binary.nat <writer>) [<nat> value])])
- ([0 #Anonymous binary.any]
- [1 #Definition binary.text]
- [2 #Analyser binary.text]
- [3 #Synthesizer binary.text]
- [4 #Generator binary.text]
- [5 #Directive binary.text]))))
- artifacts (: (Writer (Row Category))
- (binary.row/64 category))]
- (|>> :representation
- (get@ #artifacts)
- (row\map (get@ #category))
- artifacts)))
-
- (exception: #export (invalid_category {tag Nat})
- (exception.report
- ["Tag" (%.nat tag)]))
-
- (def: #export parser
- (Parser Registry)
- (let [category (: (Parser Category)
- (do {! <>.monad}
- [tag <b>.nat]
- (case tag
- 0 (\ ! map (|>> #Anonymous) <b>.any)
- 1 (\ ! map (|>> #Definition) <b>.text)
- 2 (\ ! map (|>> #Analyser) <b>.text)
- 3 (\ ! map (|>> #Synthesizer) <b>.text)
- 4 (\ ! map (|>> #Generator) <b>.text)
- 5 (\ ! map (|>> #Directive) <b>.text)
- _ (<>.fail (exception.construct ..invalid_category [tag])))))]
- (|> (<b>.row/64 category)
- (\ <>.monad map (row\fold (function (_ artifact registry)
- (product.right
- (case artifact
- #Anonymous
- (..resource registry)
-
- (^template [<tag> <create>]
- [(<tag> name)
- (<create> name registry)])
- ([#Definition ..definition]
- [#Analyser ..analyser]
- [#Synthesizer ..synthesizer]
- [#Generator ..generator]
- [#Directive ..directive])
- )))
- ..empty)))))
- )
diff --git a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux b/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux
deleted file mode 100644
index a31f6e793..000000000
--- a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux
+++ /dev/null
@@ -1,48 +0,0 @@
-(.module:
- [lux (#- Module)
- [control
- ["<>" parser
- ["<b>" binary (#+ Parser)]]]
- [data
- ["." text]
- [collection
- [set (#+ Set)]]
- [format
- ["." binary (#+ Writer)]]]
- [world
- [file (#+ Path)]]]
- [//
- ["." artifact (#+ Registry)]])
-
-(type: #export Module
- Text)
-
-(type: #export Descriptor
- {#name Module
- #file Path
- #hash Nat
- #state Module_State
- #references (Set Module)
- #registry Registry})
-
-(def: #export writer
- (Writer Descriptor)
- ($_ binary.and
- binary.text
- binary.text
- binary.nat
- binary.any
- (binary.set binary.text)
- artifact.writer
- ))
-
-(def: #export parser
- (Parser Descriptor)
- ($_ <>.and
- <b>.text
- <b>.text
- <b>.nat
- (\ <>.monad wrap #.Cached)
- (<b>.set text.hash <b>.text)
- artifact.parser
- ))
diff --git a/stdlib/source/lux/tool/compiler/meta/archive/document.lux b/stdlib/source/lux/tool/compiler/meta/archive/document.lux
deleted file mode 100644
index b60d77246..000000000
--- a/stdlib/source/lux/tool/compiler/meta/archive/document.lux
+++ /dev/null
@@ -1,71 +0,0 @@
-(.module:
- [lux (#- Module)
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["<>" parser
- [binary (#+ Parser)]]]
- [data
- [collection
- ["." dictionary (#+ Dictionary)]]
- [format
- ["." binary (#+ Writer)]]]
- [type (#+ :share)
- abstract]]
- [//
- ["." signature (#+ Signature)]
- ["." key (#+ Key)]
- [descriptor (#+ Module)]])
-
-(exception: #export (invalid-signature {expected Signature} {actual Signature})
- (exception.report
- ["Expected" (signature.description expected)]
- ["Actual" (signature.description actual)]))
-
-(abstract: #export (Document d)
- {#signature Signature
- #content d}
-
- (def: #export (read key document)
- (All [d] (-> (Key d) (Document Any) (Try d)))
- (let [[document//signature document//content] (:representation document)]
- (if (\ signature.equivalence =
- (key.signature key)
- document//signature)
- (#try.Success (:share [e]
- (Key e)
- key
-
- e
- (:assume document//content)))
- (exception.throw ..invalid-signature [(key.signature key)
- document//signature]))))
-
- (def: #export (write key content)
- (All [d] (-> (Key d) d (Document d)))
- (:abstraction {#signature (key.signature key)
- #content content}))
-
- (def: #export (check key document)
- (All [d] (-> (Key d) (Document Any) (Try (Document d))))
- (do try.monad
- [_ (..read key document)]
- (wrap (:assume document))))
-
- (def: #export signature
- (-> (Document Any) Signature)
- (|>> :representation (get@ #signature)))
-
- (def: #export (writer content)
- (All [d] (-> (Writer d) (Writer (Document d))))
- (let [writer (binary.and signature.writer
- content)]
- (|>> :representation writer)))
-
- (def: #export parser
- (All [d] (-> (Parser d) (Parser (Document d))))
- (|>> (<>.and signature.parser)
- (\ <>.monad map (|>> :abstraction))))
- )
diff --git a/stdlib/source/lux/tool/compiler/meta/archive/key.lux b/stdlib/source/lux/tool/compiler/meta/archive/key.lux
deleted file mode 100644
index 1f30e105b..000000000
--- a/stdlib/source/lux/tool/compiler/meta/archive/key.lux
+++ /dev/null
@@ -1,18 +0,0 @@
-(.module:
- [lux #*
- [type
- abstract]]
- [//
- [signature (#+ Signature)]])
-
-(abstract: #export (Key k)
- Signature
-
- (def: #export signature
- (-> (Key Any) Signature)
- (|>> :representation))
-
- (def: #export (key signature sample)
- (All [d] (-> Signature d (Key d)))
- (:abstraction signature))
- )
diff --git a/stdlib/source/lux/tool/compiler/meta/archive/signature.lux b/stdlib/source/lux/tool/compiler/meta/archive/signature.lux
deleted file mode 100644
index 8956f99ec..000000000
--- a/stdlib/source/lux/tool/compiler/meta/archive/signature.lux
+++ /dev/null
@@ -1,41 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]
- [control
- ["<>" parser
- ["<b>" binary (#+ Parser)]]]
- [data
- ["." product]
- ["." name]
- ["." text
- ["%" format (#+ format)]]
- [format
- ["." binary (#+ Writer)]]]
- [math
- [number
- ["." nat]]]]
- [////
- [version (#+ Version)]])
-
-(type: #export Signature
- {#name Name
- #version Version})
-
-(def: #export equivalence
- (Equivalence Signature)
- (product.equivalence name.equivalence nat.equivalence))
-
-(def: #export (description signature)
- (-> Signature Text)
- (format (%.name (get@ #name signature)) " " (%.nat (get@ #version signature))))
-
-(def: #export writer
- (Writer Signature)
- (binary.and (binary.and binary.text binary.text)
- binary.nat))
-
-(def: #export parser
- (Parser Signature)
- (<>.and (<>.and <b>.text <b>.text)
- <b>.nat))
diff --git a/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux b/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux
deleted file mode 100644
index 2a9389235..000000000
--- a/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux
+++ /dev/null
@@ -1,96 +0,0 @@
-(.module:
- [lux (#- Module)
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." state]
- ["." function
- ["." memo (#+ Memo)]]]
- [data
- ["." maybe ("#\." functor)]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." dictionary (#+ Dictionary)]
- ["." set (#+ Set)]]]]
- [///
- ["." archive (#+ Output Archive)
- [key (#+ Key)]
- ["." descriptor (#+ Module Descriptor)]
- ["." document (#+ Document)]]])
-
-(type: Ancestry
- (Set Module))
-
-(def: fresh
- Ancestry
- (set.new text.hash))
-
-(type: #export Graph
- (Dictionary Module Ancestry))
-
-(def: empty
- Graph
- (dictionary.new text.hash))
-
-(def: #export modules
- (-> Graph (List Module))
- dictionary.keys)
-
-(type: Dependency
- {#module Module
- #imports Ancestry})
-
-(def: #export graph
- (-> (List Dependency) Graph)
- (list\fold (function (_ [module imports] graph)
- (dictionary.put module imports graph))
- ..empty))
-
-(def: (ancestry archive)
- (-> Archive Graph)
- (let [memo (: (Memo Module Ancestry)
- (function (_ recur module)
- (do {! state.monad}
- [#let [parents (case (archive.find module archive)
- (#try.Success [descriptor document])
- (get@ #descriptor.references descriptor)
-
- (#try.Failure error)
- ..fresh)]
- ancestors (monad.map ! recur (set.to_list parents))]
- (wrap (list\fold set.union parents ancestors)))))
- ancestry (memo.open memo)]
- (list\fold (function (_ module memory)
- (if (dictionary.key? memory module)
- memory
- (let [[memory _] (ancestry [memory module])]
- memory)))
- ..empty
- (archive.archived archive))))
-
-(def: (dependency? ancestry target source)
- (-> Graph Module Module Bit)
- (let [target_ancestry (|> ancestry
- (dictionary.get target)
- (maybe.default ..fresh))]
- (set.member? target_ancestry source)))
-
-(type: #export Order
- (List [Module [archive.ID [Descriptor (Document .Module) Output]]]))
-
-(def: #export (load_order key archive)
- (-> (Key .Module) Archive (Try Order))
- (let [ancestry (..ancestry archive)]
- (|> ancestry
- dictionary.keys
- (list.sort (..dependency? ancestry))
- (monad.map try.monad
- (function (_ module)
- (do try.monad
- [module_id (archive.id module archive)
- [descriptor document output] (archive.find module archive)
- document (document.check key document)]
- (wrap [module [module_id [descriptor document output]]])))))))
diff --git a/stdlib/source/lux/tool/compiler/meta/io.lux b/stdlib/source/lux/tool/compiler/meta/io.lux
deleted file mode 100644
index 6bafa0a79..000000000
--- a/stdlib/source/lux/tool/compiler/meta/io.lux
+++ /dev/null
@@ -1,19 +0,0 @@
-(.module:
- [lux (#- Code)
- [data
- ["." text]]
- [world
- [file (#+ Path System)]]])
-
-(type: #export Context
- Path)
-
-(type: #export Code
- Text)
-
-(def: #export (sanitize system)
- (All [m] (-> (System m) Text Text))
- (text.replace_all "/" (\ system separator)))
-
-(def: #export lux_context
- "lux")
diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux
deleted file mode 100644
index 1ff603267..000000000
--- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux
+++ /dev/null
@@ -1,449 +0,0 @@
-(.module:
- [lux (#- Module)
- [target (#+ Target)]
- [abstract
- [predicate (#+ Predicate)]
- ["." monad (#+ do)]]
- [control
- [pipe (#+ case>)]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- [concurrency
- ["." promise (#+ Promise) ("#\." monad)]]
- ["<>" parser
- ["<.>" binary (#+ Parser)]]]
- [data
- [binary (#+ Binary)]
- ["." product]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." dictionary (#+ Dictionary)]
- ["." row (#+ Row)]
- ["." set]]]
- [math
- [number
- ["n" nat]]]
- [world
- ["." file]]]
- [program
- [compositor
- [import (#+ Import)]
- ["." static (#+ Static)]]]
- ["." // (#+ Context)
- ["#." context]
- ["/#" //
- ["." archive (#+ Output Archive)
- ["." artifact (#+ Artifact)]
- ["." descriptor (#+ Module Descriptor)]
- ["." document (#+ Document)]]
- [cache
- ["." dependency]]
- ["/#" // (#+ Input)
- [language
- ["$" lux
- ["." version]
- ["." analysis]
- ["." synthesis]
- ["." generation]
- ["." directive]
- ["#/." program]]]]]])
-
-(exception: #export (cannot_prepare {archive file.Path}
- {module_id archive.ID}
- {error Text})
- (exception.report
- ["Archive" archive]
- ["Module ID" (%.nat module_id)]
- ["Error" error]))
-
-(def: (archive fs static)
- (All [!] (-> (file.System !) Static file.Path))
- (format (get@ #static.target static)
- (\ fs separator)
- (get@ #static.host static)))
-
-(def: (unversioned_lux_archive fs static)
- (All [!] (-> (file.System !) Static file.Path))
- (format (..archive fs static)
- (\ fs separator)
- //.lux_context))
-
-(def: (versioned_lux_archive fs static)
- (All [!] (-> (file.System !) Static file.Path))
- (format (..unversioned_lux_archive fs static)
- (\ fs separator)
- (%.nat version.version)))
-
-(def: (module fs static module_id)
- (All [!] (-> (file.System !) Static archive.ID file.Path))
- (format (..versioned_lux_archive fs static)
- (\ fs separator)
- (%.nat module_id)))
-
-(def: #export (artifact fs static module_id artifact_id)
- (All [!] (-> (file.System !) Static archive.ID artifact.ID file.Path))
- (format (..module fs static module_id)
- (\ fs separator)
- (%.nat artifact_id)
- (get@ #static.artifact_extension static)))
-
-(def: (ensure_directory fs path)
- (-> (file.System Promise) file.Path (Promise (Try Any)))
- (do promise.monad
- [? (\ fs directory? path)]
- (if ?
- (wrap (#try.Success []))
- (\ fs make_directory path))))
-
-(def: #export (prepare fs static module_id)
- (-> (file.System Promise) Static archive.ID (Promise (Try Any)))
- (do {! promise.monad}
- [#let [module (..module fs static module_id)]
- module_exists? (\ fs directory? module)]
- (if module_exists?
- (wrap (#try.Success []))
- (do (try.with !)
- [_ (ensure_directory fs (..unversioned_lux_archive fs static))
- _ (ensure_directory fs (..versioned_lux_archive fs static))]
- (|> module
- (\ fs make_directory)
- (\ ! map (|>> (case> (#try.Success output)
- (#try.Success [])
-
- (#try.Failure error)
- (exception.throw ..cannot_prepare [(..archive fs static)
- module_id
- error])))))))))
-
-(def: #export (write fs static module_id artifact_id content)
- (-> (file.System Promise) Static archive.ID artifact.ID Binary (Promise (Try Any)))
- (\ fs write content (..artifact fs static module_id artifact_id)))
-
-(def: #export (enable fs static)
- (-> (file.System Promise) Static (Promise (Try Any)))
- (do (try.with promise.monad)
- [_ (..ensure_directory fs (get@ #static.target static))]
- (..ensure_directory fs (..archive fs static))))
-
-(def: (general_descriptor fs static)
- (-> (file.System Promise) Static file.Path)
- (format (..archive fs static)
- (\ fs separator)
- "general_descriptor"))
-
-(def: #export (freeze fs static archive)
- (-> (file.System Promise) Static Archive (Promise (Try Any)))
- (\ fs write (archive.export ///.version archive) (..general_descriptor fs static)))
-
-(def: module_descriptor_file
- "module_descriptor")
-
-(def: (module_descriptor fs static module_id)
- (-> (file.System Promise) Static archive.ID file.Path)
- (format (..module fs static module_id)
- (\ fs separator)
- ..module_descriptor_file))
-
-(def: #export (cache fs static module_id content)
- (-> (file.System Promise) Static archive.ID Binary (Promise (Try Any)))
- (\ fs write content (..module_descriptor fs static module_id)))
-
-(def: (read_module_descriptor fs static module_id)
- (-> (file.System Promise) Static archive.ID (Promise (Try Binary)))
- (\ fs read (..module_descriptor fs static module_id)))
-
-(def: parser
- (Parser [Descriptor (Document .Module)])
- (<>.and descriptor.parser
- (document.parser $.parser)))
-
-(def: (fresh_analysis_state host)
- (-> Target .Lux)
- (analysis.state (analysis.info version.version host)))
-
-(def: (analysis_state host archive)
- (-> Target Archive (Try .Lux))
- (do {! try.monad}
- [modules (: (Try (List [Module .Module]))
- (monad.map ! (function (_ module)
- (do !
- [[descriptor document output] (archive.find module archive)
- content (document.read $.key document)]
- (wrap [module content])))
- (archive.archived archive)))]
- (wrap (set@ #.modules modules (fresh_analysis_state host)))))
-
-(def: (cached_artifacts fs static module_id)
- (-> (file.System Promise) Static archive.ID (Promise (Try (Dictionary Text Binary))))
- (let [! (try.with promise.monad)]
- (|> (..module fs static module_id)
- (\ fs directory_files)
- (\ ! map (|>> (list\map (function (_ file)
- [(file.name fs file) file]))
- (list.filter (|>> product.left (text\= ..module_descriptor_file) not))
- (monad.map ! (function (_ [name path])
- (|> path
- (\ fs read)
- (\ ! map (|>> [name])))))
- (\ ! map (dictionary.from_list text.hash))))
- (\ ! join))))
-
-(type: Definitions (Dictionary Text Any))
-(type: Analysers (Dictionary Text analysis.Handler))
-(type: Synthesizers (Dictionary Text synthesis.Handler))
-(type: Generators (Dictionary Text generation.Handler))
-(type: Directives (Dictionary Text directive.Handler))
-
-(type: Bundles
- [Analysers
- Synthesizers
- Generators
- Directives])
-
-(def: empty_bundles
- Bundles
- [(dictionary.new text.hash)
- (dictionary.new text.hash)
- (dictionary.new text.hash)
- (dictionary.new text.hash)])
-
-(def: (loaded_document extension host module_id expected actual document)
- (All [expression directive]
- (-> Text (generation.Host expression directive) archive.ID (Row Artifact) (Dictionary Text Binary) (Document .Module)
- (Try [(Document .Module) Bundles])))
- (do {! try.monad}
- [[definitions bundles] (: (Try [Definitions Bundles])
- (loop [input (row.to_list expected)
- definitions (: Definitions
- (dictionary.new text.hash))
- bundles ..empty_bundles]
- (let [[analysers synthesizers generators directives] bundles]
- (case input
- (#.Cons [[artifact_id artifact_category] input'])
- (case (do !
- [data (try.from_maybe (dictionary.get (format (%.nat artifact_id) extension) actual))
- #let [context [module_id artifact_id]
- directive (\ host ingest context data)]]
- (case artifact_category
- #artifact.Anonymous
- (do !
- [_ (\ host re_learn context directive)]
- (wrap [definitions
- [analysers
- synthesizers
- generators
- directives]]))
-
- (#artifact.Definition name)
- (if (text\= $/program.name name)
- (wrap [definitions
- [analysers
- synthesizers
- generators
- directives]])
- (do !
- [value (\ host re_load context directive)]
- (wrap [(dictionary.put name value definitions)
- [analysers
- synthesizers
- generators
- directives]])))
-
- (#artifact.Analyser extension)
- (do !
- [value (\ host re_load context directive)]
- (wrap [definitions
- [(dictionary.put extension (:as analysis.Handler value) analysers)
- synthesizers
- generators
- directives]]))
-
- (#artifact.Synthesizer extension)
- (do !
- [value (\ host re_load context directive)]
- (wrap [definitions
- [analysers
- (dictionary.put extension (:as synthesis.Handler value) synthesizers)
- generators
- directives]]))
-
- (#artifact.Generator extension)
- (do !
- [value (\ host re_load context directive)]
- (wrap [definitions
- [analysers
- synthesizers
- (dictionary.put extension (:as generation.Handler value) generators)
- directives]]))
-
- (#artifact.Directive extension)
- (do !
- [value (\ host re_load context directive)]
- (wrap [definitions
- [analysers
- synthesizers
- generators
- (dictionary.put extension (:as directive.Handler value) directives)]]))))
- (#try.Success [definitions' bundles'])
- (recur input' definitions' bundles')
-
- failure
- failure)
-
- #.None
- (#try.Success [definitions bundles])))))
- content (document.read $.key document)
- definitions (monad.map ! (function (_ [def_name def_global])
- (case def_global
- (#.Alias alias)
- (wrap [def_name (#.Alias alias)])
-
- (#.Definition [exported? type annotations _])
- (do !
- [value (try.from_maybe (dictionary.get def_name definitions))]
- (wrap [def_name (#.Definition [exported? type annotations value])]))))
- (get@ #.definitions content))]
- (wrap [(document.write $.key (set@ #.definitions definitions content))
- bundles])))
-
-(def: (load_definitions fs static module_id host_environment [descriptor document output])
- (All [expression directive]
- (-> (file.System Promise) Static archive.ID (generation.Host expression directive)
- [Descriptor (Document .Module) Output]
- (Promise (Try [[Descriptor (Document .Module) Output]
- Bundles]))))
- (do (try.with promise.monad)
- [actual (cached_artifacts fs static module_id)
- #let [expected (|> descriptor (get@ #descriptor.registry) artifact.artifacts)]
- [document bundles] (promise\wrap (loaded_document (get@ #static.artifact_extension static) host_environment module_id expected actual document))]
- (wrap [[descriptor document output] bundles])))
-
-(def: (purge! fs static [module_name module_id])
- (-> (file.System Promise) Static [Module archive.ID] (Promise (Try Any)))
- (do {! (try.with promise.monad)}
- [#let [cache (..module fs static module_id)]
- _ (|> cache
- (\ fs directory_files)
- (\ ! map (monad.map ! (\ fs delete)))
- (\ ! join))]
- (\ fs delete cache)))
-
-(def: (valid_cache? expected actual)
- (-> Descriptor Input Bit)
- (and (text\= (get@ #descriptor.name expected)
- (get@ #////.module actual))
- (text\= (get@ #descriptor.file expected)
- (get@ #////.file actual))
- (n.= (get@ #descriptor.hash expected)
- (get@ #////.hash actual))))
-
-(type: Purge
- (Dictionary Module archive.ID))
-
-(def: initial_purge
- (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module) Output]]]])
- Purge)
- (|>> (list.all (function (_ [valid_cache? [module_name [module_id _]]])
- (if valid_cache?
- #.None
- (#.Some [module_name module_id]))))
- (dictionary.from_list text.hash)))
-
-(def: (full_purge caches load_order)
- (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module) Output]]]])
- dependency.Order
- Purge)
- (list\fold (function (_ [module_name [module_id [descriptor document output]]] purge)
- (let [purged? (: (Predicate Module)
- (dictionary.key? purge))]
- (if (purged? module_name)
- purge
- (if (|> descriptor
- (get@ #descriptor.references)
- set.to_list
- (list.any? purged?))
- (dictionary.put module_name module_id purge)
- purge))))
- (..initial_purge caches)
- load_order))
-
-(def: pseudo_module
- Text
- "(Lux Caching System)")
-
-(def: (load_every_reserved_module host_environment fs static import contexts archive)
- (All [expression directive]
- (-> (generation.Host expression directive) (file.System Promise) Static Import (List Context) Archive
- (Promise (Try [Archive .Lux Bundles]))))
- (do {! (try.with promise.monad)}
- [pre_loaded_caches (|> archive
- archive.reservations
- (monad.map ! (function (_ [module_name module_id])
- (do !
- [data (..read_module_descriptor fs static module_id)
- [descriptor document] (promise\wrap (<binary>.run ..parser data))]
- (if (text\= archive.runtime_module module_name)
- (wrap [true
- [module_name [module_id [descriptor document (: Output row.empty)]]]])
- (do !
- [input (//context.read fs ..pseudo_module import contexts (get@ #static.host_module_extension static) module_name)]
- (wrap [(..valid_cache? descriptor input)
- [module_name [module_id [descriptor document (: Output row.empty)]]]])))))))
- load_order (|> pre_loaded_caches
- (list\map product.right)
- (monad.fold try.monad
- (function (_ [module [module_id descriptor,document,output]] archive)
- (archive.add module descriptor,document,output archive))
- archive)
- (\ try.monad map (dependency.load_order $.key))
- (\ try.monad join)
- promise\wrap)
- #let [purge (..full_purge pre_loaded_caches load_order)]
- _ (|> purge
- dictionary.entries
- (monad.map ! (..purge! fs static)))
- loaded_caches (|> load_order
- (list.filter (function (_ [module_name [module_id [descriptor document output]]])
- (not (dictionary.key? purge module_name))))
- (monad.map ! (function (_ [module_name [module_id descriptor,document,output]])
- (do !
- [[descriptor,document,output bundles] (..load_definitions fs static module_id host_environment descriptor,document,output)]
- (wrap [[module_name descriptor,document,output]
- bundles])))))]
- (promise\wrap
- (do {! try.monad}
- [archive (monad.fold !
- (function (_ [[module descriptor,document] _bundle] archive)
- (archive.add module descriptor,document archive))
- archive
- loaded_caches)
- analysis_state (..analysis_state (get@ #static.host static) archive)]
- (wrap [archive
- analysis_state
- (list\fold (function (_ [_ [+analysers +synthesizers +generators +directives]]
- [analysers synthesizers generators directives])
- [(dictionary.merge +analysers analysers)
- (dictionary.merge +synthesizers synthesizers)
- (dictionary.merge +generators generators)
- (dictionary.merge +directives directives)])
- ..empty_bundles
- loaded_caches)])))))
-
-(def: #export (thaw host_environment fs static import contexts)
- (All [expression directive]
- (-> (generation.Host expression directive) (file.System Promise) Static Import (List Context)
- (Promise (Try [Archive .Lux Bundles]))))
- (do promise.monad
- [binary (\ fs read (..general_descriptor fs static))]
- (case binary
- (#try.Success binary)
- (do (try.with promise.monad)
- [archive (promise\wrap (archive.import ///.version binary))]
- (..load_every_reserved_module host_environment fs static import contexts archive))
-
- (#try.Failure error)
- (wrap (#try.Success [archive.empty
- (fresh_analysis_state (get@ #static.host static))
- ..empty_bundles])))))
diff --git a/stdlib/source/lux/tool/compiler/meta/io/context.lux b/stdlib/source/lux/tool/compiler/meta/io/context.lux
deleted file mode 100644
index f31b4e1b2..000000000
--- a/stdlib/source/lux/tool/compiler/meta/io/context.lux
+++ /dev/null
@@ -1,169 +0,0 @@
-(.module:
- [lux (#- Module Code)
- ["@" target]
- [abstract
- [predicate (#+ Predicate)]
- ["." monad (#+ Monad do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- [concurrency
- ["." promise (#+ Promise) ("#\." monad)]]]
- [data
- [binary (#+ Binary)]
- ["." text ("#\." hash)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." dictionary (#+ Dictionary)]]]
- [world
- ["." file]]]
- [program
- [compositor
- [import (#+ Import)]]]
- ["." // (#+ Context Code)
- ["/#" // #_
- [archive
- [descriptor (#+ Module)]]
- ["/#" // (#+ Input)]]])
-
-(exception: #export (cannot_find_module {importer Module} {module Module})
- (exception.report
- ["Module" (%.text module)]
- ["Importer" (%.text importer)]))
-
-(exception: #export (cannot_read_module {module Module})
- (exception.report
- ["Module" (%.text module)]))
-
-(type: #export Extension
- Text)
-
-(def: lux_extension
- Extension
- ".lux")
-
-(def: #export (path fs context module)
- (All [m] (-> (file.System m) Context Module file.Path))
- (|> module
- (//.sanitize fs)
- (format context (\ fs separator))))
-
-(def: (find_source_file fs importer contexts module extension)
- (-> (file.System Promise) Module (List Context) Module Extension
- (Promise (Try file.Path)))
- (case contexts
- #.Nil
- (promise\wrap (exception.throw ..cannot_find_module [importer module]))
-
- (#.Cons context contexts')
- (let [path (format (..path fs context module) extension)]
- (do promise.monad
- [? (\ fs file? path)]
- (if ?
- (wrap (#try.Success path))
- (find_source_file fs importer contexts' module extension))))))
-
-(def: (full_host_extension partial_host_extension)
- (-> Extension Extension)
- (format partial_host_extension ..lux_extension))
-
-(def: (find_local_source_file fs importer import contexts partial_host_extension module)
- (-> (file.System Promise) Module Import (List Context) Extension Module
- (Promise (Try [file.Path Binary])))
- ## Preference is explicitly being given to Lux files that have a host extension.
- ## Normal Lux files (i.e. without a host extension) are then picked as fallback files.
- (do {! promise.monad}
- [outcome (..find_source_file fs importer contexts module (..full_host_extension partial_host_extension))]
- (case outcome
- (#try.Success path)
- (|> path
- (\ fs read)
- (\ (try.with !) map (|>> [path])))
-
- (#try.Failure _)
- (do {! (try.with !)}
- [path (..find_source_file fs importer contexts module ..lux_extension)]
- (|> path
- (\ fs read)
- (\ ! map (|>> [path])))))))
-
-(def: (find_library_source_file importer import partial_host_extension module)
- (-> Module Import Extension Module (Try [file.Path Binary]))
- (let [path (format module (..full_host_extension partial_host_extension))]
- (case (dictionary.get path import)
- (#.Some data)
- (#try.Success [path data])
-
- #.None
- (let [path (format module ..lux_extension)]
- (case (dictionary.get path import)
- (#.Some data)
- (#try.Success [path data])
-
- #.None
- (exception.throw ..cannot_find_module [importer module]))))))
-
-(def: (find_any_source_file fs importer import contexts partial_host_extension module)
- (-> (file.System Promise) Module Import (List Context) Extension Module
- (Promise (Try [file.Path Binary])))
- ## Preference is explicitly being given to Lux files that have a host extension.
- ## Normal Lux files (i.e. without a host extension) are then picked as fallback files.
- (do {! promise.monad}
- [outcome (find_local_source_file fs importer import contexts partial_host_extension module)]
- (case outcome
- (#try.Success [path data])
- (wrap outcome)
-
- (#try.Failure _)
- (wrap (..find_library_source_file importer import partial_host_extension module)))))
-
-(def: #export (read fs importer import contexts partial_host_extension module)
- (-> (file.System Promise) Module Import (List Context) Extension Module
- (Promise (Try Input)))
- (do (try.with promise.monad)
- [[path binary] (..find_any_source_file fs importer import contexts partial_host_extension module)]
- (case (\ utf8.codec decode binary)
- (#try.Success code)
- (wrap {#////.module module
- #////.file path
- #////.hash (text\hash code)
- #////.code code})
-
- (#try.Failure _)
- (promise\wrap (exception.throw ..cannot_read_module [module])))))
-
-(type: #export Enumeration
- (Dictionary file.Path Binary))
-
-(def: (enumerate_context fs directory enumeration)
- (-> (file.System Promise) Context Enumeration (Promise (Try Enumeration)))
- (do {! (try.with promise.monad)}
- [enumeration (|> directory
- (\ fs directory_files)
- (\ ! map (monad.fold ! (function (_ file enumeration)
- (if (text.ends_with? ..lux_extension file)
- (do !
- [source_code (\ fs read file)]
- (promise\wrap
- (dictionary.try_put (file.name fs file) source_code enumeration)))
- (wrap enumeration)))
- enumeration))
- (\ ! join))]
- (|> directory
- (\ fs sub_directories)
- (\ ! map (monad.fold ! (enumerate_context fs) enumeration))
- (\ ! join))))
-
-(def: Action
- (type (All [a] (Promise (Try a)))))
-
-(def: #export (enumerate fs contexts)
- (-> (file.System Promise) (List Context) (Action Enumeration))
- (monad.fold (: (Monad Action)
- (try.with promise.monad))
- (..enumerate_context fs)
- (: Enumeration
- (dictionary.new text.hash))
- contexts))
diff --git a/stdlib/source/lux/tool/compiler/meta/packager.lux b/stdlib/source/lux/tool/compiler/meta/packager.lux
deleted file mode 100644
index fff07d28f..000000000
--- a/stdlib/source/lux/tool/compiler/meta/packager.lux
+++ /dev/null
@@ -1,42 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [monad (#+ Monad)]]
- [control
- [try (#+ Try)]]
- [data
- [binary (#+ Binary)]
- [collection
- ["." row]
- ["." list ("#\." functor)]]]
- [world
- ["." file (#+ Path)]]]
- [program
- [compositor
- [static (#+ Static)]]]
- [//
- [cache
- ["." dependency]]
- ["." archive (#+ Archive)
- ["." descriptor]
- ["." artifact]]
- [//
- [language
- [lux
- [generation (#+ Context)]]]]])
-
-(type: #export Packager
- (-> Archive Context (Try Binary)))
-
-(type: #export Order
- (List [archive.ID (List artifact.ID)]))
-
-(def: #export order
- (-> dependency.Order Order)
- (list\map (function (_ [module [module_id [descriptor document]]])
- (|> descriptor
- (get@ #descriptor.registry)
- artifact.artifacts
- row.to_list
- (list\map (|>> (get@ #artifact.id)))
- [module_id]))))
diff --git a/stdlib/source/lux/tool/compiler/meta/packager/jvm.lux b/stdlib/source/lux/tool/compiler/meta/packager/jvm.lux
deleted file mode 100644
index a89bdc836..000000000
--- a/stdlib/source/lux/tool/compiler/meta/packager/jvm.lux
+++ /dev/null
@@ -1,144 +0,0 @@
-(.module:
- [lux (#- Module Definition)
- [type (#+ :share)]
- ["." ffi (#+ import: do_to)]
- [abstract
- ["." monad (#+ Monad do)]]
- [control
- ["." try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." binary (#+ Binary)]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." row (#+ Row) ("#\." fold)]
- ["." list ("#\." functor fold)]]]
- [math
- [number
- ["n" nat]]]
- [target
- [jvm
- [encoding
- ["." name]]]]]
- [program
- [compositor
- ["." static (#+ Static)]]]
- ["." // (#+ Packager)
- [//
- ["." archive (#+ Output)
- ["." descriptor (#+ Module)]
- ["." artifact]]
- [cache
- ["." dependency]]
- ["." io #_
- ["#" archive]]
- [//
- [language
- ["$" lux
- [generation (#+ Context)]
- [phase
- [generation
- [jvm
- ["." runtime (#+ Definition)]]]]]]]]])
-
-(import: java/lang/Object)
-
-(import: java/lang/String)
-
-(import: java/util/jar/Attributes
- ["#::."
- (put [java/lang/Object java/lang/Object] #? java/lang/Object)])
-
-(import: java/util/jar/Attributes$Name
- ["#::."
- (#static MAIN_CLASS java/util/jar/Attributes$Name)
- (#static MANIFEST_VERSION java/util/jar/Attributes$Name)])
-
-(import: java/util/jar/Manifest
- ["#::."
- (new [])
- (getMainAttributes [] java/util/jar/Attributes)])
-
-(import: java/io/Flushable
- ["#::."
- (flush [] void)])
-
-(import: java/io/Closeable
- ["#::."
- (close [] void)])
-
-(import: java/io/OutputStream)
-
-(import: java/io/ByteArrayOutputStream
- ["#::."
- (new [int])
- (toByteArray [] [byte])])
-
-(import: java/util/zip/ZipEntry)
-
-(import: java/util/zip/ZipOutputStream
- ["#::."
- (write [[byte] int int] void)
- (closeEntry [] void)])
-
-(import: java/util/jar/JarEntry
- ["#::."
- (new [java/lang/String])])
-
-(import: java/util/jar/JarOutputStream
- ["#::."
- (new [java/io/OutputStream java/util/jar/Manifest])
- (putNextEntry [java/util/zip/ZipEntry] void)])
-
-(def: byte 1)
-## https://en.wikipedia.org/wiki/Kibibyte
-(def: kibi_byte (n.* 1,024 byte))
-## https://en.wikipedia.org/wiki/Mebibyte
-(def: mebi_byte (n.* 1,024 kibi_byte))
-
-(def: manifest_version "1.0")
-
-(def: (manifest program)
- (-> Context java/util/jar/Manifest)
- (let [manifest (java/util/jar/Manifest::new)]
- (exec (do_to (java/util/jar/Manifest::getMainAttributes manifest)
- (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MAIN_CLASS) (|> program runtime.class_name name.internal name.external))
- (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MANIFEST_VERSION) ..manifest_version))
- manifest)))
-
-(def: (write_class static module artifact content sink)
- (-> Static archive.ID artifact.ID Binary java/util/jar/JarOutputStream
- java/util/jar/JarOutputStream)
- (let [class_path (format (runtime.class_name [module artifact])
- (get@ #static.artifact_extension static))]
- (do_to sink
- (java/util/jar/JarOutputStream::putNextEntry (java/util/jar/JarEntry::new class_path))
- (java/util/zip/ZipOutputStream::write content +0 (.int (binary.size content)))
- (java/io/Flushable::flush)
- (java/util/zip/ZipOutputStream::closeEntry))))
-
-(def: (write_module static [module output] sink)
- (-> Static [archive.ID Output] java/util/jar/JarOutputStream
- java/util/jar/JarOutputStream)
- (row\fold (function (_ [artifact content] sink)
- (..write_class static module artifact content sink))
- sink
- output))
-
-(def: #export (package static)
- (-> Static Packager)
- (function (_ archive program)
- (do {! try.monad}
- [order (dependency.load_order $.key archive)
- #let [buffer (java/io/ByteArrayOutputStream::new (.int ..mebi_byte))
- sink (|> order
- (list\map (function (_ [module [module_id [descriptor document output]]])
- [module_id output]))
- (list\fold (..write_module static)
- (java/util/jar/JarOutputStream::new buffer (..manifest program))))
- _ (do_to sink
- (java/io/Flushable::flush)
- (java/io/Closeable::close))]]
- (wrap (java/io/ByteArrayOutputStream::toByteArray buffer)))))
diff --git a/stdlib/source/lux/tool/compiler/meta/packager/scheme.lux b/stdlib/source/lux/tool/compiler/meta/packager/scheme.lux
deleted file mode 100644
index ac35684ed..000000000
--- a/stdlib/source/lux/tool/compiler/meta/packager/scheme.lux
+++ /dev/null
@@ -1,131 +0,0 @@
-(.module:
- [lux (#- Module)
- [type (#+ :share)]
- [abstract
- ["." monad (#+ Monad do)]]
- [control
- ["." try (#+ Try)]]
- [data
- [binary (#+ Binary)]
- ["." product]
- ["." text
- ["%" format (#+ format)]
- ["." encoding]]
- [collection
- ["." row]
- ["." list ("#\." functor fold)]
- ["." dictionary (#+ Dictionary)]
- ["." set]]
- [format
- ["." tar]
- ["." binary]]]
- [target
- ["_" scheme]]
- [time
- ["." instant (#+ Instant)]]
- [world
- ["." file]]]
- [program
- [compositor
- ["." static (#+ Static)]]]
- ["." // (#+ Packager)
- [//
- ["." archive (#+ Output)
- ["." descriptor (#+ Module Descriptor)]
- ["." artifact]
- ["." document (#+ Document)]]
- [cache
- ["." dependency]]
- ["." io #_
- ["#" archive]]
- [//
- [language
- ["$" lux
- [generation (#+ Context)]]]]]])
-
-## TODO: Delete ASAP
-(type: (Action ! a)
- (! (Try a)))
-
-(def: (then pre post)
- (-> _.Expression _.Expression _.Expression)
- (_.manual (format (_.code pre)
- text.new_line
- (_.code post))))
-
-(def: bundle_module
- (-> Output (Try _.Expression))
- (|>> row.to_list
- (list\map product.right)
- (monad.fold try.monad
- (function (_ content so_far)
- (|> content
- (\ encoding.utf8 decode)
- (\ try.monad map
- (|>> :assume
- (:share [directive]
- directive
- so_far
-
- directive)
- (..then so_far)))))
- (: _.Expression (_.manual "")))))
-
-(def: module_file
- (-> archive.ID file.Path)
- (|>> %.nat (text.suffix ".scm")))
-
-(def: mode
- tar.Mode
- ($_ tar.and
- tar.read_by_group
- tar.read_by_owner
-
- tar.write_by_other
- tar.write_by_group
- tar.write_by_owner))
-
-(def: owner
- tar.Owner
- {#tar.name tar.anonymous
- #tar.id tar.no_id})
-
-(def: ownership
- {#tar.user ..owner
- #tar.group ..owner})
-
-(def: (write_module now mapping [module [module_id [descriptor document output]]])
- (-> Instant (Dictionary Module archive.ID)
- [Module [archive.ID [Descriptor (Document .Module) Output]]]
- (Try tar.Entry))
- (do {! try.monad}
- [bundle (: (Try _.Expression)
- (..bundle_module output))
- entry_content (: (Try tar.Content)
- (|> descriptor
- (get@ #descriptor.references)
- set.to_list
- (list.all (function (_ module) (dictionary.get module mapping)))
- (list\map (|>> ..module_file _.string _.load-relative/1))
- (list\fold ..then bundle)
- (: _.Expression)
- _.code
- (\ encoding.utf8 encode)
- tar.content))
- module_file (tar.path (..module_file module_id))]
- (wrap (#tar.Normal [module_file now ..mode ..ownership entry_content]))))
-
-(def: #export (package now)
- (-> Instant Packager)
- (function (package archive program)
- (do {! try.monad}
- [order (dependency.load_order $.key archive)
- #let [mapping (|> order
- (list\map (function (_ [module [module_id [descriptor document output]]])
- [module module_id]))
- (dictionary.from_list text.hash)
- (: (Dictionary Module archive.ID)))]
- entries (monad.map ! (..write_module now mapping) order)]
- (wrap (|> entries
- row.from_list
- (binary.run tar.writer))))))
diff --git a/stdlib/source/lux/tool/compiler/meta/packager/script.lux b/stdlib/source/lux/tool/compiler/meta/packager/script.lux
deleted file mode 100644
index 98a011a4c..000000000
--- a/stdlib/source/lux/tool/compiler/meta/packager/script.lux
+++ /dev/null
@@ -1,75 +0,0 @@
-(.module:
- [lux #*
- [type (#+ :share)]
- [abstract
- ["." monad (#+ Monad do)]]
- [control
- ["." try (#+ Try)]]
- [data
- [binary (#+ Binary)]
- ["." product]
- [text
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." row]
- ["." list ("#\." functor)]]]]
- [program
- [compositor
- ["." static (#+ Static)]]]
- ["." // (#+ Packager)
- [//
- ["." archive (#+ Output)
- ["." descriptor]
- ["." artifact]]
- [cache
- ["." dependency]]
- ["." io #_
- ["#" archive]]
- [//
- [language
- ["$" lux
- [generation (#+ Context)]]]]]])
-
-## TODO: Delete ASAP
-(type: (Action ! a)
- (! (Try a)))
-
-(def: (write_module sequence [module output] so_far)
- (All [directive]
- (-> (-> directive directive directive) [archive.ID Output] directive
- (Try directive)))
- (|> output
- row.to_list
- (list\map product.right)
- (monad.fold try.monad
- (function (_ content so_far)
- (|> content
- (\ utf8.codec decode)
- (\ try.monad map
- (function (_ content)
- (sequence so_far
- (:share [directive]
- directive
- so_far
-
- directive
- (:assume content)))))))
- so_far)))
-
-(def: #export (package header to_code sequence scope)
- (All [directive]
- (-> directive
- (-> directive Text)
- (-> directive directive directive)
- (-> directive directive)
- Packager))
- (function (package archive program)
- (do {! try.monad}
- [order (dependency.load_order $.key archive)]
- (|> order
- (list\map (function (_ [module [module_id [descriptor document output]]])
- [module_id output]))
- (monad.fold ! (..write_module sequence) header)
- (\ ! map (|>> scope to_code (\ utf8.codec encode)))))))
diff --git a/stdlib/source/lux/tool/compiler/phase.lux b/stdlib/source/lux/tool/compiler/phase.lux
deleted file mode 100644
index 0d6543c33..000000000
--- a/stdlib/source/lux/tool/compiler/phase.lux
+++ /dev/null
@@ -1,118 +0,0 @@
-(.module:
- [lux #*
- ["." debug]
- [abstract
- [monad (#+ Monad do)]]
- [control
- ["." state]
- ["." try (#+ Try) ("#\." functor)]
- ["ex" exception (#+ Exception exception:)]
- ["." io]
- [parser
- ["s" code]]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]]
- [time
- ["." instant]
- ["." duration]]
- [macro
- [syntax (#+ syntax:)]]]
- [//
- [meta
- [archive (#+ Archive)]]])
-
-(type: #export (Operation s o)
- (state.State' Try s o))
-
-(def: #export monad
- (All [s] (Monad (Operation s)))
- (state.with try.monad))
-
-(type: #export (Phase s i o)
- (-> Archive i (Operation s o)))
-
-(def: #export (run' state operation)
- (All [s o]
- (-> s (Operation s o) (Try [s o])))
- (operation state))
-
-(def: #export (run state operation)
- (All [s o]
- (-> s (Operation s o) (Try o)))
- (|> state
- operation
- (\ try.monad map product.right)))
-
-(def: #export get_state
- (All [s o]
- (Operation s s))
- (function (_ state)
- (#try.Success [state state])))
-
-(def: #export (set_state state)
- (All [s o]
- (-> s (Operation s Any)))
- (function (_ _)
- (#try.Success [state []])))
-
-(def: #export (sub [get set] operation)
- (All [s s' o]
- (-> [(-> s s') (-> s' s s)]
- (Operation s' o)
- (Operation s o)))
- (function (_ state)
- (do try.monad
- [[state' output] (operation (get state))]
- (wrap [(set state' state) output]))))
-
-(def: #export fail
- (-> Text Operation)
- (|>> try.fail (state.lift try.monad)))
-
-(def: #export (throw exception parameters)
- (All [e] (-> (Exception e) e Operation))
- (..fail (ex.construct exception parameters)))
-
-(def: #export (lift error)
- (All [s a] (-> (Try a) (Operation s a)))
- (function (_ state)
- (try\map (|>> [state]) error)))
-
-(syntax: #export (assert exception message test)
- (wrap (list (` (if (~ test)
- (\ ..monad (~' wrap) [])
- (..throw (~ exception) (~ message)))))))
-
-(def: #export identity
- (All [s a] (Phase s a a))
- (function (_ archive input state)
- (#try.Success [state input])))
-
-(def: #export (compose pre post)
- (All [s0 s1 i t o]
- (-> (Phase s0 i t)
- (Phase s1 t o)
- (Phase [s0 s1] i o)))
- (function (_ archive input [pre/state post/state])
- (do try.monad
- [[pre/state' temp] (pre archive input pre/state)
- [post/state' output] (post archive temp post/state)]
- (wrap [[pre/state' post/state'] output]))))
-
-(def: #export (timed definition description operation)
- (All [s a]
- (-> Name Text (Operation s a) (Operation s a)))
- (do ..monad
- [_ (wrap [])
- #let [pre (io.run instant.now)]
- output operation
- #let [_ (|> instant.now
- io.run
- instant.relative
- (duration.difference (instant.relative pre))
- %.duration
- (format (%.name definition) " [" description "]: ")
- debug.log!)]]
- (wrap output)))
diff --git a/stdlib/source/lux/tool/compiler/reference.lux b/stdlib/source/lux/tool/compiler/reference.lux
deleted file mode 100644
index 98a1f0c07..000000000
--- a/stdlib/source/lux/tool/compiler/reference.lux
+++ /dev/null
@@ -1,84 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]]
- [control
- [pipe (#+ case>)]]
- [data
- ["." name]
- [text
- ["%" format (#+ Format)]]]
- [math
- [number
- ["n" nat]]]]
- ["." / #_
- ["#." variable (#+ Variable)]])
-
-(type: #export Constant
- Name)
-
-(type: #export Reference
- (#Variable Variable)
- (#Constant Constant))
-
-(implementation: #export equivalence
- (Equivalence Reference)
-
- (def: (= reference sample)
- (case [reference sample]
- (^template [<tag> <equivalence>]
- [[(<tag> reference) (<tag> sample)]
- (\ <equivalence> = reference sample)])
- ([#Variable /variable.equivalence]
- [#Constant name.equivalence])
-
- _
- false)))
-
-(implementation: #export hash
- (Hash Reference)
-
- (def: &equivalence
- ..equivalence)
-
- (def: (hash value)
- (case value
- (^template [<factor> <tag> <hash>]
- [(<tag> value)
- ($_ n.* <factor>
- (\ <hash> hash value))])
- ([2 #Variable /variable.hash]
- [3 #Constant name.hash])
- )))
-
-(template [<name> <family> <tag>]
- [(template: #export (<name> content)
- (<| <family>
- <tag>
- content))]
-
- [local #..Variable #/variable.Local]
- [foreign #..Variable #/variable.Foreign]
- )
-
-(template [<name> <tag>]
- [(template: #export (<name> content)
- (<| <tag>
- content))]
-
- [variable #..Variable]
- [constant #..Constant]
- )
-
-(def: #export self
- Reference
- (..local 0))
-
-(def: #export format
- (Format Reference)
- (|>> (case> (#Variable variable)
- (/variable.format variable)
-
- (#Constant constant)
- (%.name constant))))
diff --git a/stdlib/source/lux/tool/compiler/reference/variable.lux b/stdlib/source/lux/tool/compiler/reference/variable.lux
deleted file mode 100644
index 84aea58ab..000000000
--- a/stdlib/source/lux/tool/compiler/reference/variable.lux
+++ /dev/null
@@ -1,67 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]]
- [control
- [pipe (#+ case>)]]
- [data
- [text
- ["%" format (#+ Format)]]]
- [math
- [number
- ["n" nat]
- ["i" int]]]])
-
-(type: #export Register
- Nat)
-
-(type: #export Variable
- (#Local Register)
- (#Foreign Register))
-
-(implementation: #export equivalence
- (Equivalence Variable)
-
- (def: (= reference sample)
- (case [reference sample]
- (^template [<tag>]
- [[(<tag> reference') (<tag> sample')]
- (n.= reference' sample')])
- ([#Local] [#Foreign])
-
- _
- #0)))
-
-(implementation: #export hash
- (Hash Variable)
-
- (def: &equivalence
- ..equivalence)
-
- (def: hash
- (|>> (case> (^template [<factor> <tag>]
- [(<tag> register)
- ($_ n.* <factor>
- (\ n.hash hash register))])
- ([2 #Local]
- [3 #Foreign])))))
-
-(template: #export (self)
- (#..Local 0))
-
-(def: #export self?
- (-> Variable Bit)
- (|>> (case> (^ (..self))
- true
-
- _
- false)))
-
-(def: #export format
- (Format Variable)
- (|>> (case> (#Local local)
- (%.format "+" (%.nat local))
-
- (#Foreign foreign)
- (%.format "-" (%.nat foreign)))))
diff --git a/stdlib/source/lux/tool/compiler/version.lux b/stdlib/source/lux/tool/compiler/version.lux
deleted file mode 100644
index d29428636..000000000
--- a/stdlib/source/lux/tool/compiler/version.lux
+++ /dev/null
@@ -1,51 +0,0 @@
-(.module:
- [lux #*
- [data
- [text
- ["%" format]]]
- [math
- [number
- ["n" nat]]]])
-
-(type: #export Version
- Nat)
-
-(def: range 100)
-
-(def: level
- (n.% ..range))
-
-(def: current
- (-> Nat Nat)
- (|>>))
-
-(def: next
- (n./ ..range))
-
-(def: #export patch
- (-> Version Nat)
- (|>> ..current ..level))
-
-(def: #export minor
- (-> Version Nat)
- (|>> ..next ..level))
-
-(def: #export major
- (-> Version Nat)
- (|>> ..next ..next ..level))
-
-(def: separator ".")
-
-(def: (padded value)
- (-> Nat Text)
- (if (n.< 10 value)
- (%.format "0" (%.nat value))
- (%.nat value)))
-
-(def: #export (format version)
- (%.Format Version)
- (%.format (..padded (..major version))
- ..separator
- (..padded (..minor version))
- ..separator
- (..padded (..patch version))))
diff --git a/stdlib/source/lux/tool/interpreter.lux b/stdlib/source/lux/tool/interpreter.lux
deleted file mode 100644
index e18a27c47..000000000
--- a/stdlib/source/lux/tool/interpreter.lux
+++ /dev/null
@@ -1,221 +0,0 @@
-(.module:
- [lux #*
- [control
- [monad (#+ Monad do)]
- ["." try (#+ Try)]
- ["ex" exception (#+ exception:)]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]
- [type (#+ :share)
- ["." check]]
- [compiler
- ["." phase
- ["." analysis
- ["." module]
- ["." type]]
- ["." generation]
- ["." directive (#+ State+ Operation)
- ["." total]]
- ["." extension]]
- ["." default
- ["." syntax]
- ["." platform (#+ Platform)]
- ["." init]]
- ["." cli (#+ Configuration)]]
- [world
- ["." file (#+ File)]
- ["." console (#+ Console)]]]
- ["." /type])
-
-(exception: #export (error {message Text})
- message)
-
-(def: #export module "<INTERPRETER>")
-
-(def: fresh-source Source [[..module 1 0] 0 ""])
-
-(def: (add-line line [where offset input])
- (-> Text Source Source)
- [where offset (format input text.new-line line)])
-
-(def: exit-command Text "exit")
-
-(def: welcome-message
- Text
- (format text.new-line
- "Welcome to the interpreter!" text.new-line
- "Type '" ..exit-command "' to leave." text.new-line
- text.new-line))
-
-(def: farewell-message
- Text
- "Till next time...")
-
-(def: enter-module
- (All [anchor expression directive]
- (Operation anchor expression directive Any))
- (directive.lift-analysis
- (do phase.monad
- [_ (module.create 0 ..module)]
- (analysis.set-current-module ..module))))
-
-(def: (initialize Monad<!> Console<!> platform configuration generation-bundle)
- (All [! anchor expression directive]
- (-> (Monad !)
- (Console !) (Platform ! anchor expression directive)
- Configuration
- (generation.Bundle anchor expression directive)
- (! (State+ anchor expression directive))))
- (do Monad<!>
- [state (platform.initialize platform generation-bundle)
- state (platform.compile platform
- (set@ #cli.module syntax.prelude configuration)
- (set@ [#extension.state
- #directive.analysis #directive.state
- #extension.state
- #.info #.mode]
- #.Interpreter
- state))
- [state _] (\ (get@ #platform.file-system platform)
- lift (phase.run' state enter-module))
- _ (\ Console<!> write ..welcome-message)]
- (wrap state)))
-
-(with-expansions [<Interpretation> (as-is (Operation anchor expression directive [Type Any]))]
-
- (def: (interpret-directive code)
- (All [anchor expression directive]
- (-> Code <Interpretation>))
- (do phase.monad
- [_ (total.phase code)
- _ init.refresh]
- (wrap [Any []])))
-
- (def: (interpret-expression code)
- (All [anchor expression directive]
- (-> Code <Interpretation>))
- (do {! phase.monad}
- [state (extension.lift phase.get-state)
- #let [analyse (get@ [#directive.analysis #directive.phase] state)
- synthesize (get@ [#directive.synthesis #directive.phase] state)
- generate (get@ [#directive.generation #directive.phase] state)]
- [_ codeT codeA] (directive.lift-analysis
- (analysis.with-scope
- (type.with-fresh-env
- (do !
- [[codeT codeA] (type.with-inference
- (analyse code))
- codeT (type.with-env
- (check.clean codeT))]
- (wrap [codeT codeA])))))
- codeS (directive.lift-synthesis
- (synthesize codeA))]
- (directive.lift-generation
- (generation.with-buffer
- (do !
- [codeH (generate codeS)
- count generation.next
- codeV (generation.evaluate! (format "interpretation_" (%.nat count)) codeH)]
- (wrap [codeT codeV]))))))
-
- (def: (interpret configuration code)
- (All [anchor expression directive]
- (-> Configuration Code <Interpretation>))
- (function (_ state)
- (case (<| (phase.run' state)
- (:share [anchor expression directive]
- {(State+ anchor expression directive)
- state}
- {<Interpretation>
- (interpret-directive code)}))
- (#try.Success [state' output])
- (#try.Success [state' output])
-
- (#try.Failure error)
- (if (ex.match? total.not-a-directive error)
- (<| (phase.run' state)
- (:share [anchor expression directive]
- {(State+ anchor expression directive)
- state}
- {<Interpretation>
- (interpret-expression code)}))
- (#try.Failure error)))))
- )
-
-(def: (execute configuration code)
- (All [anchor expression directive]
- (-> Configuration Code (Operation anchor expression directive Text)))
- (do phase.monad
- [[codeT codeV] (interpret configuration code)
- state phase.get-state]
- (wrap (/type.represent (get@ [#extension.state
- #directive.analysis #directive.state
- #extension.state]
- state)
- codeT
- codeV))))
-
-(type: (Context anchor expression directive)
- {#configuration Configuration
- #state (State+ anchor expression directive)
- #source Source})
-
-(with-expansions [<Context> (as-is (Context anchor expression directive))]
- (def: (read-eval-print context)
- (All [anchor expression directive]
- (-> <Context> (Try [<Context> Text])))
- (do try.monad
- [#let [[_where _offset _code] (get@ #source context)]
- [source' input] (syntax.parse ..module syntax.no-aliases (text.size _code) (get@ #source context))
- [state' representation] (let [## TODO: Simplify ASAP
- state (:share [anchor expression directive]
- {<Context>
- context}
- {(State+ anchor expression directive)
- (get@ #state context)})]
- (<| (phase.run' state)
- ## TODO: Simplify ASAP
- (:share [anchor expression directive]
- {<Context>
- context}
- {(Operation anchor expression directive Text)
- (execute (get@ #configuration context) input)})))]
- (wrap [(|> context
- (set@ #state state')
- (set@ #source source'))
- representation]))))
-
-(def: #export (run Monad<!> Console<!> platform configuration generation-bundle)
- (All [! anchor expression directive]
- (-> (Monad !)
- (Console !) (Platform ! anchor expression directive)
- Configuration
- (generation.Bundle anchor expression directive)
- (! Any)))
- (do {! Monad<!>}
- [state (initialize Monad<!> Console<!> platform configuration)]
- (loop [context {#configuration configuration
- #state state
- #source ..fresh-source}
- multi-line? #0]
- (do !
- [_ (if multi-line?
- (\ Console<!> write " ")
- (\ Console<!> write "> "))
- line (\ Console<!> read-line)]
- (if (and (not multi-line?)
- (text\= ..exit-command line))
- (\ Console<!> write ..farewell-message)
- (case (read-eval-print (update@ #source (add-line line) context))
- (#try.Success [context' representation])
- (do !
- [_ (\ Console<!> write representation)]
- (recur context' #0))
-
- (#try.Failure error)
- (if (ex.match? syntax.end-of-file error)
- (recur context #1)
- (exec (log! (ex.construct ..error error))
- (recur (set@ #source ..fresh-source context) #0))))))
- )))
diff --git a/stdlib/source/lux/tool/mediator.lux b/stdlib/source/lux/tool/mediator.lux
deleted file mode 100644
index 5beb217e0..000000000
--- a/stdlib/source/lux/tool/mediator.lux
+++ /dev/null
@@ -1,18 +0,0 @@
-(.module:
- [lux (#- Source Module)
- [world
- ["." binary (#+ Binary)]
- ["." file (#+ File)]]]
- [//
- [compiler (#+ Compiler)
- [meta
- ["." archive (#+ Archive)
- [descriptor (#+ Module)]]]]])
-
-(type: #export Source File)
-
-(type: #export (Mediator !)
- (-> Archive Module (! Archive)))
-
-(type: #export (Instancer ! d o)
- (-> (file.System !) (List Source) (Compiler d o) (Mediator !)))
diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux
deleted file mode 100644
index af6048ac9..000000000
--- a/stdlib/source/lux/type.lux
+++ /dev/null
@@ -1,462 +0,0 @@
-(.module: {#.doc "Basic functionality for working with types."}
- [lux (#- function)
- ["@" target]
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ Monad do)]]
- [control
- ["." function]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- ["." product]
- ["." maybe]
- ["." text ("#\." monoid equivalence)]
- ["." name ("#\." equivalence codec)]
- [collection
- ["." array]
- ["." list ("#\." functor monoid fold)]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- [number
- ["n" nat ("#\." decimal)]]]
- ["." meta
- ["." location]]])
-
-(template [<name> <tag>]
- [(def: #export (<name> type)
- (-> Type [Nat Type])
- (loop [num_args 0
- type type]
- (case type
- (<tag> env sub_type)
- (recur (inc num_args) sub_type)
-
- _
- [num_args type])))]
-
- [flatten_univ_q #.UnivQ]
- [flatten_ex_q #.ExQ]
- )
-
-(def: #export (flatten_function type)
- (-> Type [(List Type) Type])
- (case type
- (#.Function in out')
- (let [[ins out] (flatten_function out')]
- [(list& in ins) out])
-
- _
- [(list) type]))
-
-(def: #export (flatten_application type)
- (-> Type [Type (List Type)])
- (case type
- (#.Apply arg func')
- (let [[func args] (flatten_application func')]
- [func (list\compose args (list arg))])
-
- _
- [type (list)]))
-
-(template [<name> <tag>]
- [(def: #export (<name> type)
- (-> Type (List Type))
- (case type
- (<tag> left right)
- (list& left (<name> right))
-
- _
- (list type)))]
-
- [flatten_variant #.Sum]
- [flatten_tuple #.Product]
- )
-
-(def: #export (format type)
- (-> Type Text)
- (case type
- (#.Primitive name params)
- ($_ text\compose
- "(primitive "
- (text.enclose' text.double_quote name)
- (|> params
- (list\map (|>> format (text\compose " ")))
- (list\fold (function.flip text\compose) ""))
- ")")
-
- (^template [<tag> <open> <close> <flatten>]
- [(<tag> _)
- ($_ text\compose <open>
- (|> (<flatten> type)
- (list\map format)
- list.reverse
- (list.interpose " ")
- (list\fold text\compose ""))
- <close>)])
- ([#.Sum "(| " ")" flatten_variant]
- [#.Product "[" "]" flatten_tuple])
-
- (#.Function input output)
- (let [[ins out] (flatten_function type)]
- ($_ text\compose "(-> "
- (|> ins
- (list\map format)
- list.reverse
- (list.interpose " ")
- (list\fold text\compose ""))
- " " (format out) ")"))
-
- (#.Parameter idx)
- (n\encode idx)
-
- (#.Var id)
- ($_ text\compose "⌈v:" (n\encode id) "⌋")
-
- (#.Ex id)
- ($_ text\compose "⟨e:" (n\encode id) "⟩")
-
- (#.Apply param fun)
- (let [[type_func type_args] (flatten_application type)]
- ($_ text\compose "(" (format type_func) " " (|> type_args (list\map format) list.reverse (list.interpose " ") (list\fold text\compose "")) ")"))
-
- (^template [<tag> <desc>]
- [(<tag> env body)
- ($_ text\compose "(" <desc> " {" (|> env (list\map format) (text.join_with " ")) "} " (format body) ")")])
- ([#.UnivQ "All"]
- [#.ExQ "Ex"])
-
- (#.Named [module name] type)
- ($_ text\compose module "." name)
- ))
-
-(def: (beta_reduce env type)
- (-> (List Type) Type Type)
- (case type
- (#.Primitive name params)
- (#.Primitive name (list\map (beta_reduce env) params))
-
- (^template [<tag>]
- [(<tag> left right)
- (<tag> (beta_reduce env left) (beta_reduce env right))])
- ([#.Sum] [#.Product]
- [#.Function] [#.Apply])
-
- (^template [<tag>]
- [(<tag> old_env def)
- (case old_env
- #.Nil
- (<tag> env def)
-
- _
- (<tag> (list\map (beta_reduce env) old_env) def))])
- ([#.UnivQ]
- [#.ExQ])
-
- (#.Parameter idx)
- (maybe.default (error! ($_ text\compose
- "Unknown type parameter" text.new_line
- " Index: " (n\encode idx) text.new_line
- "Environment: " (|> env
- list.enumeration
- (list\map (.function (_ [index type])
- ($_ text\compose
- (n\encode index)
- " " (..format type))))
- (text.join_with (text\compose text.new_line " ")))))
- (list.nth idx env))
-
- _
- type
- ))
-
-(implementation: #export equivalence
- (Equivalence Type)
-
- (def: (= x y)
- (or (for {@.php false} ## TODO: Remove this once JPHP is gone.
- (is? x y))
- (case [x y]
- [(#.Primitive xname xparams) (#.Primitive yname yparams)]
- (and (text\= xname yname)
- (n.= (list.size yparams) (list.size xparams))
- (list\fold (.function (_ [x y] prev) (and prev (= x y)))
- #1
- (list.zip/2 xparams yparams)))
-
- (^template [<tag>]
- [[(<tag> xid) (<tag> yid)]
- (n.= yid xid)])
- ([#.Var] [#.Ex] [#.Parameter])
-
- (^or [(#.Function xleft xright) (#.Function yleft yright)]
- [(#.Apply xleft xright) (#.Apply yleft yright)])
- (and (= xleft yleft)
- (= xright yright))
-
- [(#.Named xname xtype) (#.Named yname ytype)]
- (and (name\= xname yname)
- (= xtype ytype))
-
- (^template [<tag>]
- [[(<tag> xL xR) (<tag> yL yR)]
- (and (= xL yL) (= xR yR))])
- ([#.Sum] [#.Product])
-
- (^or [(#.UnivQ xenv xbody) (#.UnivQ yenv ybody)]
- [(#.ExQ xenv xbody) (#.ExQ yenv ybody)])
- (and (n.= (list.size yenv) (list.size xenv))
- (= xbody ybody)
- (list\fold (.function (_ [x y] prev) (and prev (= x y)))
- #1
- (list.zip/2 xenv yenv)))
-
- _
- #0
- ))))
-
-(def: #export (apply params func)
- (-> (List Type) Type (Maybe Type))
- (case params
- #.Nil
- (#.Some func)
-
- (#.Cons param params')
- (case func
- (^template [<tag>]
- [(<tag> env body)
- (|> body
- (beta_reduce (list& func param env))
- (apply params'))])
- ([#.UnivQ] [#.ExQ])
-
- (#.Apply A F)
- (apply (list& A params) F)
-
- (#.Named name unnamed)
- (apply params unnamed)
-
- _
- #.None)))
-
-(def: #export (to_code type)
- (-> Type Code)
- (case type
- (#.Primitive name params)
- (` (#.Primitive (~ (code.text name))
- (.list (~+ (list\map to_code params)))))
-
- (^template [<tag>]
- [(<tag> idx)
- (` (<tag> (~ (code.nat idx))))])
- ([#.Var] [#.Ex] [#.Parameter])
-
- (^template [<tag>]
- [(<tag> left right)
- (` (<tag> (~ (to_code left))
- (~ (to_code right))))])
- ([#.Sum] [#.Product] [#.Function] [#.Apply])
-
- (#.Named name sub_type)
- (code.identifier name)
-
- (^template [<tag>]
- [(<tag> env body)
- (` (<tag> (.list (~+ (list\map to_code env)))
- (~ (to_code body))))])
- ([#.UnivQ] [#.ExQ])
- ))
-
-(def: #export (un_alias type)
- (-> Type Type)
- (case type
- (#.Named _ (#.Named name type'))
- (un_alias (#.Named name type'))
-
- _
- type))
-
-(def: #export (un_name type)
- (-> Type Type)
- (case type
- (#.Named name type')
- (un_name type')
-
- _
- type))
-
-(template [<name> <base> <ctor>]
- [(def: #export (<name> types)
- (-> (List Type) Type)
- (case types
- #.Nil
- <base>
-
- (#.Cons type #.Nil)
- type
-
- (#.Cons type types')
- (<ctor> type (<name> types'))))]
-
- [variant Nothing #.Sum]
- [tuple Any #.Product]
- )
-
-(def: #export (function inputs output)
- (-> (List Type) Type Type)
- (case inputs
- #.Nil
- output
-
- (#.Cons input inputs')
- (#.Function input (function inputs' output))))
-
-(def: #export (application params quant)
- (-> (List Type) Type Type)
- (case params
- #.Nil
- quant
-
- (#.Cons param params')
- (application params' (#.Apply param quant))))
-
-(template [<name> <tag>]
- [(def: #export (<name> size body)
- (-> Nat Type Type)
- (case size
- 0 body
- _ (|> body (<name> (dec size)) (<tag> (list)))))]
-
- [univ_q #.UnivQ]
- [ex_q #.ExQ]
- )
-
-(def: #export (quantified? type)
- (-> Type Bit)
- (case type
- (#.Named [module name] _type)
- (quantified? _type)
-
- (#.Apply A F)
- (maybe.default #0
- (do maybe.monad
- [applied (apply (list A) F)]
- (wrap (quantified? applied))))
-
- (^or (#.UnivQ _) (#.ExQ _))
- #1
-
- _
- #0))
-
-(def: #export (array depth element_type)
- (-> Nat Type Type)
- (case depth
- 0 element_type
- _ (|> element_type
- (array (dec depth))
- (list)
- (#.Primitive array.type_name))))
-
-(def: #export (flatten_array type)
- (-> Type [Nat Type])
- (case type
- (^multi (^ (#.Primitive name (list element_type)))
- (text\= array.type_name name))
- (let [[depth element_type] (flatten_array element_type)]
- [(inc depth) element_type])
-
- _
- [0 type]))
-
-(def: #export array?
- (-> Type Bit)
- (|>> ..flatten_array
- product.left
- (n.> 0)))
-
-(syntax: (new_secret_marker)
- (macro.with_gensyms [g!_secret_marker_]
- (wrap (list g!_secret_marker_))))
-
-(def: secret_marker
- (`` (name_of (~~ (new_secret_marker)))))
-
-(syntax: #export (:log! {input (<>.or (<>.and <code>.identifier
- (<>.maybe (<>.after (<code>.identifier! ..secret_marker) <code>.any)))
- <code>.any)})
- (case input
- (#.Left [valueN valueC])
- (do meta.monad
- [location meta.location
- valueT (meta.find_type valueN)
- #let [_ ("lux io log"
- ($_ text\compose
- (name\encode (name_of ..:log!)) " " (location.format location) text.new_line
- "Expression: " (case valueC
- (#.Some valueC)
- (code.format valueC)
-
- #.None
- (name\encode valueN))
- text.new_line
- " Type: " (..format valueT)))]]
- (wrap (list (code.identifier valueN))))
-
- (#.Right valueC)
- (macro.with_gensyms [g!value]
- (wrap (list (` (.let [(~ g!value) (~ valueC)]
- (..:log! (~ valueC) (~ (code.identifier ..secret_marker)) (~ g!value)))))))))
-
-(def: type_parameters
- (Parser (List Text))
- (<code>.tuple (<>.some <code>.local_identifier)))
-
-(syntax: #export (:cast {type_vars type_parameters}
- input
- output
- {value (<>.maybe <code>.any)})
- (let [casterC (` (: (All [(~+ (list\map code.local_identifier type_vars))]
- (-> (~ input) (~ output)))
- (|>> :assume)))]
- (case value
- #.None
- (wrap (list casterC))
-
- (#.Some value)
- (wrap (list (` ((~ casterC) (~ value))))))))
-
-(type: Typed
- {#type Code
- #expression Code})
-
-(def: typed
- (Parser Typed)
- (<>.and <code>.any <code>.any))
-
-## TODO: Make sure the generated code always gets optimized away.
-(syntax: #export (:share {type_vars ..type_parameters}
- {exemplar ..typed}
- {computation ..typed})
- (macro.with_gensyms [g!_]
- (let [shareC (` (: (All [(~+ (list\map code.local_identifier type_vars))]
- (-> (~ (get@ #type exemplar))
- (~ (get@ #type computation))))
- (.function ((~ g!_) (~ g!_))
- (~ (get@ #expression computation)))))]
- (wrap (list (` ((~ shareC) (~ (get@ #expression exemplar)))))))))
-
-(syntax: #export (:by_example {type_vars ..type_parameters}
- {exemplar ..typed}
- {extraction <code>.any})
- (wrap (list (` (:of ((~! :share)
- [(~+ (list\map code.local_identifier type_vars))]
-
- (~ (get@ #type exemplar))
- (~ (get@ #expression exemplar))
-
- (~ extraction)
- (:assume [])))))))
diff --git a/stdlib/source/lux/type/abstract.lux b/stdlib/source/lux/type/abstract.lux
deleted file mode 100644
index c3121d7ff..000000000
--- a/stdlib/source/lux/type/abstract.lux
+++ /dev/null
@@ -1,268 +0,0 @@
-(.module:
- [lux #*
- [type (#+ :cast)]
- ["." meta]
- [abstract
- [monad (#+ Monad do)]]
- [control
- ["." exception (#+ exception:)]
- ["<>" parser ("#\." monad)
- ["<.>" code (#+ Parser)]]]
- [data
- ["." name ("#\." codec)]
- ["." text ("#\." equivalence monoid)]
- [collection
- ["." list ("#\." functor monoid)]]]
- [macro
- ["." code]
- [syntax (#+ syntax:)
- ["|.|" export]
- ["|.|" annotations]]]])
-
-(type: Stack List)
-
-(def: peek
- (All [a] (-> (Stack a) (Maybe a)))
- list.head)
-
-(def: (push value stack)
- (All [a] (-> a (Stack a) (Stack a)))
- (#.Cons value stack))
-
-(def: pop
- (All [a] (-> (Stack a) (Maybe (Stack a))))
- list.tail)
-
-(type: #export Frame
- {#name Text
- #type_vars (List Code)
- #abstraction Code
- #representation Code})
-
-(def: frames
- (Stack Frame)
- #.Nil)
-
-(template: (!peek <source> <reference> <then>)
- (loop [entries <source>]
- (case entries
- (#.Cons [head_name head] tail)
- (if (text\= <reference> head_name)
- <then>
- (recur tail))
-
- #.Nil
- (undefined))))
-
-(def: (peek_frames_definition reference source)
- (-> Text (List [Text Global]) (Stack Frame))
- (!peek source reference
- (case head
- (#.Left _)
- (undefined)
-
- (#.Right [exported? frame_type frame_anns frame_value])
- (:as (Stack Frame) frame_value))))
-
-(def: (peek_frames reference definition_reference source)
- (-> Text Text (List [Text Module]) (Stack Frame))
- (!peek source reference
- (peek_frames_definition definition_reference (get@ #.definitions head))))
-
-(exception: #export no_active_frames)
-
-(def: (peek! frame)
- (-> (Maybe Text) (Meta Frame))
- (function (_ compiler)
- (let [[reference definition_reference] (name_of ..frames)
- current_frames (peek_frames reference definition_reference (get@ #.modules compiler))]
- (case (case frame
- (#.Some frame)
- (list.find (function (_ [actual _])
- (text\= frame actual))
- current_frames)
-
- #.None
- (..peek current_frames))
- (#.Some frame)
- (#.Right [compiler frame])
-
- #.None
- (exception.throw ..no_active_frames [])))))
-
-(def: #export current
- (Meta Frame)
- (..peek! #.None))
-
-(def: #export (specific name)
- (-> Text (Meta Frame))
- (..peek! (#.Some name)))
-
-(template: (!push <source> <reference> <then>)
- (loop [entries <source>]
- (case entries
- (#.Cons [head_name head] tail)
- (if (text\= <reference> head_name)
- (#.Cons [head_name <then>]
- tail)
- (#.Cons [head_name head]
- (recur tail)))
-
- #.Nil
- (undefined))))
-
-(def: (push_frame_definition reference frame source)
- (-> Text Frame (List [Text Global]) (List [Text Global]))
- (!push source reference
- (case head
- (#.Left _)
- (undefined)
-
- (#.Right [exported? frames_type frames_anns frames_value])
- (#.Right [exported?
- frames_type
- frames_anns
- (..push frame (:as (Stack Frame) frames_value))]))))
-
-(def: (push_frame [module_reference definition_reference] frame source)
- (-> Name Frame (List [Text Module]) (List [Text Module]))
- (!push source module_reference
- (update@ #.definitions (push_frame_definition definition_reference frame) head)))
-
-(def: (push! frame)
- (-> Frame (Meta Any))
- (function (_ compiler)
- (#.Right [(update@ #.modules
- (..push_frame (name_of ..frames) frame)
- compiler)
- []])))
-
-(def: (pop_frame_definition reference source)
- (-> Text (List [Text Global]) (List [Text Global]))
- (!push source reference
- (case head
- (#.Left _)
- (undefined)
-
- (#.Right [exported? frames_type frames_anns frames_value])
- (#.Right [exported?
- frames_type
- frames_anns
- (let [current_frames (:as (Stack Frame) frames_value)]
- (case (..pop current_frames)
- (#.Some current_frames')
- current_frames'
-
- #.None
- current_frames))]))))
-
-(def: (pop_frame [module_reference definition_reference] source)
- (-> Name (List [Text Module]) (List [Text Module]))
- (!push source module_reference
- (|> head (update@ #.definitions (pop_frame_definition definition_reference)))))
-
-(syntax: (pop!)
- (function (_ compiler)
- (#.Right [(update@ #.modules
- (..pop_frame (name_of ..frames))
- compiler)
- (list)])))
-
-(def: cast
- (Parser [(Maybe Text) Code])
- (<>.either (<>.and (<>.maybe <code>.local_identifier) <code>.any)
- (<>.and (<>\wrap #.None) <code>.any)))
-
-(template [<name> <from> <to>]
- [(syntax: #export (<name> {[frame value] ..cast})
- (do meta.monad
- [[name type_vars abstraction representation] (peek! frame)]
- (wrap (list (` ((~! :cast) [(~+ type_vars)] (~ <from>) (~ <to>)
- (~ value)))))))]
-
- [:abstraction representation abstraction]
- [:representation abstraction representation]
- )
-
-(def: abstraction_type_name
- (-> Name Text)
- (|>> name\encode
- ($_ text\compose
- (name\encode (name_of #..Abstraction))
- " ")))
-
-(def: representation_definition_name
- (-> Text Text)
- (|>> ($_ text\compose
- (name\encode (name_of #..Representation))
- " ")))
-
-(def: declaration
- (Parser [Text (List Text)])
- (<>.either (<code>.form (<>.and <code>.local_identifier (<>.some <code>.local_identifier)))
- (<>.and <code>.local_identifier (\ <>.monad wrap (list)))))
-
-## TODO: Make sure the generated code always gets optimized away.
-## (This applies to uses of ":abstraction" and ":representation")
-(syntax: #export (abstract:
- {export |export|.parser}
- {[name type_vars] declaration}
- representation_type
- {annotations (<>.default |annotations|.empty |annotations|.parser)}
- {primitives (<>.some <code>.any)})
- (do meta.monad
- [current_module meta.current_module_name
- #let [type_varsC (list\map code.local_identifier type_vars)
- abstraction_declaration (` ((~ (code.local_identifier name)) (~+ type_varsC)))
- representation_declaration (` ((~ (code.local_identifier (representation_definition_name name)))
- (~+ type_varsC)))]
- _ (..push! [name
- type_varsC
- abstraction_declaration
- representation_declaration])]
- (wrap (list& (` (type: (~+ (|export|.format export)) (~ abstraction_declaration)
- (~ (|annotations|.format annotations))
- (primitive (~ (code.text (abstraction_type_name [current_module name])))
- [(~+ type_varsC)])))
- (` (type: (~ representation_declaration)
- (~ representation_type)))
- ($_ list\compose
- primitives
- (list (` ((~! ..pop!)))))))))
-
-(type: (Selection a)
- (#Specific Code a)
- (#Current a))
-
-(def: (selection parser)
- (All [a] (-> (Parser a) (Parser (Selection a))))
- (<>.or (<>.and <code>.any parser)
- parser))
-
-(syntax: #export (:transmutation {selection (..selection <code>.any)})
- (case selection
- (#Specific specific value)
- (wrap (list (` (..:abstraction (~ specific)
- (..:representation (~ specific)
- (~ value))))))
-
- (#Current value)
- (wrap (list (` (..:abstraction (..:representation (~ value))))))))
-
-(syntax: #export (^:representation {selection (<code>.form (..selection <code>.local_identifier))}
- body
- {branches (<>.some <code>.any)})
- (case selection
- (#Specific specific name)
- (let [g!var (code.local_identifier name)]
- (wrap (list& g!var
- (` (.let [(~ g!var) (..:representation (~ specific) (~ g!var))]
- (~ body)))
- branches)))
-
- (#Current name)
- (let [g!var (code.local_identifier name)]
- (wrap (list& g!var
- (` (.let [(~ g!var) (..:representation (~ g!var))]
- (~ body)))
- branches)))))
diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux
deleted file mode 100644
index 3882591e5..000000000
--- a/stdlib/source/lux/type/check.lux
+++ /dev/null
@@ -1,720 +0,0 @@
-(.module: {#.doc "Type-checking functionality."}
- [lux #*
- ["@" target]
- [abstract
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- ["." monad (#+ Monad do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ Exception exception:)]]
- [data
- ["." maybe]
- ["." product]
- ["." text ("#\." monoid equivalence)]
- [collection
- ["." list]
- ["." set (#+ Set)]]]
- [math
- [number
- ["n" nat ("#\." decimal)]]]]
- ["." // ("#\." equivalence)])
-
-(template: (!n\= reference subject)
- ("lux i64 =" reference subject))
-
-(template: (!text\= reference subject)
- ("lux text =" reference subject))
-
-(exception: #export (unknown_type_var {id Nat})
- (exception.report
- ["ID" (n\encode id)]))
-
-(exception: #export (unbound_type_var {id Nat})
- (exception.report
- ["ID" (n\encode id)]))
-
-(exception: #export (invalid_type_application {funcT Type} {argT Type})
- (exception.report
- ["Type function" (//.format funcT)]
- ["Type argument" (//.format argT)]))
-
-(exception: #export (cannot_rebind_var {id Nat} {type Type} {bound Type})
- (exception.report
- ["Var" (n\encode id)]
- ["Wanted Type" (//.format type)]
- ["Current Type" (//.format bound)]))
-
-(exception: #export (type_check_failed {expected Type} {actual Type})
- (exception.report
- ["Expected" (//.format expected)]
- ["Actual" (//.format actual)]))
-
-(type: #export Var
- Nat)
-
-(type: Assumption
- [Type Type])
-
-(type: #export (Check a)
- (-> Type_Context (Try [Type_Context a])))
-
-(type: (Checker a)
- (-> (List Assumption) a a (Check (List Assumption))))
-
-(type: Type_Vars
- (List [Var (Maybe Type)]))
-
-(implementation: #export functor
- (Functor Check)
-
- (def: (map f fa)
- (function (_ context)
- (case (fa context)
- (#try.Success [context' output])
- (#try.Success [context' (f output)])
-
- (#try.Failure error)
- (#try.Failure error)))))
-
-(implementation: #export apply
- (Apply Check)
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (function (_ context)
- (case (ff context)
- (#try.Success [context' f])
- (case (fa context')
- (#try.Success [context'' a])
- (#try.Success [context'' (f a)])
-
- (#try.Failure error)
- (#try.Failure error))
-
- (#try.Failure error)
- (#try.Failure error)
- )))
- )
-
-(implementation: #export monad
- (Monad Check)
-
- (def: &functor ..functor)
-
- (def: (wrap x)
- (function (_ context)
- (#try.Success [context x])))
-
- (def: (join ffa)
- (function (_ context)
- (case (ffa context)
- (#try.Success [context' fa])
- (case (fa context')
- (#try.Success [context'' a])
- (#try.Success [context'' a])
-
- (#try.Failure error)
- (#try.Failure error))
-
- (#try.Failure error)
- (#try.Failure error)
- )))
- )
-
-(open: "check\." ..monad)
-
-(def: (var::new id plist)
- (-> Var Type_Vars Type_Vars)
- (#.Cons [id #.None] plist))
-
-(def: (var::get id plist)
- (-> Var Type_Vars (Maybe (Maybe Type)))
- (case plist
- (#.Cons [var_id var_type]
- plist')
- (if (!n\= id var_id)
- (#.Some var_type)
- (var::get id plist'))
-
- #.Nil
- #.None))
-
-(def: (var::put id value plist)
- (-> Var (Maybe Type) Type_Vars Type_Vars)
- (case plist
- #.Nil
- (list [id value])
-
- (#.Cons [var_id var_type]
- plist')
- (if (!n\= id var_id)
- (#.Cons [var_id value]
- plist')
- (#.Cons [var_id var_type]
- (var::put id value plist')))))
-
-(def: #export (run context proc)
- (All [a] (-> Type_Context (Check a) (Try a)))
- (case (proc context)
- (#try.Success [context' output])
- (#try.Success output)
-
- (#try.Failure error)
- (#try.Failure error)))
-
-(def: #export (fail message)
- (All [a] (-> Text (Check a)))
- (function (_ context)
- (#try.Failure message)))
-
-(def: #export (assert message test)
- (-> Text Bit (Check Any))
- (function (_ context)
- (if test
- (#try.Success [context []])
- (#try.Failure message))))
-
-(def: #export (throw exception message)
- (All [e a] (-> (Exception e) e (Check a)))
- (..fail (exception.construct exception message)))
-
-(def: #export existential
- {#.doc "A producer of existential types."}
- (Check [Nat Type])
- (function (_ context)
- (let [id (get@ #.ex_counter context)]
- (#try.Success [(update@ #.ex_counter inc context)
- [id (#.Ex id)]]))))
-
-(template [<name> <outputT> <fail> <succeed>]
- [(def: #export (<name> id)
- (-> Var (Check <outputT>))
- (function (_ context)
- (case (|> context (get@ #.var_bindings) (var::get id))
- (^or (#.Some (#.Some (#.Var _)))
- (#.Some #.None))
- (#try.Success [context <fail>])
-
- (#.Some (#.Some bound))
- (#try.Success [context <succeed>])
-
- #.None
- (exception.throw ..unknown_type_var id))))]
-
- [bound? Bit false true]
- [read (Maybe Type) #.None (#.Some bound)]
- )
-
-(def: #export (read! id)
- (-> Var (Check Type))
- (do ..monad
- [?type (read id)]
- (case ?type
- (#.Some type)
- (wrap type)
-
- #.None
- (..throw ..unbound_type_var id))))
-
-(def: (peek id)
- (-> Var (Check Type))
- (function (_ context)
- (case (|> context (get@ #.var_bindings) (var::get id))
- (#.Some (#.Some bound))
- (#try.Success [context bound])
-
- (#.Some _)
- (exception.throw ..unbound_type_var id)
-
- _
- (exception.throw ..unknown_type_var id))))
-
-(def: #export (bind type id)
- (-> Type Var (Check Any))
- (function (_ context)
- (case (|> context (get@ #.var_bindings) (var::get id))
- (#.Some #.None)
- (#try.Success [(update@ #.var_bindings (var::put id (#.Some type)) context)
- []])
-
- (#.Some (#.Some bound))
- (exception.throw ..cannot_rebind_var [id type bound])
-
- _
- (exception.throw ..unknown_type_var id))))
-
-(def: (update type id)
- (-> Type Var (Check Any))
- (function (_ context)
- (case (|> context (get@ #.var_bindings) (var::get id))
- (#.Some _)
- (#try.Success [(update@ #.var_bindings (var::put id (#.Some type)) context)
- []])
-
- _
- (exception.throw ..unknown_type_var id))))
-
-(def: #export var
- (Check [Var Type])
- (function (_ context)
- (let [id (get@ #.var_counter context)]
- (#try.Success [(|> context
- (update@ #.var_counter inc)
- (update@ #.var_bindings (var::new id)))
- [id (#.Var id)]]))))
-
-(def: (apply_type! funcT argT)
- (-> Type Type (Check Type))
- (case funcT
- (#.Var func_id)
- (do ..monad
- [?funcT' (read func_id)]
- (case ?funcT'
- (#.Some funcT')
- (apply_type! funcT' argT)
-
- _
- (throw ..invalid_type_application [funcT argT])))
-
- (#.Apply argT' funcT')
- (do ..monad
- [funcT'' (apply_type! funcT' argT')]
- (apply_type! funcT'' argT))
-
- _
- (case (//.apply (list argT) funcT)
- (#.Some output)
- (check\wrap output)
-
- _
- (throw ..invalid_type_application [funcT argT]))))
-
-(type: Ring
- (Set Var))
-
-(def: empty_ring
- Ring
- (set.new n.hash))
-
-## TODO: Optimize this by not using sets anymore.
-(def: (ring start)
- (-> Var (Check Ring))
- (function (_ context)
- (loop [current start
- output (set.add start empty_ring)]
- (case (|> context (get@ #.var_bindings) (var::get current))
- (#.Some (#.Some type))
- (case type
- (#.Var post)
- (if (!n\= start post)
- (#try.Success [context output])
- (recur post (set.add post output)))
-
- _
- (#try.Success [context empty_ring]))
-
- (#.Some #.None)
- (#try.Success [context output])
-
- #.None
- (exception.throw ..unknown_type_var current)))))
-
-(def: #export fresh_context
- Type_Context
- {#.var_counter 0
- #.ex_counter 0
- #.var_bindings (list)})
-
-(def: (attempt op)
- (All [a] (-> (Check a) (Check (Maybe a))))
- (function (_ context)
- (case (op context)
- (#try.Success [context' output])
- (#try.Success [context' (#.Some output)])
-
- (#try.Failure _)
- (#try.Success [context #.None]))))
-
-(def: (either left right)
- (All [a] (-> (Check a) (Check a) (Check a)))
- (function (_ context)
- (case (left context)
- (#try.Failure _)
- (right context)
-
- output
- output)))
-
-(def: (assumed? [e a] assumptions)
- (-> Assumption (List Assumption) Bit)
- (list.any? (function (_ [e' a'])
- (and (//\= e e')
- (//\= a a')))
- assumptions))
-
-(def: (assume! assumption assumptions)
- (-> Assumption (List Assumption) (List Assumption))
- (#.Cons assumption assumptions))
-
-## TODO: "if_bind" can be optimized...
-(def: (if_bind id type then else)
- (All [a]
- (-> Var Type (Check a) (-> Type (Check a))
- (Check a)))
- ($_ either
- (do ..monad
- [_ (..bind type id)]
- then)
- (do {! ..monad}
- [ring (..ring id)
- _ (assert "" (n.> 1 (set.size ring)))
- _ (monad.map ! (update type) (set.to_list ring))]
- then)
- (do ..monad
- [?bound (read id)]
- (else (maybe.default (#.Var id) ?bound)))))
-
-## TODO: "link_2" can be optimized...
-(def: (link_2 left right)
- (-> Var Var (Check Any))
- (do ..monad
- [_ (..bind (#.Var right) left)]
- (..bind (#.Var left) right)))
-
-## TODO: "link_3" can be optimized...
-(def: (link_3 interpose to from)
- (-> Var Var Var (Check Any))
- (do ..monad
- [_ (update (#.Var interpose) from)]
- (update (#.Var to) interpose)))
-
-## TODO: "check_vars" can be optimized...
-(def: (check_vars check' assumptions idE idA)
- (-> (Checker Type) (Checker Var))
- (if (!n\= idE idA)
- (check\wrap assumptions)
- (do {! ..monad}
- [ebound (attempt (peek idE))
- abound (attempt (peek idA))]
- (case [ebound abound]
- ## Link the 2 variables circularly
- [#.None #.None]
- (do !
- [_ (link_2 idE idA)]
- (wrap assumptions))
-
- ## Interpose new variable between 2 existing links
- [(#.Some etype) #.None]
- (case etype
- (#.Var targetE)
- (do !
- [_ (link_3 idA targetE idE)]
- (wrap assumptions))
-
- _
- (check' assumptions etype (#.Var idA)))
-
- ## Interpose new variable between 2 existing links
- [#.None (#.Some atype)]
- (case atype
- (#.Var targetA)
- (do !
- [_ (link_3 idE targetA idA)]
- (wrap assumptions))
-
- _
- (check' assumptions (#.Var idE) atype))
-
- [(#.Some etype) (#.Some atype)]
- (case [etype atype]
- [(#.Var targetE) (#.Var targetA)]
- (do !
- [ringE (..ring idE)
- ringA (..ring idA)]
- (if (\ set.equivalence = ringE ringA)
- (wrap assumptions)
- ## Fuse 2 rings
- (do !
- [_ (monad.fold ! (function (_ interpose to)
- (do !
- [_ (link_3 interpose to idE)]
- (wrap interpose)))
- targetE
- (set.to_list ringA))]
- (wrap assumptions))))
-
- (^template [<pattern> <id> <type>]
- [<pattern>
- (do !
- [ring (..ring <id>)
- _ (monad.map ! (update <type>) (set.to_list ring))]
- (wrap assumptions))])
- ([[(#.Var _) _] idE atype]
- [[_ (#.Var _)] idA etype])
-
- _
- (check' assumptions etype atype))))))
-
-(def: silent_failure!
- (All [a] (Check a))
- (..fail ""))
-
-## TODO: "check_apply" can be optimized...
-(def: (check_apply check' assumptions expected actual)
- (-> (Checker Type) (Checker [Type Type]))
- (let [[expected_input expected_function] expected
- [actual_input actual_function] actual]
- (case [expected_function actual_function]
- [(#.Ex exE) (#.Ex exA)]
- (if (!n\= exE exA)
- (check' assumptions expected_input actual_input)
- ..silent_failure!)
-
- [(#.UnivQ _ _) (#.Ex _)]
- (do ..monad
- [expected' (apply_type! expected_function expected_input)]
- (check' assumptions expected' (#.Apply actual)))
-
- [(#.Ex _) (#.UnivQ _ _)]
- (do ..monad
- [actual' (apply_type! actual_function actual_input)]
- (check' assumptions (#.Apply expected) actual'))
-
- [(#.Apply [expected_input' expected_function']) (#.Ex _)]
- (do ..monad
- [expected_function'' (apply_type! expected_function' expected_input')]
- (check' assumptions (#.Apply [expected_input expected_function'']) (#.Apply actual)))
-
- [(#.Ex _) (#.Apply [actual_input' actual_function'])]
- (do ..monad
- [actual_function'' (apply_type! actual_function' actual_input')]
- (check' assumptions (#.Apply expected) (#.Apply [actual_input actual_function''])))
-
- (^or [(#.Ex _) _] [_ (#.Ex _)])
- (do ..monad
- [assumptions (check' assumptions expected_function actual_function)]
- (check' assumptions expected_input actual_input))
-
- [(#.Var id) _]
- (function (_ context)
- (case ((do ..monad
- [expected_function' (..read! id)]
- (check' assumptions (#.Apply expected_input expected_function') (#.Apply actual)))
- context)
- (#try.Success output)
- (#try.Success output)
-
- (#try.Failure _)
- (case actual_function
- (#.UnivQ _ _)
- ((do ..monad
- [actual' (apply_type! actual_function actual_input)]
- (check' assumptions (#.Apply expected) actual'))
- context)
-
- (#.Ex exA)
- ((do ..monad
- [assumptions (check' assumptions expected_function actual_function)]
- (check' assumptions expected_input actual_input))
- context)
-
- _
- ((do ..monad
- [assumptions (check' assumptions expected_function actual_function)
- expected' (apply_type! actual_function expected_input)
- actual' (apply_type! actual_function actual_input)]
- (check' assumptions expected' actual'))
- context))))
-
- [_ (#.Var id)]
- (function (_ context)
- (case ((do ..monad
- [actual_function' (read! id)]
- (check' assumptions (#.Apply expected) (#.Apply actual_input actual_function')))
- context)
- (#try.Success output)
- (#try.Success output)
-
- _
- ((do ..monad
- [assumptions (check' assumptions expected_function actual_function)
- expected' (apply_type! expected_function expected_input)
- actual' (apply_type! expected_function actual_input)]
- (check' assumptions expected' actual'))
- context)))
-
- _
- ..silent_failure!)))
-
-(def: (with exception parameter check)
- (All [e a] (-> (Exception e) e (Check a) (Check a)))
- (|>> check (exception.with exception parameter)))
-
-## TODO: "check'" can be optimized...
-(def: (check' assumptions expected actual)
- {#.doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."}
- (Checker Type)
- (if (for {@.php false} ## TODO: Remove this once JPHP is gone.
- (is? expected actual))
- (check\wrap assumptions)
- (with ..type_check_failed [expected actual]
- (case [expected actual]
- [(#.Var idE) (#.Var idA)]
- (check_vars check' assumptions idE idA)
-
- [(#.Var id) _]
- (if_bind id actual
- (check\wrap assumptions)
- (function (_ bound)
- (check' assumptions bound actual)))
-
- [_ (#.Var id)]
- (if_bind id expected
- (check\wrap assumptions)
- (function (_ bound)
- (check' assumptions expected bound)))
-
- (^template [<fE> <fA>]
- [[(#.Apply aE <fE>) (#.Apply aA <fA>)]
- (check_apply check' assumptions [aE <fE>] [aA <fA>])])
- ([F1 (#.Ex ex)]
- [(#.Ex exE) fA]
- [fE (#.Var idA)]
- [(#.Var idE) fA])
-
- [(#.Apply A F) _]
- (let [new_assumption [expected actual]]
- (if (assumed? new_assumption assumptions)
- (check\wrap assumptions)
- (do ..monad
- [expected' (apply_type! F A)]
- (check' (assume! new_assumption assumptions) expected' actual))))
-
- [_ (#.Apply A F)]
- (do ..monad
- [actual' (apply_type! F A)]
- (check' assumptions expected actual'))
-
- ## TODO: Refactor-away as cold-code
- (^template [<tag> <instancer>]
- [[(<tag> _) _]
- (do ..monad
- [[_ paramT] <instancer>
- expected' (apply_type! expected paramT)]
- (check' assumptions expected' actual))])
- ([#.UnivQ ..existential]
- [#.ExQ ..var])
-
- ## TODO: Refactor-away as cold-code
- (^template [<tag> <instancer>]
- [[_ (<tag> _)]
- (do ..monad
- [[_ paramT] <instancer>
- actual' (apply_type! actual paramT)]
- (check' assumptions expected actual'))])
- ([#.UnivQ ..var]
- [#.ExQ ..existential])
-
- [(#.Primitive e_name e_params) (#.Primitive a_name a_params)]
- (if (!text\= e_name a_name)
- (loop [assumptions assumptions
- e_params e_params
- a_params a_params]
- (case [e_params a_params]
- [#.Nil #.Nil]
- (check\wrap assumptions)
-
- [(#.Cons e_head e_tail) (#.Cons a_head a_tail)]
- (do ..monad
- [assumptions' (check' assumptions e_head a_head)]
- (recur assumptions' e_tail a_tail))
-
- _
- ..silent_failure!))
- ..silent_failure!)
-
- (^template [<compose>]
- [[(<compose> eL eR) (<compose> aL aR)]
- (do ..monad
- [assumptions (check' assumptions eL aL)]
- (check' assumptions eR aR))])
- ([#.Sum]
- [#.Product])
-
- [(#.Function eI eO) (#.Function aI aO)]
- (do ..monad
- [assumptions (check' assumptions aI eI)]
- (check' assumptions eO aO))
-
- [(#.Ex e!id) (#.Ex a!id)]
- (if (!n\= e!id a!id)
- (check\wrap assumptions)
- ..silent_failure!)
-
- [(#.Named _ ?etype) _]
- (check' assumptions ?etype actual)
-
- [_ (#.Named _ ?atype)]
- (check' assumptions expected ?atype)
-
- _
- ..silent_failure!))))
-
-(def: #export (check expected actual)
- {#.doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."}
- (-> Type Type (Check Any))
- (check' (list) expected actual))
-
-(def: #export (checks? expected actual)
- {#.doc "A simple type-checking function that just returns a yes/no answer."}
- (-> Type Type Bit)
- (case (..run ..fresh_context (..check' (list) expected actual))
- (#try.Failure _)
- false
-
- (#try.Success _)
- true))
-
-(def: #export context
- (Check Type_Context)
- (function (_ context)
- (#try.Success [context context])))
-
-(def: #export (clean inputT)
- (-> Type (Check Type))
- (case inputT
- (#.Primitive name paramsT+)
- (|> paramsT+
- (monad.map ..monad clean)
- (check\map (|>> (#.Primitive name))))
-
- (^or (#.Parameter _) (#.Ex _) (#.Named _))
- (check\wrap inputT)
-
- (^template [<tag>]
- [(<tag> leftT rightT)
- (do ..monad
- [leftT' (clean leftT)]
- (|> (clean rightT)
- (check\map (|>> (<tag> leftT')))))])
- ([#.Sum] [#.Product] [#.Function] [#.Apply])
-
- (#.Var id)
- (do ..monad
- [?actualT (read id)]
- (case ?actualT
- (#.Some actualT)
- (clean actualT)
-
- _
- (wrap inputT)))
-
- (^template [<tag>]
- [(<tag> envT+ unquantifiedT)
- (do {! ..monad}
- [envT+' (monad.map ! clean envT+)]
- (wrap (<tag> envT+' unquantifiedT)))])
- ([#.UnivQ] [#.ExQ])
- ))
diff --git a/stdlib/source/lux/type/dynamic.lux b/stdlib/source/lux/type/dynamic.lux
deleted file mode 100644
index 754e682f2..000000000
--- a/stdlib/source/lux/type/dynamic.lux
+++ /dev/null
@@ -1,50 +0,0 @@
-(.module:
- [lux #*
- ["." debug]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- [text
- ["%" format]]]
- [macro (#+ with_gensyms)
- ["." syntax (#+ syntax:)]]
- ["." type
- abstract]])
-
-(exception: #export (wrong_type {expected Type} {actual Type})
- (exception.report
- ["Expected" (%.type expected)]
- ["Actual" (%.type actual)]))
-
-(abstract: #export Dynamic
- [Type Any]
-
- {#.doc "A value coupled with its type, so it can be checked later."}
-
- (def: abstraction (-> [Type Any] Dynamic) (|>> :abstraction))
- (def: representation (-> Dynamic [Type Any]) (|>> :representation))
-
- (syntax: #export (:dynamic value)
- {#.doc (doc (: Dynamic
- (:dynamic 123)))}
- (with_gensyms [g!value]
- (wrap (list (` (let [(~ g!value) (~ value)]
- ((~! ..abstraction) [(:of (~ g!value)) (~ g!value)])))))))
-
- (syntax: #export (:check type value)
- {#.doc (doc (: (try.Try Nat)
- (:check Nat (:dynamic 123))))}
- (with_gensyms [g!type g!value]
- (wrap (list (` (let [[(~ g!type) (~ g!value)] ((~! ..representation) (~ value))]
- (: ((~! try.Try) (~ type))
- (if (\ (~! type.equivalence) (~' =)
- (.type (~ type)) (~ g!type))
- (#try.Success (:as (~ type) (~ g!value)))
- ((~! exception.throw) ..wrong_type [(.type (~ type)) (~ g!type)])))))))))
-
- (def: #export (format value)
- (-> Dynamic (Try Text))
- (let [[type value] (:representation value)]
- (debug.represent type value)))
- )
diff --git a/stdlib/source/lux/type/implicit.lux b/stdlib/source/lux/type/implicit.lux
deleted file mode 100644
index 14f2ac441..000000000
--- a/stdlib/source/lux/type/implicit.lux
+++ /dev/null
@@ -1,400 +0,0 @@
-(.module:
- [lux #*
- [abstract
- ["." monad (#+ Monad do)]
- ["eq" equivalence]]
- [control
- ["." try]
- ["p" parser
- ["s" code (#+ Parser)]]]
- [data
- ["." product]
- ["." maybe]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." monad fold)]
- ["." dictionary (#+ Dictionary)]]]
- ["." macro
- ["." code]
- [syntax (#+ syntax:)]]
- [math
- ["." number
- ["n" nat]]]
- ["." meta
- ["." annotation]]
- ["." type
- ["." check (#+ Check)]]])
-
-(def: (find_type_var id env)
- (-> Nat Type_Context (Meta Type))
- (case (list.find (|>> product.left (n.= id))
- (get@ #.var_bindings env))
- (#.Some [_ (#.Some type)])
- (case type
- (#.Var id')
- (find_type_var id' env)
-
- _
- (\ meta.monad wrap type))
-
- (#.Some [_ #.None])
- (meta.fail (format "Unbound type-var " (%.nat id)))
-
- #.None
- (meta.fail (format "Unknown type-var " (%.nat id)))
- ))
-
-(def: (resolve_type var_name)
- (-> Name (Meta Type))
- (do meta.monad
- [raw_type (meta.find_type var_name)
- compiler meta.get_compiler]
- (case raw_type
- (#.Var id)
- (find_type_var id (get@ #.type_context compiler))
-
- _
- (wrap raw_type))))
-
-(def: (find_member_type idx sig_type)
- (-> Nat Type (Check Type))
- (case sig_type
- (#.Named _ sig_type')
- (find_member_type idx sig_type')
-
- (#.Apply arg func)
- (case (type.apply (list arg) func)
- #.None
- (check.fail (format "Cannot apply type " (%.type func) " to type " (%.type arg)))
-
- (#.Some sig_type')
- (find_member_type idx sig_type'))
-
- (#.Product left right)
- (if (n.= 0 idx)
- (\ check.monad wrap left)
- (find_member_type (dec idx) right))
-
- _
- (if (n.= 0 idx)
- (\ check.monad wrap sig_type)
- (check.fail (format "Cannot find member type " (%.nat idx) " for " (%.type sig_type))))))
-
-(def: (find_member_name member)
- (-> Name (Meta Name))
- (case member
- ["" simple_name]
- (meta.either (do meta.monad
- [member (meta.normalize member)
- _ (meta.resolve_tag member)]
- (wrap member))
- (do {! meta.monad}
- [this_module_name meta.current_module_name
- imp_mods (meta.imported_modules this_module_name)
- tag_lists (monad.map ! meta.tag_lists imp_mods)
- #let [tag_lists (|> tag_lists list\join (list\map product.left) list\join)
- candidates (list.filter (|>> product.right (text\= simple_name))
- tag_lists)]]
- (case candidates
- #.Nil
- (meta.fail (format "Unknown tag: " (%.name member)))
-
- (#.Cons winner #.Nil)
- (wrap winner)
-
- _
- (meta.fail (format "Too many candidate tags: " (%.list %.name candidates))))))
-
- _
- (\ meta.monad wrap member)))
-
-(def: (resolve_member member)
- (-> Name (Meta [Nat Type]))
- (do meta.monad
- [member (find_member_name member)
- [idx tag_list sig_type] (meta.resolve_tag member)]
- (wrap [idx sig_type])))
-
-(def: (prepare_definitions source_module target_module constants aggregate)
- (-> Text Text (List [Text Definition]) (-> (List [Name Type]) (List [Name Type])))
- (list\fold (function (_ [name [exported? def_type def_anns def_value]] aggregate)
- (if (and (annotation.implementation? def_anns)
- (or (text\= target_module source_module)
- exported?))
- (#.Cons [[source_module name] def_type] aggregate)
- aggregate))
- aggregate
- constants))
-
-(def: local_env
- (Meta (List [Name Type]))
- (do meta.monad
- [local_batches meta.locals
- #let [total_locals (list\fold (function (_ [name type] table)
- (try.default table (dictionary.try_put name type table)))
- (: (Dictionary Text Type)
- (dictionary.new text.hash))
- (list\join local_batches))]]
- (wrap (|> total_locals
- dictionary.entries
- (list\map (function (_ [name type]) [["" name] type]))))))
-
-(def: local_structs
- (Meta (List [Name Type]))
- (do {! meta.monad}
- [this_module_name meta.current_module_name
- definitions (meta.definitions this_module_name)]
- (wrap (prepare_definitions this_module_name this_module_name definitions #.Nil))))
-
-(def: imported_structs
- (Meta (List [Name Type]))
- (do {! meta.monad}
- [this_module_name meta.current_module_name
- imported_modules (meta.imported_modules this_module_name)
- accessible_definitions (monad.map ! meta.definitions imported_modules)]
- (wrap (list\fold (function (_ [imported_module definitions] tail)
- (prepare_definitions imported_module this_module_name definitions tail))
- #.Nil
- (list.zip/2 imported_modules accessible_definitions)))))
-
-(def: (apply_function_type func arg)
- (-> Type Type (Check Type))
- (case func
- (#.Named _ func')
- (apply_function_type func' arg)
-
- (#.UnivQ _)
- (do check.monad
- [[id var] check.var]
- (apply_function_type (maybe.assume (type.apply (list var) func))
- arg))
-
- (#.Function input output)
- (do check.monad
- [_ (check.check input arg)]
- (wrap output))
-
- _
- (check.fail (format "Invalid function type: " (%.type func)))))
-
-(def: (concrete_type type)
- (-> Type (Check [(List Nat) Type]))
- (case type
- (#.UnivQ _)
- (do check.monad
- [[id var] check.var
- [ids final_output] (concrete_type (maybe.assume (type.apply (list var) type)))]
- (wrap [(#.Cons id ids)
- final_output]))
-
- _
- (\ check.monad wrap [(list) type])))
-
-(def: (check_apply member_type input_types output_type)
- (-> Type (List Type) Type (Check []))
- (do check.monad
- [member_type' (monad.fold check.monad
- (function (_ input member)
- (apply_function_type member input))
- member_type
- input_types)]
- (check.check output_type member_type')))
-
-(type: #rec Instance
- {#constructor Name
- #dependencies (List Instance)})
-
-(def: (test_provision provision context dep alts)
- (-> (-> Lux Type_Context Type (Check Instance))
- Type_Context Type (List [Name Type])
- (Meta (List Instance)))
- (do meta.monad
- [compiler meta.get_compiler]
- (case (|> alts
- (list\map (function (_ [alt_name alt_type])
- (case (check.run context
- (do {! check.monad}
- [[tvars alt_type] (concrete_type alt_type)
- #let [[deps alt_type] (type.flatten_function alt_type)]
- _ (check.check dep alt_type)
- context' check.context
- =deps (monad.map ! (provision compiler context') deps)]
- (wrap =deps)))
- (#.Left error)
- (list)
-
- (#.Right =deps)
- (list [alt_name =deps]))))
- list\join)
- #.Nil
- (meta.fail (format "No candidates for provisioning: " (%.type dep)))
-
- found
- (wrap found))))
-
-(def: (provision compiler context dep)
- (-> Lux Type_Context Type (Check Instance))
- (case (meta.run compiler
- ($_ meta.either
- (do meta.monad [alts ..local_env] (..test_provision provision context dep alts))
- (do meta.monad [alts ..local_structs] (..test_provision provision context dep alts))
- (do meta.monad [alts ..imported_structs] (..test_provision provision context dep alts))))
- (#.Left error)
- (check.fail error)
-
- (#.Right candidates)
- (case candidates
- #.Nil
- (check.fail (format "No candidates for provisioning: " (%.type dep)))
-
- (#.Cons winner #.Nil)
- (\ check.monad wrap winner)
-
- _
- (check.fail (format "Too many candidates for provisioning: " (%.type dep) " --- " (%.list (|>> product.left %.name) candidates))))
- ))
-
-(def: (test_alternatives sig_type member_idx input_types output_type alts)
- (-> Type Nat (List Type) Type (List [Name Type]) (Meta (List Instance)))
- (do meta.monad
- [compiler meta.get_compiler
- context meta.type_context]
- (case (|> alts
- (list\map (function (_ [alt_name alt_type])
- (case (check.run context
- (do {! check.monad}
- [[tvars alt_type] (concrete_type alt_type)
- #let [[deps alt_type] (type.flatten_function alt_type)]
- _ (check.check alt_type sig_type)
- member_type (find_member_type member_idx alt_type)
- _ (check_apply member_type input_types output_type)
- context' check.context
- =deps (monad.map ! (provision compiler context') deps)]
- (wrap =deps)))
- (#.Left error)
- (list)
-
- (#.Right =deps)
- (list [alt_name =deps]))))
- list\join)
- #.Nil
- (meta.fail (format "No alternatives for " (%.type (type.function input_types output_type))))
-
- found
- (wrap found))))
-
-(def: (find_alternatives sig_type member_idx input_types output_type)
- (-> Type Nat (List Type) Type (Meta (List Instance)))
- (let [test (test_alternatives sig_type member_idx input_types output_type)]
- ($_ meta.either
- (do meta.monad [alts ..local_env] (test alts))
- (do meta.monad [alts ..local_structs] (test alts))
- (do meta.monad [alts ..imported_structs] (test alts)))))
-
-(def: (var? input)
- (-> Code Bit)
- (case input
- [_ (#.Identifier _)]
- #1
-
- _
- #0))
-
-(def: (join_pair [l r])
- (All [a] (-> [a a] (List a)))
- (list l r))
-
-(def: (instance$ [constructor dependencies])
- (-> Instance Code)
- (case dependencies
- #.Nil
- (code.identifier constructor)
-
- _
- (` ((~ (code.identifier constructor)) (~+ (list\map instance$ dependencies))))))
-
-(syntax: #export (\\
- {member s.identifier}
- {args (p.or (p.and (p.some s.identifier) s.end!)
- (p.and (p.some s.any) s.end!))})
- {#.doc (doc "Automatic implementation selection (for type-class style polymorphism)."
- "This feature layers type-class style polymorphism on top of Lux's signatures and implementations."
- "When calling a polymorphic function, or using a polymorphic constant,"
- "this macro will check the types of the arguments, and the expected type for the whole expression"
- "and it will search in the local scope, the module's scope and the imports' scope"
- "in order to find suitable implementations to satisfy those requirements."
- "If a single alternative is found, that one will be used automatically."
- "If no alternative is found, or if more than one alternative is found (ambiguity)"
- "a compile-time error will be raised, to alert the user."
- "Examples:"
- "Nat equivalence"
- (\ number.equivalence = x y)
- (\\ = x y)
- "Can optionally add the prefix of the module where the signature was defined."
- (\\ eq.= x y)
- "(List Nat) equivalence"
- (\\ =
- (list.indices 10)
- (list.indices 10))
- "(Functor List) map"
- (\\ map inc (list.indices 10))
- "Caveat emptor: You need to make sure to import the module of any implementation you want to use."
- "Otherwise, this macro will not find it.")}
- (case args
- (#.Left [args _])
- (do {! meta.monad}
- [[member_idx sig_type] (resolve_member member)
- input_types (monad.map ! resolve_type args)
- output_type meta.expected_type
- chosen_ones (find_alternatives sig_type member_idx input_types output_type)]
- (case chosen_ones
- #.Nil
- (meta.fail (format "No implementation could be found for member: " (%.name member)))
-
- (#.Cons chosen #.Nil)
- (wrap (list (` (\ (~ (instance$ chosen))
- (~ (code.local_identifier (product.right member)))
- (~+ (list\map code.identifier args))))))
-
- _
- (meta.fail (format "Too many implementations available: "
- (|> chosen_ones
- (list\map (|>> product.left %.name))
- (text.join_with ", "))
- " --- for type: " (%.type sig_type)))))
-
- (#.Right [args _])
- (do {! meta.monad}
- [labels (|> (macro.gensym "") (list.repeat (list.size args)) (monad.seq !))]
- (wrap (list (` (let [(~+ (|> (list.zip/2 labels args) (list\map join_pair) list\join))]
- (..\\ (~ (code.identifier member)) (~+ labels)))))))
- ))
-
-(def: (implicit_bindings amount)
- (-> Nat (Meta (List Code)))
- (|> (macro.gensym "g!implicit")
- (list.repeat amount)
- (monad.seq meta.monad)))
-
-(def: implicits
- (Parser (List Code))
- (s.tuple (p.many s.any)))
-
-(syntax: #export (with {implementations ..implicits} body)
- (do meta.monad
- [g!implicit+ (implicit_bindings (list.size implementations))]
- (wrap (list (` (let [(~+ (|> (list.zip/2 g!implicit+ implementations)
- (list\map (function (_ [g!implicit implementation])
- (list g!implicit implementation)))
- list\join))]
- (~ body)))))))
-
-(syntax: #export (implicit: {implementations ..implicits})
- (do meta.monad
- [g!implicit+ (implicit_bindings (list.size implementations))]
- (wrap (|> (list.zip/2 g!implicit+ implementations)
- (list\map (function (_ [g!implicit implementation])
- (` (def: (~ g!implicit)
- {#.implementation? #1}
- (~ implementation)))))))))
diff --git a/stdlib/source/lux/type/quotient.lux b/stdlib/source/lux/type/quotient.lux
deleted file mode 100644
index dd47b6bf3..000000000
--- a/stdlib/source/lux/type/quotient.lux
+++ /dev/null
@@ -1,55 +0,0 @@
-(.module:
- [lux (#- type)
- [abstract
- [equivalence (#+ Equivalence)]]
- [macro (#+ with_gensyms)
- [syntax (#+ syntax:)]]
- ["." type
- abstract]])
-
-(abstract: #export (Class t c %)
- (-> t c)
-
- (def: #export class
- (All [t c]
- (Ex [%]
- (-> (-> t c) (Class t c %))))
- (|>> :abstraction))
-
- (abstract: #export (Quotient t c %)
- {#value t
- #label c}
-
- (def: #export (quotient class value)
- (All [t c %]
- (-> (Class t c %) t
- (Quotient t c %)))
- (:abstraction {#value value
- #label ((:representation Class class) value)}))
-
- (template [<name> <output> <slot>]
- [(def: #export <name>
- (All [t c %] (-> (Quotient t c %) <output>))
- (|>> :representation (get@ <slot>)))]
-
- [value t #value]
- [label c #label]
- )
- )
- )
-
-(syntax: #export (type class)
- (with_gensyms [g!t g!c g!%]
- (wrap (list (` ((~! type.:by_example)
- [(~ g!t) (~ g!c) (~ g!%)]
-
- (..Class (~ g!t) (~ g!c) (~ g!%))
- (~ class)
-
- (..Quotient (~ g!t) (~ g!c) (~ g!%))))))))
-
-(implementation: #export (equivalence super)
- (All [t c %] (-> (Equivalence c) (Equivalence (..Quotient t c %))))
-
- (def: (= reference sample)
- (\ super = (..label reference) (..label sample))))
diff --git a/stdlib/source/lux/type/refinement.lux b/stdlib/source/lux/type/refinement.lux
deleted file mode 100644
index 5bbc90149..000000000
--- a/stdlib/source/lux/type/refinement.lux
+++ /dev/null
@@ -1,88 +0,0 @@
-(.module:
- [lux (#- type)
- [abstract
- [predicate (#+ Predicate)]]
- ["." macro
- [syntax (#+ syntax:)]]
- ["." type
- abstract]])
-
-(abstract: #export (Refined t %)
- {#value t
- #predicate (Predicate t)}
-
- {#.doc "A refined type '%' of base type 't' using a predicate."}
-
- (type: #export (Refiner t %)
- (-> t (Maybe (Refined t %))))
-
- (def: #export (refinement predicate)
- (All [t]
- (Ex [%]
- (-> (Predicate t) (Refiner t %))))
- (function (_ un_refined)
- (if (predicate un_refined)
- (#.Some (:abstraction {#value un_refined
- #predicate predicate}))
- #.None)))
-
- (template [<name> <output> <slot>]
- [(def: #export <name>
- (All [t %] (-> (Refined t %) <output>))
- (|>> :representation (get@ <slot>)))]
-
- [un_refine t #value]
- [predicate (Predicate t) #predicate]
- )
-
- (def: #export (lift transform)
- (All [t %]
- (-> (-> t t)
- (-> (Refined t %) (Maybe (Refined t %)))))
- (function (_ refined)
- (let [(^slots [#value #predicate]) (:representation refined)
- value' (transform value)]
- (if (predicate value')
- (#.Some (:abstraction {#value value'
- #predicate predicate}))
- #.None))))
- )
-
-(def: #export (filter refiner values)
- (All [t %] (-> (Refiner t %) (List t) (List (Refined t %))))
- (case values
- #.Nil
- #.Nil
-
- (#.Cons head tail)
- (case (refiner head)
- (#.Some refined)
- (#.Cons refined (filter refiner tail))
-
- #.None
- (filter refiner tail))))
-
-(def: #export (partition refiner values)
- (All [t %] (-> (Refiner t %) (List t) [(List (Refined t %)) (List t)]))
- (case values
- #.Nil
- [#.Nil #.Nil]
-
- (#.Cons head tail)
- (let [[yes no] (partition refiner tail)]
- (case (refiner head)
- (#.Some refined)
- [(#.Cons refined yes)
- no]
-
- #.None
- [yes
- (#.Cons head no)]))))
-
-(syntax: #export (type refiner)
- (macro.with_gensyms [g!t g!%]
- (wrap (list (` ((~! type.:by_example) [(~ g!t) (~ g!%)]
- (..Refiner (~ g!t) (~ g!%))
- (~ refiner)
-
- (..Refined (~ g!t) (~ g!%))))))))
diff --git a/stdlib/source/lux/type/resource.lux b/stdlib/source/lux/type/resource.lux
deleted file mode 100644
index acad33a71..000000000
--- a/stdlib/source/lux/type/resource.lux
+++ /dev/null
@@ -1,217 +0,0 @@
-(.module:
- [lux #*
- ["." meta]
- [abstract
- ["." monad (#+ Monad do)
- [indexed (#+ IxMonad)]]]
- [control
- ["." exception (#+ exception:)]
- ["." io (#+ IO)]
- [concurrency
- ["." promise (#+ Promise)]]
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- ["." identity (#+ Identity)]
- ["." maybe]
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." set]
- ["." row (#+ Row)]
- ["." list ("#\." functor fold)]]]
- ["." macro
- [syntax (#+ syntax:)]]
- [math
- [number
- ["n" nat]]]
- [type
- abstract]])
-
-(type: #export (Procedure monad input output value)
- (-> input (monad [output value])))
-
-(type: #export (Linear monad value)
- (All [keys]
- (Procedure monad keys keys value)))
-
-(type: #export (Affine monad permissions value)
- (All [keys]
- (Procedure monad keys [permissions keys] value)))
-
-(type: #export (Relevant monad permissions value)
- (All [keys]
- (Procedure monad [permissions keys] keys value)))
-
-(implementation: (indexed Monad<m>)
- (All [m] (-> (Monad m) (IxMonad (Procedure m))))
-
- (def: (wrap value)
- (function (_ keys)
- (\ Monad<m> wrap [keys value])))
-
- (def: (bind f input)
- (function (_ keysI)
- (do Monad<m>
- [[keysT value] (input keysI)]
- ((f value) keysT)))))
-
-(template [<name> <m> <monad> <execute> <lift>]
- [(def: #export <name>
- (IxMonad (Procedure <m>))
- (..indexed <monad>))
-
- (def: #export (<execute> procedure)
- (All [v] (-> (Linear <m> v) (<m> v)))
- (do <monad>
- [[_ output] (procedure [])]
- (wrap output)))
-
- (def: #export (<lift> procedure)
- (All [v] (-> (<m> v) (Linear <m> v)))
- (function (_ keys)
- (do <monad>
- [output procedure]
- (wrap [keys output]))))]
-
- [pure Identity identity.monad run_pure lift_pure]
- [sync IO io.monad run_sync lift_sync]
- [async Promise promise.monad run_async lift_async]
- )
-
-(abstract: #export Ordered Any)
-
-(abstract: #export Commutative Any)
-
-(abstract: #export (Key mode key)
- Any
-
- (template [<name> <mode>]
- [(def: <name>
- (Ex [k] (-> Any (Key <mode> k)))
- (|>> :abstraction))]
-
- [ordered_key Ordered]
- [commutative_key Commutative]
- ))
-
-(abstract: #export (Res key value)
- value
-
- {#.doc "A value locked by a key."}
-
- (template [<name> <m> <monad> <mode> <key>]
- [(def: #export (<name> value)
- (All [v] (Ex [k] (-> v (Affine <m> (Key <mode> k) (Res k v)))))
- (function (_ keys)
- (\ <monad> wrap [[(<key> []) keys] (:abstraction value)])))]
-
- [ordered_pure Identity identity.monad Ordered ordered_key]
- [ordered_sync IO io.monad Ordered ordered_key]
- [ordered_async Promise promise.monad Ordered ordered_key]
- [commutative_sync IO io.monad Commutative commutative_key]
- [commutative_pure Identity identity.monad Commutative commutative_key]
- [commutative_async Promise promise.monad Commutative commutative_key]
- )
-
- (template [<name> <m> <monad>]
- [(def: #export (<name> resource)
- (All [v k m]
- (-> (Res k v) (Relevant <m> (Key m k) v)))
- (function (_ [key keys])
- (\ <monad> wrap [keys (:representation resource)])))]
-
- [read_pure Identity identity.monad]
- [read_sync IO io.monad]
- [read_async Promise promise.monad]
- ))
-
-(exception: #export (index_cannot_be_repeated {index Nat})
- (exception.report
- ["Index" (%.nat index)]))
-
-(exception: #export amount_cannot_be_zero)
-
-(def: indices
- (Parser (List Nat))
- (<code>.tuple (loop [seen (set.new n.hash)]
- (do {! <>.monad}
- [done? <code>.end?]
- (if done?
- (wrap (list))
- (do !
- [head <code>.nat
- _ (<>.assert (exception.construct ..index_cannot_be_repeated head)
- (not (set.member? seen head)))
- tail (recur (set.add head seen))]
- (wrap (list& head tail))))))))
-
-(def: (no_op Monad<m>)
- (All [m] (-> (Monad m) (Linear m Any)))
- (function (_ context)
- (\ Monad<m> wrap [context []])))
-
-(template [<name> <m> <monad>]
- [(syntax: #export (<name> {swaps ..indices})
- (macro.with_gensyms [g!_ g!context]
- (case swaps
- #.Nil
- (wrap (list (` ((~! no_op) <monad>))))
-
- (#.Cons head tail)
- (do {! meta.monad}
- [#let [max_idx (list\fold n.max head tail)]
- g!inputs (<| (monad.seq !) (list.repeat (inc max_idx)) (macro.gensym "input"))
- #let [g!outputs (|> (monad.fold maybe.monad
- (function (_ from to)
- (do maybe.monad
- [input (list.nth from g!inputs)]
- (wrap (row.add input to))))
- (: (Row Code) row.empty)
- swaps)
- maybe.assume
- row.to_list)
- g!inputsT+ (list\map (|>> (~) (..Key ..Commutative) (`)) g!inputs)
- g!outputsT+ (list\map (|>> (~) (..Key ..Commutative) (`)) g!outputs)]]
- (wrap (list (` (: (All [(~+ g!inputs) (~ g!context)]
- (Procedure (~! <m>)
- [(~+ g!inputsT+) (~ g!context)]
- [(~+ g!outputsT+) (~ g!context)]
- .Any))
- (function ((~ g!_) [(~+ g!inputs) (~ g!context)])
- (\ (~! <monad>) (~' wrap) [[(~+ g!outputs) (~ g!context)] []]))))))))))]
-
- [exchange_pure Identity identity.monad]
- [exchange_sync IO io.monad]
- [exchange_async Promise promise.monad]
- )
-
-(def: amount
- (Parser Nat)
- (do <>.monad
- [raw <code>.nat
- _ (<>.assert (exception.construct ..amount_cannot_be_zero [])
- (n.> 0 raw))]
- (wrap raw)))
-
-(template [<name> <m> <monad> <from> <to>]
- [(syntax: #export (<name> {amount ..amount})
- (macro.with_gensyms [g!_ g!context]
- (do {! meta.monad}
- [g!keys (<| (monad.seq !) (list.repeat amount) (macro.gensym "keys"))]
- (wrap (list (` (: (All [(~+ g!keys) (~ g!context)]
- (Procedure (~! <m>)
- [<from> (~ g!context)]
- [<to> (~ g!context)]
- .Any))
- (function ((~ g!_) [<from> (~ g!context)])
- (\ (~! <monad>) (~' wrap) [[<to> (~ g!context)] []])))))))))]
-
- [group_pure Identity identity.monad (~+ g!keys) [(~+ g!keys)]]
- [group_sync IO io.monad (~+ g!keys) [(~+ g!keys)]]
- [group_async Promise promise.monad (~+ g!keys) [(~+ g!keys)]]
- [un_group_pure Identity identity.monad [(~+ g!keys)] (~+ g!keys)]
- [un_group_sync IO io.monad [(~+ g!keys)] (~+ g!keys)]
- [un_group_async Promise promise.monad [(~+ g!keys)] (~+ g!keys)]
- )
diff --git a/stdlib/source/lux/type/unit.lux b/stdlib/source/lux/type/unit.lux
deleted file mode 100644
index ff0dfa645..000000000
--- a/stdlib/source/lux/type/unit.lux
+++ /dev/null
@@ -1,188 +0,0 @@
-## TODO: Write tests ASAP.
-(.module:
- [lux #*
- ["." meta]
- [abstract
- [monad (#+ Monad do)]
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]
- [enum (#+ Enum)]]
- [control
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- [text
- ["%" format (#+ format)]]]
- [macro
- ["." code]
- [syntax (#+ syntax:)
- ["|.|" export]
- ["|.|" annotations]]]
- [math
- [number
- ["n" nat]
- ["i" int]
- ["." ratio (#+ Ratio)]]]
- [type
- abstract]])
-
-(abstract: #export (Qty unit)
- Int
-
- (def: in
- (All [unit] (-> Int (Qty unit)))
- (|>> :abstraction))
-
- (def: out
- (All [unit] (-> (Qty unit) Int))
- (|>> :representation))
-
- (template [<name> <op>]
- [(def: #export (<name> param subject)
- (All [unit] (-> (Qty unit) (Qty unit) (Qty unit)))
- (:abstraction (<op> (:representation param)
- (:representation subject))))]
-
- [+ i.+]
- [- i.-]
- )
-
- (template [<name> <op> <p> <s> <p*s>]
- [(def: #export (<name> param subject)
- (All [p s] (-> (Qty <p>) (Qty <s>) (Qty <p*s>)))
- (:abstraction (<op> (:representation param)
- (:representation subject))))]
-
- [* i.* p s [p s]]
- [/ i./ p [p s] s]
- )
- )
-
-(interface: #export (Unit a)
- (: (-> Int (Qty a))
- in)
- (: (-> (Qty a) Int)
- out))
-
-(interface: #export (Scale s)
- (: (All [u] (-> (Qty u) (Qty (s u))))
- scale)
- (: (All [u] (-> (Qty (s u)) (Qty u)))
- de_scale)
- (: Ratio
- ratio))
-
-(type: #export Pure
- (Qty Any))
-
-(def: #export pure
- (-> Int Pure)
- ..in)
-
-(def: #export number
- (-> Pure Int)
- ..out)
-
-(syntax: #export (unit:
- {export |export|.parser}
- {type_name <code>.local_identifier}
- {unit_name <code>.local_identifier}
- {annotations (<>.default |annotations|.empty |annotations|.parser)})
- (do meta.monad
- [@ meta.current_module_name
- #let [g!type (code.local_identifier type_name)]]
- (wrap (list (` (type: (~+ (|export|.format export)) (~ g!type)
- (~ (|annotations|.format annotations))
- (primitive (~ (code.text (%.name [@ type_name]))))))
-
- (` (implementation: (~+ (|export|.format export)) (~ (code.local_identifier unit_name))
- (..Unit (~ g!type))
-
- (def: (~' in) (~! ..in))
- (def: (~' out) (~! ..out))))
- ))))
-
-(def: scale
- (Parser Ratio)
- (<code>.tuple (do <>.monad
- [numerator <code>.nat
- _ (<>.assert (format "Numerator must be positive: " (%.nat numerator))
- (n.> 0 numerator))
- denominator <code>.nat
- _ (<>.assert (format "Denominator must be positive: " (%.nat denominator))
- (n.> 0 denominator))]
- (wrap [numerator denominator]))))
-
-(syntax: #export (scale:
- {export |export|.parser}
- {type_name <code>.local_identifier}
- {scale_name <code>.local_identifier}
- {(^slots [#ratio.numerator #ratio.denominator]) ..scale}
- {annotations (<>.default |annotations|.empty |annotations|.parser)})
- (do meta.monad
- [@ meta.current_module_name
- #let [g!scale (code.local_identifier type_name)]]
- (wrap (list (` (type: (~+ (|export|.format export)) ((~ g!scale) (~' u))
- (~ (|annotations|.format annotations))
- (primitive (~ (code.text (%.name [@ type_name]))) [(~' u)])))
-
- (` (implementation: (~+ (|export|.format export)) (~ (code.local_identifier scale_name))
- (..Scale (~ g!scale))
-
- (def: (~' scale)
- (|>> ((~! ..out))
- (i.* (~ (code.int (.int numerator))))
- (i./ (~ (code.int (.int denominator))))
- ((~! ..in))))
- (def: (~' de_scale)
- (|>> ((~! ..out))
- (i.* (~ (code.int (.int denominator))))
- (i./ (~ (code.int (.int numerator))))
- ((~! ..in))))
- (def: (~' ratio)
- [(~ (code.nat numerator)) (~ (code.nat denominator))])))
- ))))
-
-(def: #export (re_scale from to quantity)
- (All [si so u] (-> (Scale si) (Scale so) (Qty (si u)) (Qty (so u))))
- (let [[numerator denominator] (ratio./ (\ from ratio)
- (\ to ratio))]
- (|> quantity
- out
- (i.* (.int numerator))
- (i./ (.int denominator))
- in)))
-
-(scale: #export Kilo kilo [1 1,000])
-(scale: #export Mega mega [1 1,000,000])
-(scale: #export Giga giga [1 1,000,000,000])
-
-(scale: #export Milli milli [ 1,000 1])
-(scale: #export Micro micro [ 1,000,000 1])
-(scale: #export Nano nano [1,000,000,000 1])
-
-(unit: #export Gram gram)
-(unit: #export Meter meter)
-(unit: #export Litre litre)
-(unit: #export Second second)
-
-(implementation: #export equivalence
- (All [unit] (Equivalence (Qty unit)))
-
- (def: (= reference sample)
- (i.= (..out reference) (..out sample))))
-
-(implementation: #export order
- (All [unit] (Order (Qty unit)))
-
- (def: &equivalence ..equivalence)
-
- (def: (< reference sample)
- (i.< (..out reference) (..out sample))))
-
-(implementation: #export enum
- (All [unit] (Enum (Qty unit)))
-
- (def: &order ..order)
- (def: succ (|>> ..out inc ..in))
- (def: pred (|>> ..out dec ..in)))
diff --git a/stdlib/source/lux/type/variance.lux b/stdlib/source/lux/type/variance.lux
deleted file mode 100644
index 863824e59..000000000
--- a/stdlib/source/lux/type/variance.lux
+++ /dev/null
@@ -1,11 +0,0 @@
-(.module:
- [lux #*])
-
-(type: #export (Co t)
- (-> Any t))
-
-(type: #export (Contra t)
- (-> t Any))
-
-(type: #export (In t)
- (-> t t))
diff --git a/stdlib/source/lux/world/console.lux b/stdlib/source/lux/world/console.lux
deleted file mode 100644
index 93842b99a..000000000
--- a/stdlib/source/lux/world/console.lux
+++ /dev/null
@@ -1,158 +0,0 @@
-(.module:
- [lux #*
- [ffi (#+ import:)]
- ["@" target]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." io (#+ IO io)]
- [concurrency
- ["." promise (#+ Promise)]
- ["." atom]]]
- [data
- ["." text (#+ Char)
- ["%" format (#+ format)]]]])
-
-(template [<name>]
- [(exception: #export (<name>)
- "")]
-
- [cannot_open]
- [cannot_close]
- )
-
-(interface: #export (Console !)
- (: (-> [] (! (Try Char)))
- read)
- (: (-> [] (! (Try Text)))
- read_line)
- (: (-> Text (! (Try Any)))
- write)
- (: (-> [] (! (Try Any)))
- close))
-
-(def: #export (async console)
- (-> (Console IO) (Console Promise))
- (`` (implementation
- (~~ (template [<capability>]
- [(def: <capability>
- (|>> (\ console <capability>) promise.future))]
-
- [read]
- [read_line]
- [write]
- [close])))))
-
-(with_expansions [<jvm> (as_is (import: java/lang/String)
-
- (import: java/io/Console
- ["#::."
- (readLine [] #io #try java/lang/String)])
-
- (import: java/io/InputStream
- ["#::."
- (read [] #io #try int)])
-
- (import: java/io/PrintStream
- ["#::."
- (print [java/lang/String] #io #try void)])
-
- (import: java/lang/System
- ["#::."
- (#static console [] #io #? java/io/Console)
- (#static in java/io/InputStream)
- (#static out java/io/PrintStream)])
-
- (def: #export default
- (IO (Try (Console IO)))
- (do io.monad
- [?jvm_console (java/lang/System::console)]
- (case ?jvm_console
- #.None
- (wrap (exception.throw ..cannot_open []))
-
- (#.Some jvm_console)
- (let [jvm_input (java/lang/System::in)
- jvm_output (java/lang/System::out)]
- (<| wrap
- exception.return
- (: (Console IO)) ## TODO: Remove ASAP
- (implementation
- (def: (read _)
- (|> jvm_input
- java/io/InputStream::read
- (\ (try.with io.monad) map .nat)))
-
- (def: (read_line _)
- (java/io/Console::readLine jvm_console))
-
- (def: (write message)
- (java/io/PrintStream::print message jvm_output))
-
- (def: close
- (|>> (exception.throw ..cannot_close) wrap)))))))))]
- (for {@.old (as_is <jvm>)
- @.jvm (as_is <jvm>)}
- (as_is)))
-
-(def: #export (write_line message console)
- (All [!] (-> Text (Console !) (! (Try Any))))
- (\ console write (format message text.new_line)))
-
-(interface: #export (Mock s)
- (: (-> s (Try [s Char]))
- on_read)
- (: (-> s (Try [s Text]))
- on_read_line)
- (: (-> Text s (Try s))
- on_write)
- (: (-> s (Try s))
- on_close))
-
-(def: #export (mock mock init)
- (All [s] (-> (Mock s) s (Console IO)))
- (let [state (atom.atom init)]
- (`` (implementation
- (~~ (template [<method> <mock>]
- [(def: (<method> _)
- (do {! io.monad}
- [|state| (atom.read state)]
- (case (\ mock <mock> |state|)
- (#try.Success [|state| output])
- (do !
- [_ (atom.write |state| state)]
- (wrap (#try.Success output)))
-
- (#try.Failure error)
- (wrap (#try.Failure error)))))]
-
- [read on_read]
- [read_line on_read_line]
- ))
-
- (def: (write input)
- (do {! io.monad}
- [|state| (atom.read state)]
- (case (\ mock on_write input |state|)
- (#try.Success |state|)
- (do !
- [_ (atom.write |state| state)]
- (wrap (#try.Success [])))
-
- (#try.Failure error)
- (wrap (#try.Failure error)))))
-
- (def: (close _)
- (do {! io.monad}
- [|state| (atom.read state)]
- (case (\ mock on_close |state|)
- (#try.Success |state|)
- (do !
- [_ (atom.write |state| state)]
- (wrap (#try.Success [])))
-
- (#try.Failure error)
- (wrap (#try.Failure error)))))
- ))))
diff --git a/stdlib/source/lux/world/db/jdbc.lux b/stdlib/source/lux/world/db/jdbc.lux
deleted file mode 100644
index 3dba77a8e..000000000
--- a/stdlib/source/lux/world/db/jdbc.lux
+++ /dev/null
@@ -1,175 +0,0 @@
-(.module:
- [lux (#- and int)
- [control
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- [monad (#+ Monad do)]
- ["." try (#+ Try)]
- ["ex" exception]
- [concurrency
- ["." promise (#+ Promise) ("#\." monad)]]
- [security
- ["!" capability (#+ capability:)]]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]]
- ["." io (#+ IO)]
- [world
- [net (#+ URL)]]
- [host (#+ import:)]]
- [//
- ["." sql]]
- ["." / #_
- ["#." input (#+ Input)]
- ["#." output (#+ Output)]])
-
-(import: java/lang/String)
-
-(import: java/sql/ResultSet
- (getRow [] #try int)
- (next [] #try boolean)
- (close [] #io #try void))
-
-(import: java/sql/Statement
- (#static NO_GENERATED_KEYS int)
- (#static RETURN_GENERATED_KEYS int)
- (getGeneratedKeys [] #try java/sql/ResultSet)
- (close [] #io #try void))
-
-(import: java/sql/PreparedStatement
- (executeUpdate [] #io #try int)
- (executeQuery [] #io #try java/sql/ResultSet))
-
-(import: java/sql/Connection
- (prepareStatement [java/lang/String int] #try java/sql/PreparedStatement)
- (isValid [int] #try boolean)
- (close [] #io #try void))
-
-(import: java/sql/DriverManager
- (#static getConnection [java/lang/String java/lang/String java/lang/String] #io #try java/sql/Connection))
-
-(type: #export Credentials
- {#url URL
- #user Text
- #password Text})
-
-(type: #export ID Int)
-
-(type: #export (Statement input)
- {#sql sql.Statement
- #input (Input input)
- #value input})
-
-(template [<name> <forge> <output>]
- [(capability: #export (<name> ! i)
- (<forge> (Statement i) (! (Try <output>))))]
-
- [Can-Execute can-execute Nat]
- [Can-Insert can-insert (List ID)]
- )
-
-(capability: #export (Can-Query ! i o)
- (can-query [(Statement i) (Output o)] (! (Try (List o)))))
-
-(capability: #export (Can-Close !)
- (can-close Any (! (Try Any))))
-
-(interface: #export (DB !)
- (: (Can-Execute !)
- execute)
- (: (Can-Insert !)
- insert)
- (: (Can-Query !)
- query)
- (: (Can-Close !)
- close))
-
-(def: (with-statement statement conn action)
- (All [i a]
- (-> (Statement i) java/sql/Connection
- (-> java/sql/PreparedStatement (IO (Try a)))
- (IO (Try a))))
- (do (try.with io.monad)
- [prepared (io.io (java/sql/Connection::prepareStatement (sql.sql (get@ #sql statement))
- (java/sql/Statement::RETURN_GENERATED_KEYS)
- conn))
- _ (io.io ((get@ #input statement) (get@ #value statement) [1 prepared]))
- result (action prepared)
- _ (java/sql/Statement::close prepared)]
- (wrap result)))
-
-(def: #export (async db)
- (-> (DB IO) (DB Promise))
- (`` (implementation
- (~~ (template [<name> <forge>]
- [(def: <name> (<forge> (|>> (!.use (\ db <name>)) promise.future)))]
-
- [execute can-execute]
- [insert can-insert]
- [close can-close]
- [query can-query])))))
-
-(def: #export (connect creds)
- (-> Credentials (IO (Try (DB IO))))
- (do (try.with io.monad)
- [connection (java/sql/DriverManager::getConnection (get@ #url creds)
- (get@ #user creds)
- (get@ #password creds))]
- (wrap (: (DB IO)
- (implementation
- (def: execute
- (..can-execute
- (function (execute statement)
- (with-statement statement connection
- (function (_ prepared)
- (do (try.with io.monad)
- [row-count (java/sql/PreparedStatement::executeUpdate prepared)]
- (wrap (.nat row-count))))))))
-
- (def: insert
- (..can-insert
- (function (insert statement)
- (with-statement statement connection
- (function (_ prepared)
- (do (try.with io.monad)
- [_ (java/sql/PreparedStatement::executeUpdate prepared)
- result-set (io.io (java/sql/Statement::getGeneratedKeys prepared))]
- (/output.rows /output.long result-set)))))))
-
- (def: close
- (..can-close
- (function (close _)
- (java/sql/Connection::close connection))))
-
- (def: query
- (..can-query
- (function (query [statement output])
- (with-statement statement connection
- (function (_ prepared)
- (do (try.with io.monad)
- [result-set (java/sql/PreparedStatement::executeQuery prepared)]
- (/output.rows output result-set)))))))
- )))))
-
-(def: #export (with-db creds action)
- (All [a]
- (-> Credentials
- (-> (DB IO) (IO (Try a)))
- (IO (Try a))))
- (do (try.with io.monad)
- [db (..connect creds)
- result (action db)
- _ (!.use (\ db close) [])]
- (wrap result)))
-
-(def: #export (with-async-db creds action)
- (All [a]
- (-> Credentials
- (-> (DB Promise) (Promise (Try a)))
- (Promise (Try a))))
- (do (try.with promise.monad)
- [db (promise.future (..connect creds))
- result (action (..async db))
- _ (promise\wrap (io.run (!.use (\ db close) [])))]
- (wrap result)))
diff --git a/stdlib/source/lux/world/db/jdbc/input.lux b/stdlib/source/lux/world/db/jdbc/input.lux
deleted file mode 100644
index 19f9e7422..000000000
--- a/stdlib/source/lux/world/db/jdbc/input.lux
+++ /dev/null
@@ -1,106 +0,0 @@
-(.module:
- [lux (#- and int)
- [ffi (#+ import:)]
- [control
- [functor (#+ Contravariant)]
- [monad (#+ Monad do)]
- ["." try (#+ Try)]]
- [time
- ["." instant (#+ Instant)]]
- ["." io (#+ IO)]
- [world
- [binary (#+ Binary)]]])
-
-(import: java/lang/String)
-
-(template [<class>]
- [(import: <class>
- (new [long]))]
-
- [java/sql/Date] [java/sql/Time] [java/sql/Timestamp]
- )
-
-(`` (import: java/sql/PreparedStatement
- (~~ (template [<name> <type>]
- [(<name> [int <type>] #try void)]
-
- [setBoolean boolean]
-
- [setByte byte]
- [setShort short]
- [setInt int]
- [setLong long]
-
- [setFloat float]
- [setDouble double]
-
- [setString java/lang/String]
- [setBytes [byte]]
-
- [setDate java/sql/Date]
- [setTime java/sql/Time]
- [setTimestamp java/sql/Timestamp]
- ))))
-
-(type: #export (Input a)
- (-> a [Nat java/sql/PreparedStatement]
- (Try [Nat java/sql/PreparedStatement])))
-
-(implementation: #export contravariant (Contravariant Input)
- (def: (map-1 f fb)
- (function (fa value circumstance)
- (fb (f value) circumstance))))
-
-(def: #export (and pre post)
- (All [l r] (-> (Input l) (Input r) (Input [l r])))
- (function (_ [left right] context)
- (do try.monad
- [context (pre left context)]
- (post right context))))
-
-(def: #export (fail error)
- (All [a] (-> Text (Input a)))
- (function (_ value [idx context])
- (#try.Failure error)))
-
-(def: #export empty
- (Input Any)
- (function (_ value context)
- (#try.Success context)))
-
-(template [<function> <type> <setter>]
- [(def: #export <function>
- (Input <type>)
- (function (_ value [idx statement])
- (do try.monad
- [_ (<setter> (.int idx) value statement)]
- (wrap [(.inc idx) statement]))))]
-
- [boolean Bit java/sql/PreparedStatement::setBoolean]
-
- [byte Int java/sql/PreparedStatement::setByte]
- [short Int java/sql/PreparedStatement::setShort]
- [int Int java/sql/PreparedStatement::setInt]
- [long Int java/sql/PreparedStatement::setLong]
-
- [float Frac java/sql/PreparedStatement::setFloat]
- [double Frac java/sql/PreparedStatement::setDouble]
-
- [string Text java/sql/PreparedStatement::setString]
- [bytes Binary java/sql/PreparedStatement::setBytes]
- )
-
-(template [<function> <setter> <constructor>]
- [(def: #export <function>
- (Input Instant)
- (function (_ value [idx statement])
- (do try.monad
- [_ (<setter> (.int idx)
- (<constructor> (instant.to-millis value))
- statement)]
- (wrap [(.inc idx) statement]))))]
-
- [date java/sql/PreparedStatement::setDate java/sql/Date::new]
- [time java/sql/PreparedStatement::setTime java/sql/Time::new]
- [time-stamp java/sql/PreparedStatement::setTimestamp java/sql/Timestamp::new]
- )
diff --git a/stdlib/source/lux/world/db/jdbc/output.lux b/stdlib/source/lux/world/db/jdbc/output.lux
deleted file mode 100644
index 4639a5255..000000000
--- a/stdlib/source/lux/world/db/jdbc/output.lux
+++ /dev/null
@@ -1,194 +0,0 @@
-(.module:
- [lux (#- and int)
- [ffi (#+ import:)]
- [control
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- [monad (#+ Monad do)]
- ["ex" exception]
- ["." try (#+ Try)]]
- [time
- ["." instant (#+ Instant)]]
- ["." io (#+ IO)]
- [world
- [binary (#+ Binary)]]])
-
-(import: java/lang/String)
-
-(import: java/util/Date
- (getTime [] long))
-
-(import: java/sql/Date)
-(import: java/sql/Time)
-(import: java/sql/Timestamp)
-
-(`` (import: java/sql/ResultSet
- (~~ (template [<method-name> <return-class>]
- [(<method-name> [int] #try <return-class>)]
-
- [getBoolean boolean]
-
- [getByte byte]
- [getShort short]
- [getInt int]
- [getLong long]
-
- [getDouble double]
- [getFloat float]
-
- [getString java/lang/String]
- [getBytes [byte]]
-
- [getDate java/sql/Date]
- [getTime java/sql/Time]
- [getTimestamp java/sql/Timestamp]
- ))
- (next [] #try boolean)
- (close [] #io #try void)))
-
-(type: #export (Output a)
- (-> [Nat java/sql/ResultSet] (Try [Nat a])))
-
-(implementation: #export functor
- (Functor Output)
-
- (def: (map f fa)
- (function (_ idx+rs)
- (case (fa idx+rs)
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success [idx' value])
- (#try.Success [idx' (f value)])))))
-
-(implementation: #export apply
- (Apply Output)
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (function (_ [idx rs])
- (case (ff [idx rs])
- (#try.Success [idx' f])
- (case (fa [idx' rs])
- (#try.Success [idx'' a])
- (#try.Success [idx'' (f a)])
-
- (#try.Failure msg)
- (#try.Failure msg))
-
- (#try.Failure msg)
- (#try.Failure msg)))))
-
-(implementation: #export monad
- (Monad Output)
-
- (def: &functor ..functor)
-
- (def: (wrap a)
- (function (_ [idx rs])
- (#.Some [idx a])))
-
- (def: (join mma)
- (function (_ [idx rs])
- (case (mma [idx rs])
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success [idx' ma])
- (ma [idx' rs])))))
-
-(def: #export (fail error)
- (All [a] (-> Text (Output a)))
- (function (_ [idx result-set])
- (#try.Failure error)))
-
-(def: #export (and left right)
- (All [a b]
- (-> (Output a) (Output b) (Output [a b])))
- (do ..monad
- [=left left
- =right right]
- (wrap [=left =right])))
-
-(template [<func-name> <method-name> <type>]
- [(def: #export <func-name>
- (Output <type>)
- (function (_ [idx result-set])
- (case (<method-name> [(.int idx)] result-set)
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success value)
- (#try.Success [(inc idx) value]))))]
-
- [boolean java/sql/ResultSet::getBoolean Bit]
-
- [byte java/sql/ResultSet::getByte Int]
- [short java/sql/ResultSet::getShort Int]
- [int java/sql/ResultSet::getInt Int]
- [long java/sql/ResultSet::getLong Int]
-
- [float java/sql/ResultSet::getFloat Frac]
- [double java/sql/ResultSet::getDouble Frac]
-
- [string java/sql/ResultSet::getString Text]
- [bytes java/sql/ResultSet::getBytes Binary]
- )
-
-(template [<func-name> <method-name>]
- [(def: #export <func-name>
- (Output Instant)
- (function (_ [idx result-set])
- (case (<method-name> [(.int idx)] result-set)
- (#try.Failure error)
- (#try.Failure error)
-
- (#try.Success value)
- (#try.Success [(inc idx)
- (instant.from-millis (java/util/Date::getTime value))]))))]
-
- [date java/sql/ResultSet::getDate]
- [time java/sql/ResultSet::getTime]
- [time-stamp java/sql/ResultSet::getTimestamp]
- )
-
-(def: #export (rows output results)
- (All [a] (-> (Output a) java/sql/ResultSet (IO (Try (List a)))))
- (case (java/sql/ResultSet::next results)
- (#try.Success has-next?)
- (if has-next?
- (case (output [1 results])
- (#.Some [_ head])
- (do io.monad
- [?tail (rows output results)]
- (case ?tail
- (#try.Success tail)
- (wrap (ex.return (#.Cons head tail)))
-
- (#try.Failure error)
- (do io.monad
- [temp (java/sql/ResultSet::close results)]
- (wrap (do try.monad
- [_ temp]
- (try.fail error))))))
-
- (#try.Failure error)
- (do io.monad
- [temp (java/sql/ResultSet::close results)]
- (wrap (do try.monad
- [_ temp]
- (try.fail error)))))
- (do io.monad
- [temp (java/sql/ResultSet::close results)]
- (wrap (do try.monad
- [_ temp]
- (wrap (list))))))
-
- (#try.Failure error)
- (do io.monad
- [temp (java/sql/ResultSet::close results)]
- (wrap (do try.monad
- [_ temp]
- (try.fail error))))
- ))
diff --git a/stdlib/source/lux/world/db/sql.lux b/stdlib/source/lux/world/db/sql.lux
deleted file mode 100644
index 4c9bce9b2..000000000
--- a/stdlib/source/lux/world/db/sql.lux
+++ /dev/null
@@ -1,475 +0,0 @@
-(.module:
- [lux (#- Source Definition function and or not type is? int)
- [control
- [monad (#+ do)]]
- [data
- [number
- ["i" int]]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]]]
- [type
- abstract]])
-
-(def: parenthesize
- (-> Text Text)
- (text.enclose ["(" ")"]))
-
-## Kind
-(template [<declaration>]
- [(abstract: #export <declaration> Any)]
-
- [Literal']
- [Column']
- [Placeholder']
- [(Value' kind)]
-
- [Function']
-
- [Condition']
-
- [Index']
-
- [Table']
- [View']
- [Source']
- [DB']
-
- [No-Limit] [With-Limit]
- [No-Offset] [With-Offset]
- [Order']
- [No-Order] [With-Order]
- [No-Group] [With-Group]
- [(Query' order group limit offset)]
-
- [Command']
-
- [No-Where] [With-Where] [Without-Where]
- [No-Having] [With-Having] [Without-Having]
- [(Action' where having kind)]
-
- [(Schema' kind)]
- [Definition']
- [(Statement' kind)]
- )
-
-(type: #export Alias Text)
-
-(def: #export no-alias Alias "")
-
-(abstract: #export (SQL kind)
- Text
-
- ## SQL
- (template [<declaration> <kind>]
- [(type: #export <declaration> (SQL <kind>))]
-
- [Literal (Value' Literal')]
- [Column (Value' Column')]
- [Placeholder (Value' Placeholder')]
- [Value (Value' Any)]
-
- [Function Function']
- [Condition Condition']
-
- [Index Index']
-
- [Table Table']
- [View View']
- [Source Source']
- [DB DB']
-
- [Order Order']
-
- [(Schema kind) (Schema' kind)]
-
- [(Query where having order group limit offset) (Statement' (Action' where having (Query' order group limit offset)))]
- [(Command where having) (Statement' (Action' where having Command'))]
- [(Action where having kind) (Statement' (Action' where having kind))]
-
- [Definition (Statement' Definition')]
- [Statement (Statement' Any)]
- )
-
- (def: Base-Query (.type (Query No-Where No-Having No-Order No-Group No-Limit No-Offset)))
- (def: Any-Query (.type (Query Any Any Any Any Any Any)))
-
- (def: #export read
- {#.doc (doc "Only use this function for debugging purposes."
- "Do not use this function to actually execute SQL code.")}
- (-> (SQL Any) Text)
- (|>> :representation))
-
- (def: #export (sql action)
- (-> Statement Text)
- (format (:representation action) ";"))
-
- (def: enumerate
- (-> (List (SQL Any)) Text)
- (|>> (list\map (|>> :representation))
- (text.join-with ", ")))
-
- ## Value
- (def: #export ? Placeholder (:abstraction "?"))
-
- (def: literal
- (-> Text Literal)
- (|>> :abstraction))
-
- (def: #export null Literal (..literal "NULL"))
-
- (def: #export (int value)
- (-> Int Literal)
- (..literal (if (i.< +0 value)
- (%.int value)
- (%.nat (.nat value)))))
-
- (def: #export function
- (-> Text Function)
- (|>> :abstraction))
-
- (def: #export (call function parameters)
- (-> Function (List Value) Value)
- (:abstraction (format (:representation function)
- (..parenthesize (..enumerate parameters)))))
-
- ## Condition
- (template [<name> <sql-op>]
- [(def: #export (<name> reference sample)
- (-> Value Value Condition)
- (:abstraction
- (..parenthesize
- (format (:representation sample)
- " " <sql-op> " "
- (:representation reference)))))]
-
- [= "="]
- [<> "<>"]
- [is? "IS"]
- [> ">"]
- [>= ">="]
- [< "<"]
- [<= "<="]
- [like? "LIKE"]
- [ilike? "ILIKE"]
- )
-
- (def: #export (between from to sample)
- (-> Value Value Value Condition)
- (:abstraction
- (..parenthesize
- (format (:representation sample)
- " BETWEEN " (:representation from)
- " AND " (:representation to)))))
-
- (def: #export (in options value)
- (-> (List Value) Value Condition)
- (:abstraction
- (format (:representation value)
- " IN "
- (..parenthesize (enumerate options)))))
-
- (template [<func-name> <sql-op>]
- [(def: #export (<func-name> left right)
- (-> Condition Condition Condition)
- (:abstraction
- (format (..parenthesize (:representation left))
- " " <sql-op> " "
- (..parenthesize (:representation right)))))]
-
- [and "AND"]
- [or "OR"]
- )
-
- (template [<name> <type> <sql>]
- [(def: #export <name>
- (-> <type> Condition)
- (|>> :representation ..parenthesize (format <sql> " ") :abstraction))]
-
- [not Condition "NOT"]
- [exists Any-Query "EXISTS"]
- )
-
- ## Query
- (template [<name> <type> <decoration>]
- [(def: #export <name>
- (-> <type> Source)
- (|>> :representation <decoration> :abstraction))]
-
- [from-table Table (<|)]
- [from-view View (<|)]
- [from-query Any-Query ..parenthesize]
- )
-
- (template [<func-name> <op>]
- [(def: #export (<func-name> columns source)
- (-> (List [Column Alias]) Source Base-Query)
- (:abstraction
- (format <op>
- " "
- (case columns
- #.Nil
- "*"
-
- _
- (|> columns
- (list\map (.function (_ [column alias])
- (if (text\= ..no-alias alias)
- (:representation column)
- (format (:representation column) " AS " alias))))
- (text.join-with ", ")))
- " FROM " (:representation source))))]
-
-
- [select "SELECT"]
- [select-distinct "SELECT DISTINCT"]
- )
-
- (template [<name> <join-text>]
- [(def: #export (<name> table condition prev)
- (-> Table Condition Base-Query Base-Query)
- (:abstraction
- (format (:representation prev)
- " " <join-text> " "
- (:representation table)
- " ON " (:representation condition))))]
-
- [inner-join "INNER JOIN"]
- [left-join "LEFT JOIN"]
- [right-join "RIGHT JOIN"]
- [full-outer-join "FULL OUTER JOIN"]
- )
-
- (template [<function> <sql-op>]
- [(def: #export (<function> left right)
- (-> Any-Query Any-Query (Query Without-Where Without-Having No-Order No-Group No-Limit No-Offset))
- (:abstraction
- (format (:representation left)
- " " <sql-op> " "
- (:representation right))))]
-
- [union "UNION"]
- [union-all "UNION ALL"]
- [intersect "INTERSECT"]
- )
-
- (template [<name> <sql> <variables> <input> <output>]
- [(def: #export (<name> value query)
- (All <variables>
- (-> Nat <input> <output>))
- (:abstraction
- (format (:representation query)
- " " <sql> " "
- (%.nat value))))]
-
- [limit "LIMIT" [where having order group offset]
- (Query where having order group No-Limit offset)
- (Query where having order group With-Limit offset)]
-
- [offset "OFFSET" [where having order group limit]
- (Query where having order group limit No-Offset)
- (Query where having order group limit With-Offset)]
- )
-
- (template [<name> <sql>]
- [(def: #export <name>
- Order
- (:abstraction <sql>))]
-
- [ascending "ASC"]
- [descending "DESC"]
- )
-
- (def: #export (order-by pairs query)
- (All [where having group limit offset]
- (-> (List [Value Order])
- (Query where having No-Order group limit offset)
- (Query where having With-Order group limit offset)))
- (case pairs
- #.Nil
- (|> query :representation :abstraction)
-
- _
- (:abstraction
- (format (:representation query)
- " ORDER BY "
- (|> pairs
- (list\map (.function (_ [value order])
- (format (:representation value) " " (:representation order))))
- (text.join-with ", "))))))
-
- (def: #export (group-by pairs query)
- (All [where having order limit offset]
- (-> (List Value)
- (Query where having order No-Group limit offset)
- (Query where having order With-Group limit offset)))
- (case pairs
- #.Nil
- (|> query :representation :abstraction)
-
- _
- (:abstraction
- (format (:representation query)
- " GROUP BY "
- (..enumerate pairs)))))
-
- ## Command
- (def: #export (insert table columns rows)
- (-> Table (List Column) (List (List Value)) (Command Without-Where Without-Having))
- (:abstraction
- (format "INSERT INTO " (:representation table) " "
- (..parenthesize (..enumerate columns))
- " VALUES "
- (|> rows
- (list\map (|>> ..enumerate ..parenthesize))
- (text.join-with ", "))
- )))
-
- (def: #export (update table pairs)
- (-> Table (List [Column Value]) (Command No-Where No-Having))
- (:abstraction (format "UPDATE " (:representation table)
- (case pairs
- #.Nil
- ""
-
- _
- (format " SET " (|> pairs
- (list\map (.function (_ [column value])
- (format (:representation column) "=" (:representation value))))
- (text.join-with ", ")))))))
-
- (def: #export delete
- (-> Table (Command No-Where No-Having))
- (|>> :representation (format "DELETE FROM ") :abstraction))
-
- ## Action
- (def: #export (where condition prev)
- (All [kind having]
- (-> Condition (Action No-Where having kind) (Action With-Where having kind)))
- (:abstraction
- (format (:representation prev)
- " WHERE "
- (:representation condition))))
-
- (def: #export (having condition prev)
- (All [where kind]
- (-> Condition (Action where No-Having kind) (Action where With-Having kind)))
- (:abstraction
- (format (:representation prev)
- " HAVING "
- (:representation condition))))
-
- ## Schema
- (def: #export type
- (-> Text (Schema Value))
- (|>> :abstraction))
-
- (template [<name> <attr>]
- [(def: #export (<name> attr)
- (-> (Schema Value) (Schema Value))
- (:abstraction
- (format (:representation attr) " " <attr>)))]
-
- [unique "UNIQUE"]
- [not-null "NOT NULL"]
- [stored "STORED"]
- )
-
- (def: #export (default value attr)
- (-> Value (Schema Value) (Schema Value))
- (:abstraction
- (format (:representation attr) " DEFAULT " (:representation value))))
-
- (def: #export (define-column name type)
- (-> Column (Schema Value) (Schema Column))
- (:abstraction
- (format (:representation name) " " (:representation type))))
-
- (def: #export (auto-increment offset column)
- (-> Int (Schema Column) (Schema Column))
- (:abstraction
- (format (:representation column) " AUTO_INCREMENT=" (:representation (..int offset)))))
-
- (def: #export (create-table or-replace? table columns)
- (-> Bit Table (List (Schema Column)) Definition)
- (let [command (if or-replace?
- "CREATE OR REPLACE TABLE"
- "CREATE TABLE IF NOT EXISTS")]
- (:abstraction
- (format command " " (:representation table)
- (..parenthesize (..enumerate columns))))))
-
- (def: #export (create-table-as table query)
- (-> Table Any-Query Definition)
- (:abstraction
- (format "CREATE TABLE " (:representation table) " AS " (:representation query))))
-
- (template [<name> <sql>]
- [(def: #export (<name> table)
- (-> Table Definition)
- (:abstraction
- (format <sql> " TABLE " (:representation table))))]
-
- [drop "DROP"]
- [truncate "TRUNCATE"]
- )
-
- (def: #export (add-column table column)
- (-> Table (Schema Column) Definition)
- (:abstraction
- (format "ALTER TABLE " (:representation table) " ADD " (:representation column))))
-
- (def: #export (drop-column table column)
- (-> Table Column Definition)
- (:abstraction
- (format "ALTER TABLE " (:representation table) " DROP COLUMN " (:representation column))))
-
- (template [<name> <type>]
- [(def: #export (<name> name)
- (-> Text <type>)
- (:abstraction name))]
-
- [column Column]
- [table Table]
- [view View]
- [index Index]
- [db DB]
- )
-
- (template [<name> <type> <sql>]
- [(def: #export <name>
- (-> <type> Definition)
- (|>> :representation (format <sql> " ") :abstraction))]
-
- [create-db DB "CREATE DATABASE"]
- [drop-db DB "DROP DATABASE"]
- [drop-view View "DROP VIEW"]
- )
-
- (template [<name> <sql>]
- [(def: #export (<name> view query)
- (-> View Any-Query Definition)
- (:abstraction
- (format <sql> " " (:representation view) " AS " (:representation query))))]
-
- [create-view "CREATE VIEW"]
- [create-or-replace-view "CREATE OR REPLACE VIEW"]
- )
-
- (def: #export (create-index index table unique? columns)
- (-> Index Table Bit (List Column) Definition)
- (:abstraction
- (format "CREATE " (if unique? "UNIQUE" "") " INDEX " (:representation index)
- " ON " (:representation table) " " (..parenthesize (..enumerate columns)))))
-
- (def: #export (with alias query body)
- (All [where having order group limit offset]
- (-> Table Any-Query
- (Query where having order group limit offset)
- (Query where having order group limit offset)))
- (:abstraction
- (format "WITH " (:representation alias)
- " AS " (..parenthesize (:representation query))
- " " (:representation body))))
- )
diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux
deleted file mode 100644
index fade9ad67..000000000
--- a/stdlib/source/lux/world/file.lux
+++ /dev/null
@@ -1,1302 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- ["." ffi]
- [abstract
- ["." monad (#+ Monad do)]]
- [control
- [pipe (#+ case>)]
- ["." try (#+ Try) ("#\." functor)]
- ["." exception (#+ exception:)]
- ["." io (#+ IO) ("#\." functor)]
- ["." function]
- [concurrency
- ["." promise (#+ Promise)]
- ["." stm (#+ Var STM)]]]
- [data
- ["." bit ("#\." equivalence)]
- ["." product]
- ["." maybe ("#\." functor)]
- ["." binary (#+ Binary)]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." array (#+ Array)]
- ["." list ("#\." functor)]
- ["." dictionary (#+ Dictionary)]]]
- [macro
- ["." template]]
- [math
- [number
- ["i" int]
- ["f" frac]]]
- [time
- ["." instant (#+ Instant)]
- ["." duration]]])
-
-(type: #export Path
- Text)
-
-(`` (interface: #export (System !)
- (: Text
- separator)
-
- (~~ (template [<name> <output>]
- [(: (-> Path (! <output>))
- <name>)]
-
- [file? Bit]
- [directory? Bit]
- ))
-
- (~~ (template [<name> <output>]
- [(: (-> Path (! (Try <output>)))
- <name>)]
-
- [make_directory Any]
- [directory_files (List Path)]
- [sub_directories (List Path)]
-
- [file_size Nat]
- [last_modified Instant]
- [can_execute? Bit]
- [read Binary]
- [delete Any]
- ))
-
- (~~ (template [<name> <input>]
- [(: (-> <input> Path (! (Try Any)))
- <name>)]
-
- [modify Instant]
- [write Binary]
- [append Binary]
- [move Path]
- ))
- ))
-
-(def: #export (un_nest fs path)
- (All [!] (-> (System !) Path (Maybe [Path Text])))
- (let [/ (\ fs separator)]
- (case (text.last_index_of / path)
- #.None
- #.None
-
- (#.Some last_separator)
- (do maybe.monad
- [[parent temp] (text.split last_separator path)
- [_ child] (text.split (text.size /) temp)]
- (wrap [parent child])))))
-
-(def: #export (parent fs path)
- (All [!] (-> (System !) Path (Maybe Path)))
- (|> (..un_nest fs path)
- (maybe\map product.left)))
-
-(def: #export (name fs path)
- (All [!] (-> (System !) Path Text))
- (|> (..un_nest fs path)
- (maybe\map product.right)
- (maybe.default path)))
-
-(def: #export (async fs)
- (-> (System IO) (System Promise))
- (`` (implementation
- (def: separator
- (\ fs separator))
-
- (~~ (template [<name>]
- [(def: <name>
- (|>> (\ fs <name>)
- promise.future))]
-
- [file?]
- [directory?]
-
- [make_directory]
- [directory_files]
- [sub_directories]
-
- [file_size]
- [last_modified]
- [can_execute?]
- [read]
- [delete]))
-
- (~~ (template [<name>]
- [(def: (<name> input path)
- (promise.future (\ fs <name> input path)))]
-
- [modify]
- [write]
- [append]
- [move]))
- )))
-
-(def: #export (nest fs parent child)
- (All [!] (-> (System !) Path Text Path))
- (format parent (\ fs separator) child))
-
-(template [<name>]
- [(exception: #export (<name> {file Path})
- (exception.report
- ["Path" file]))]
-
- [cannot_make_file]
- [cannot_find_file]
- [cannot_delete]
-
- [cannot_make_directory]
- [cannot_find_directory]
-
- [cannot_read_all_data]
- )
-
-(with_expansions [<extra> (as_is (exception: #export (cannot_move {target Path} {source Path})
- (exception.report
- ["Source" source]
- ["Target" target])))]
- (for {@.old (as_is <extra>)
- @.jvm (as_is <extra>)
- @.lua (as_is <extra>)}
- (as_is)))
-
-(with_expansions [<for_jvm> (as_is (exception: #export (cannot_modify_file {instant Instant} {file Path})
- (exception.report
- ["Instant" (%.instant instant)]
- ["Path" file]))
-
- (ffi.import: java/lang/String)
-
- (`` (ffi.import: java/io/File
- ["#::."
- (new [java/lang/String])
- (~~ (template [<name>]
- [(<name> [] #io #try boolean)]
-
- [createNewFile] [mkdir]
- [delete]
- [isFile] [isDirectory]
- [canRead] [canWrite] [canExecute]))
-
- (length [] #io #try long)
- (listFiles [] #io #try #? [java/io/File])
- (getAbsolutePath [] #io #try java/lang/String)
- (renameTo [java/io/File] #io #try boolean)
- (lastModified [] #io #try long)
- (setLastModified [long] #io #try boolean)
- (#static separator java/lang/String)]))
-
- (ffi.import: java/lang/AutoCloseable
- ["#::."
- (close [] #io #try void)])
-
- (ffi.import: java/io/OutputStream
- ["#::."
- (write [[byte]] #io #try void)
- (flush [] #io #try void)])
-
- (ffi.import: java/io/FileOutputStream
- ["#::."
- (new [java/io/File boolean] #io #try)])
-
- (ffi.import: java/io/InputStream
- ["#::."
- (read [[byte]] #io #try int)])
-
- (ffi.import: java/io/FileInputStream
- ["#::."
- (new [java/io/File] #io #try)])
-
- (`` (implementation: #export default
- (System IO)
-
- (def: separator
- (java/io/File::separator))
-
- (~~ (template [<name> <method>]
- [(def: <name>
- (|>> java/io/File::new
- <method>
- (io\map (|>> (try.default false)))))]
-
- [file? java/io/File::isFile]
- [directory? java/io/File::isDirectory]
- ))
-
- (def: (make_directory path)
- (|> path
- java/io/File::new
- java/io/File::mkdir))
-
- (~~ (template [<name> <method>]
- [(def: (<name> path)
- (do {! (try.with io.monad)}
- [?children (java/io/File::listFiles (java/io/File::new path))]
- (case ?children
- (#.Some children)
- (|> children
- array.to_list
- (monad.filter ! (|>> <method>))
- (\ ! map (monad.map ! (|>> java/io/File::getAbsolutePath)))
- (\ ! join))
-
- #.None
- (\ io.monad wrap (exception.throw ..cannot_find_directory [path])))))]
-
- [directory_files java/io/File::isFile]
- [sub_directories java/io/File::isDirectory]
- ))
-
- (def: file_size
- (|>> java/io/File::new
- java/io/File::length
- (\ (try.with io.monad) map .nat)))
-
- (def: last_modified
- (|>> java/io/File::new
- (java/io/File::lastModified)
- (\ (try.with io.monad) map (|>> duration.from_millis instant.absolute))))
-
- (def: can_execute?
- (|>> java/io/File::new
- java/io/File::canExecute))
-
- (def: (read path)
- (do (try.with io.monad)
- [#let [file (java/io/File::new path)]
- size (java/io/File::length file)
- #let [data (binary.create (.nat size))]
- stream (java/io/FileInputStream::new file)
- bytes_read (java/io/InputStream::read data stream)
- _ (java/lang/AutoCloseable::close stream)]
- (if (i.= size bytes_read)
- (wrap data)
- (\ io.monad wrap (exception.throw ..cannot_read_all_data path)))))
-
- (def: (delete path)
- (|> path
- java/io/File::new
- java/io/File::delete))
-
- (def: (modify time_stamp path)
- (|> path
- java/io/File::new
- (java/io/File::setLastModified (|> time_stamp instant.relative duration.to_millis))))
-
- (~~ (template [<name> <flag>]
- [(def: (<name> data path)
- (do (try.with io.monad)
- [stream (java/io/FileOutputStream::new (java/io/File::new path) <flag>)
- _ (java/io/OutputStream::write data stream)
- _ (java/io/OutputStream::flush stream)]
- (java/lang/AutoCloseable::close stream)))]
-
- [write #0]
- [append #1]
- ))
-
- (def: (move destination origin)
- (|> origin
- java/io/File::new
- (java/io/File::renameTo (java/io/File::new destination))))
- )))]
- (for {@.old (as_is <for_jvm>)
- @.jvm (as_is <for_jvm>)
-
- @.js
- (as_is (ffi.import: Buffer
- ["#::."
- (#static from [Binary] ..Buffer)])
-
- (ffi.import: FileDescriptor)
-
- (ffi.import: Stats
- ["#::."
- (size ffi.Number)
- (mtimeMs ffi.Number)
- (isFile [] #io #try ffi.Boolean)
- (isDirectory [] #io #try ffi.Boolean)])
-
- (ffi.import: FsConstants
- ["#::."
- (F_OK ffi.Number)
- (R_OK ffi.Number)
- (W_OK ffi.Number)
- (X_OK ffi.Number)])
-
- (ffi.import: Fs
- ["#::."
- (constants FsConstants)
- (readFileSync [ffi.String] #io #try Binary)
- (appendFileSync [ffi.String Buffer] #io #try Any)
- (writeFileSync [ffi.String Buffer] #io #try Any)
- (statSync [ffi.String] #io #try Stats)
- (accessSync [ffi.String ffi.Number] #io #try Any)
- (renameSync [ffi.String ffi.String] #io #try Any)
- (utimesSync [ffi.String ffi.Number ffi.Number] #io #try Any)
- (unlink [ffi.String] #io #try Any)
- (readdirSync [ffi.String] #io #try (Array ffi.String))
- (mkdirSync [ffi.String] #io #try Any)
- (rmdirSync [ffi.String] #io #try Any)])
-
- (ffi.import: JsPath
- ["#::."
- (sep ffi.String)])
-
- (template [<name> <path>]
- [(def: (<name> _)
- (-> [] (Maybe (-> ffi.String Any)))
- (ffi.constant (-> ffi.String Any) <path>))]
-
- [normal_require [require]]
- [global_require [global require]]
- [process_load [global process mainModule constructor _load]]
- )
-
- (def: (require _)
- (-> [] (-> ffi.String Any))
- (case [(normal_require []) (global_require []) (process_load [])]
- (^or [(#.Some require) _ _]
- [_ (#.Some require) _]
- [_ _ (#.Some require)])
- require
-
- _
- (undefined)))
-
- (template [<name> <module> <type>]
- [(def: (<name> _)
- (-> [] <type>)
- (:as <type> (..require [] <module>)))]
-
- [node_fs "fs" ..Fs]
- [node_path "path" ..JsPath]
- )
-
- (`` (implementation: #export default
- (System IO)
-
- (def: separator
- (if ffi.on_node_js?
- (JsPath::sep (..node_path []))
- "/"))
-
- (~~ (template [<name> <method>]
- [(def: (<name> path)
- (do {! io.monad}
- [?stats (Fs::statSync [path] (..node_fs []))]
- (case ?stats
- (#try.Success stats)
- (|> stats
- (<method> [])
- (\ ! map (|>> (try.default false))))
-
- (#try.Failure _)
- (wrap false))))]
-
- [file? Stats::isFile]
- [directory? Stats::isDirectory]
- ))
-
- (def: (make_directory path)
- (let [node_fs (..node_fs [])]
- (do io.monad
- [outcome (Fs::accessSync [path (|> node_fs Fs::constants FsConstants::F_OK)] node_fs)]
- (case outcome
- (#try.Success _)
- (wrap (exception.throw ..cannot_make_directory [path]))
-
- (#try.Failure _)
- (Fs::mkdirSync [path] node_fs)))))
-
- (~~ (template [<name> <method>]
- [(def: (<name> path)
- (do {! (try.with io.monad)}
- [#let [node_fs (..node_fs [])]
- subs (Fs::readdirSync [path] node_fs)]
- (|> subs
- array.to_list
- (monad.map ! (function (_ sub)
- (do !
- [stats (Fs::statSync [sub] node_fs)]
- (\ ! map (|>> [sub]) (<method> [] stats)))))
- (\ ! map (|>> (list.filter product.right)
- (list\map product.left))))))]
-
- [directory_files Stats::isFile]
- [sub_directories Stats::isDirectory]
- ))
-
- (def: (file_size path)
- (let [! (try.with io.monad)]
- (|> (..node_fs [])
- (Fs::statSync [path])
- (\ ! map (|>> Stats::size
- f.nat)))))
-
- (def: (last_modified path)
- (let [! (try.with io.monad)]
- (|> (..node_fs [])
- (Fs::statSync [path])
- (\ ! map (|>> Stats::mtimeMs
- f.int
- duration.from_millis
- instant.absolute)))))
-
- (def: (can_execute? path)
- (let [node_fs (..node_fs [])]
- (|> node_fs
- (Fs::accessSync [path (|> node_fs Fs::constants FsConstants::X_OK)])
- (io\map (|>> (case> (#try.Success _)
- true
-
- (#try.Failure _)
- false)
- #try.Success)))))
-
- (def: (read path)
- (Fs::readFileSync [path] (..node_fs [])))
-
- (def: (delete path)
- (do {! (try.with io.monad)}
- [#let [node_fs (..node_fs [])]
- stats (Fs::statSync [path] node_fs)
- verdict (Stats::isFile [] stats)]
- (if verdict
- (Fs::unlink [path] node_fs)
- (Fs::rmdirSync [path] node_fs))))
-
- (def: (modify time_stamp path)
- (let [when (|> time_stamp instant.relative duration.to_millis i.frac)]
- (Fs::utimesSync [path when when] (..node_fs []))))
-
- (~~ (template [<name> <method>]
- [(def: (<name> data path)
- (<method> [path (Buffer::from data)] (..node_fs [])))]
-
- [write Fs::writeFileSync]
- [append Fs::appendFileSync]
- ))
-
- (def: (move destination origin)
- (Fs::renameSync [origin destination] (..node_fs [])))
- )))
-
- @.python
- (as_is (type: (Tuple/2 left right)
- (primitive "python_tuple[2]" [left right]))
-
- (ffi.import: PyFile
- ["#::."
- (read [] #io #try Binary)
- (write [Binary] #io #try #? Any)
- (close [] #io #try #? Any)])
-
- (ffi.import: (open [ffi.String ffi.String] #io #try PyFile))
- (ffi.import: (tuple [[ffi.Integer ffi.Integer]] (Tuple/2 ffi.Integer ffi.Integer)))
-
- (ffi.import: os
- ["#::."
- (#static F_OK ffi.Integer)
- (#static R_OK ffi.Integer)
- (#static W_OK ffi.Integer)
- (#static X_OK ffi.Integer)
-
- (#static mkdir [ffi.String] #io #try #? Any)
- (#static access [ffi.String ffi.Integer] #io #try ffi.Boolean)
- (#static remove [ffi.String] #io #try #? Any)
- (#static rmdir [ffi.String] #io #try #? Any)
- (#static rename [ffi.String ffi.String] #io #try #? Any)
- (#static utime [ffi.String (Tuple/2 ffi.Integer ffi.Integer)] #io #try #? Any)
- (#static listdir [ffi.String] #io #try (Array ffi.String))])
-
- (ffi.import: os/path
- ["#::."
- (#static isfile [ffi.String] #io #try ffi.Boolean)
- (#static isdir [ffi.String] #io #try ffi.Boolean)
- (#static sep ffi.String)
- (#static getsize [ffi.String] #io #try ffi.Integer)
- (#static getmtime [ffi.String] #io #try ffi.Float)])
-
- (`` (implementation: #export default
- (System IO)
-
- (def: separator
- (os/path::sep))
-
- (~~ (template [<name> <method>]
- [(def: <name>
- (|>> <method>
- (io\map (|>> (try.default false)))))]
-
- [file? os/path::isfile]
- [directory? os/path::isdir]
- ))
-
- (def: make_directory
- os::mkdir)
-
- (~~ (template [<name> <method>]
- [(def: <name>
- (let [! (try.with io.monad)]
- (|>> os::listdir
- (\ ! map (|>> array.to_list
- (monad.map ! (function (_ sub)
- (\ ! map (|>> [sub]) (<method> [sub]))))
- (\ ! map (|>> (list.filter product.right)
- (list\map product.left)))))
- (\ ! join))))]
-
- [directory_files os/path::isfile]
- [sub_directories os/path::isdir]
- ))
-
- (def: file_size
- (|>> os/path::getsize
- (\ (try.with io.monad) map .nat)))
-
- (def: last_modified
- (|>> os/path::getmtime
- (\ (try.with io.monad) map (|>> f.int
- (i.* +1,000)
- duration.from_millis
- instant.absolute))))
-
- (def: (can_execute? path)
- (os::access [path (os::X_OK)]))
-
- (def: (read path)
- (do (try.with io.monad)
- [file (..open [path "rb"])
- data (PyFile::read [] file)
- _ (PyFile::close [] file)]
- (wrap data)))
-
- (def: (delete path)
- (do (try.with io.monad)
- [? (os/path::isfile [path])]
- (if ?
- (os::remove [path])
- (os::rmdir [path]))))
-
- (def: (modify time_stamp path)
- (let [when (|> time_stamp instant.relative duration.to_millis (i./ +1,000))]
- (os::utime [path (..tuple [when when])])))
-
- (~~ (template [<name> <mode>]
- [(def: (<name> data path)
- (do (try.with io.monad)
- [file (..open [path <mode>])
- _ (PyFile::write [data] file)]
- (PyFile::close [] file)))]
-
- [write "w+b"]
- [append "ab"]
- ))
-
- (def: (move destination origin)
- (os::rename [origin destination]))
- )))
-
- @.ruby
- (as_is (ffi.import: Time #as RubyTime
- ["#::."
- (#static at [Frac] RubyTime)
- (to_f [] Frac)])
-
- (ffi.import: Stat #as RubyStat
- ["#::."
- (executable? [] Bit)
- (size Int)
- (mtime [] RubyTime)])
-
- (ffi.import: File #as RubyFile
- ["#::."
- (#static SEPARATOR ffi.String)
- (#static open [Path ffi.String] #io #try RubyFile)
- (#static stat [Path] #io #try RubyStat)
- (#static delete [Path] #io #try Int)
- (#static file? [Path] #io #try Bit)
- (#static directory? [Path] #io #try Bit)
- (#static utime [RubyTime RubyTime Path] #io #try Int)
-
- (read [] #io #try Binary)
- (write [Binary] #io #try Int)
- (flush [] #io #try #? Any)
- (close [] #io #try #? Any)])
-
- (ffi.import: Dir #as RubyDir
- ["#::."
- (#static open [Path] #io #try RubyDir)
-
- (children [] #io #try (Array Path))
- (close [] #io #try #? Any)])
-
- (ffi.import: "fileutils" FileUtils #as RubyFileUtils
- ["#::."
- (#static move [Path Path] #io #try #? Any)
- (#static rmdir [Path] #io #try #? Any)
- (#static mkdir [Path] #io #try #? Any)])
-
- (def: ruby_separator
- Text
- (..RubyFile::SEPARATOR))
-
- (`` (implementation: #export default
- (System IO)
-
- (def: separator
- ..ruby_separator)
-
- (~~ (template [<name> <test>]
- [(def: <name>
- (|>> <test>
- (io\map (|>> (try.default false)))))]
-
- [file? RubyFile::file?]
- [directory? RubyFile::directory?]
- ))
-
- (def: make_directory
- RubyFileUtils::mkdir)
-
- (~~ (template [<name> <test>]
- [(def: (<name> path)
- (do {! (try.with io.monad)}
- [self (RubyDir::open [path])
- children (RubyDir::children [] self)
- output (loop [input (|> children
- array.to_list
- (list\map (|>> (format path ..ruby_separator))))
- output (: (List ..Path)
- (list))]
- (case input
- #.Nil
- (wrap output)
-
- (#.Cons head tail)
- (do !
- [verdict (<test> head)]
- (recur tail (if verdict
- (#.Cons head output)
- output)))))
- _ (RubyDir::close [] self)]
- (wrap output)))]
-
- [directory_files RubyFile::file?]
- [sub_directories RubyFile::directory?]
- ))
-
- (~~ (template [<name> <pipeline>]
- [(def: <name>
- (let [! (try.with io.monad)]
- (|>> RubyFile::stat
- (\ ! map (`` (|>> (~~ (template.splice <pipeline>))))))))]
-
- [file_size [RubyStat::size .nat]]
- [last_modified [(RubyStat::mtime [])
- (RubyTime::to_f [])
- (f.* +1,000.0)
- f.int
- duration.from_millis
- instant.absolute]]
- [can_execute? [(RubyStat::executable? [])]]
- ))
-
- (def: (read path)
- (do (try.with io.monad)
- [file (RubyFile::open [path "rb"])
- data (RubyFile::read [] file)
- _ (RubyFile::close [] file)]
- (wrap data)))
-
- (def: (delete path)
- (do (try.with io.monad)
- [? (RubyFile::file? path)]
- (if ?
- (RubyFile::delete [path])
- (RubyFileUtils::rmdir [path]))))
-
- (def: (modify moment path)
- (let [moment (|> moment
- instant.relative
- duration.to_millis
- i.frac
- (f./ +1,000.0)
- RubyTime::at)]
- (RubyFile::utime [moment moment path])))
-
- (~~ (template [<mode> <name>]
- [(def: (<name> data path)
- (do {! (try.with io.monad)}
- [file (RubyFile::open [path <mode>])
- data (RubyFile::write [data] file)
- _ (RubyFile::flush [] file)
- _ (RubyFile::close [] file)]
- (wrap [])))]
-
- ["wb" write]
- ["ab" append]
- ))
-
- (def: (move destination origin)
- (do (try.with io.monad)
- [_ (RubyFileUtils::move [origin destination])]
- (wrap [])))
- )))
-
- ## @.php
- ## (as_is (ffi.import: (FILE_APPEND Int))
- ## ## https://www.php.net/manual/en/dir.constants.php
- ## (ffi.import: (DIRECTORY_SEPARATOR ffi.String))
- ## ## https://www.php.net/manual/en/function.pack.php
- ## ## https://www.php.net/manual/en/function.unpack.php
- ## (ffi.import: (unpack [ffi.String ffi.String] Binary))
- ## ## https://www.php.net/manual/en/ref.filesystem.php
- ## ## https://www.php.net/manual/en/function.file-get-contents.php
- ## (ffi.import: (file_get_contents [Path] #io #try ffi.String))
- ## ## https://www.php.net/manual/en/function.file-put-contents.php
- ## (ffi.import: (file_put_contents [Path ffi.String Int] #io #try ffi.Integer))
- ## (ffi.import: (filemtime [Path] #io #try ffi.Integer))
- ## (ffi.import: (filesize [Path] #io #try ffi.Integer))
- ## (ffi.import: (is_executable [Path] #io #try ffi.Boolean))
- ## (ffi.import: (touch [Path ffi.Integer] #io #try ffi.Boolean))
- ## (ffi.import: (rename [Path Path] #io #try ffi.Boolean))
- ## (ffi.import: (unlink [Path] #io #try ffi.Boolean))
-
- ## ## https://www.php.net/manual/en/function.rmdir.php
- ## (ffi.import: (rmdir [Path] #io #try ffi.Boolean))
- ## ## https://www.php.net/manual/en/function.scandir.php
- ## (ffi.import: (scandir [Path] #io #try (Array Path)))
- ## ## https://www.php.net/manual/en/function.is-file.php
- ## (ffi.import: (is_file [Path] #io #try ffi.Boolean))
- ## ## https://www.php.net/manual/en/function.is-dir.php
- ## (ffi.import: (is_dir [Path] #io #try ffi.Boolean))
- ## ## https://www.php.net/manual/en/function.mkdir.php
- ## (ffi.import: (mkdir [Path] #io #try ffi.Boolean))
-
- ## (def: byte_array_format "C*")
- ## (def: default_separator (..DIRECTORY_SEPARATOR))
-
- ## (template [<name>]
- ## [(exception: #export (<name> {file Path})
- ## (exception.report
- ## ["Path" file]))]
-
- ## [cannot_write_to_file]
- ## )
-
- ## (`` (implementation: (file path)
- ## (-> Path (File IO))
-
- ## (~~ (template [<name> <mode>]
- ## [(def: (<name> data)
- ## (do {! (try.with io.monad)}
- ## [outcome (..file_put_contents [path ("php pack" ..byte_array_format data) <mode>])]
- ## (if (bit\= false (:as Bit outcome))
- ## (\ io.monad wrap (exception.throw ..cannot_write_to_file [path]))
- ## (wrap []))))]
-
- ## [over_write +0]
- ## [append (..FILE_APPEND)]
- ## ))
-
- ## (def: (content _)
- ## (do {! (try.with io.monad)}
- ## [data (..file_get_contents [path])]
- ## (if (bit\= false (:as Bit data))
- ## (\ io.monad wrap (exception.throw ..cannot_find_file [path]))
- ## (wrap (..unpack [..byte_array_format data])))))
-
- ## (def: path
- ## path)
-
- ## (~~ (template [<name> <ffi> <pipeline>]
- ## [(def: (<name> _)
- ## (do {! (try.with io.monad)}
- ## [value (<ffi> [path])]
- ## (if (bit\= false (:as Bit value))
- ## (\ io.monad wrap (exception.throw ..cannot_find_file [path]))
- ## (wrap (`` (|> value (~~ (template.splice <pipeline>))))))))]
-
- ## [size ..filesize [.nat]]
- ## [last_modified ..filemtime [(i.* +1,000) duration.from_millis instant.absolute]]
- ## ))
-
- ## (def: (can_execute? _)
- ## (..is_executable [path]))
-
- ## (def: (modify moment)
- ## (do {! (try.with io.monad)}
- ## [verdict (..touch [path (|> moment instant.relative duration.to_millis (i./ +1,000))])]
- ## (if (bit\= false (:as Bit verdict))
- ## (\ io.monad wrap (exception.throw ..cannot_find_file [path]))
- ## (wrap []))))
-
- ## (def: (move destination)
- ## (do {! (try.with io.monad)}
- ## [verdict (..rename [path destination])]
- ## (if (bit\= false (:as Bit verdict))
- ## (\ io.monad wrap (exception.throw ..cannot_find_file [path]))
- ## (wrap (file destination)))))
-
- ## (def: (delete _)
- ## (do (try.with io.monad)
- ## [verdict (..unlink [path])]
- ## (if (bit\= false (:as Bit verdict))
- ## (\ io.monad wrap (exception.throw ..cannot_find_file [path]))
- ## (wrap []))))
- ## ))
-
- ## (`` (implementation: (directory path)
- ## (-> Path (Directory IO))
-
- ## (def: scope
- ## path)
-
- ## (~~ (template [<name> <test> <constructor> <capability>]
- ## [(def: (<name> _)
- ## (do {! (try.with io.monad)}
- ## [children (..scandir [path])]
- ## (loop [input (|> children
- ## array.to_list
- ## (list.filter (function (_ child)
- ## (not (or (text\= "." child)
- ## (text\= ".." child))))))
- ## output (: (List (<capability> IO))
- ## (list))]
- ## (case input
- ## #.Nil
- ## (wrap output)
-
- ## (#.Cons head tail)
- ## (do !
- ## [verdict (<test> head)]
- ## (if verdict
- ## (recur tail (#.Cons (<constructor> head) output))
- ## (recur tail output)))))))]
-
- ## [files ..is_file ..file File]
- ## [directories ..is_dir directory Directory]
- ## ))
-
- ## (def: (discard _)
- ## (do (try.with io.monad)
- ## [verdict (..rmdir [path])]
- ## (if (bit\= false (:as Bit verdict))
- ## (\ io.monad wrap (exception.throw ..cannot_find_directory [path]))
- ## (wrap []))))
- ## ))
-
- ## (`` (implementation: #export default
- ## (System IO)
-
- ## (~~ (template [<name> <test> <constructor> <exception>]
- ## [(def: (<name> path)
- ## (do {! (try.with io.monad)}
- ## [verdict (<test> path)]
- ## (\ io.monad wrap
- ## (if verdict
- ## (#try.Success (<constructor> path))
- ## (exception.throw <exception> [path])))))]
-
- ## [file ..is_file ..file ..cannot_find_file]
- ## [directory ..is_dir ..directory ..cannot_find_directory]
- ## ))
-
- ## (def: (make_file path)
- ## (do {! (try.with io.monad)}
- ## [verdict (..touch [path (|> instant.now io.run instant.relative duration.to_millis (i./ +1,000))])]
- ## (\ io.monad wrap
- ## (if verdict
- ## (#try.Success (..file path))
- ## (exception.throw ..cannot_make_file [path])))))
-
- ## (def: (make_directory path)
- ## (do {! (try.with io.monad)}
- ## [verdict (..mkdir path)]
- ## (\ io.monad wrap
- ## (if verdict
- ## (#try.Success (..directory path))
- ## (exception.throw ..cannot_make_directory [path])))))
-
- ## (def: separator
- ## ..default_separator)
- ## ))
- ## )
- }
- (as_is)))
-
-(def: #export (exists? monad fs path)
- (All [!] (-> (Monad !) (System !) Path (! Bit)))
- (do monad
- [verdict (\ fs file? path)]
- (if verdict
- (wrap verdict)
- (\ fs directory? path))))
-
-(type: Mock_File
- {#mock_last_modified Instant
- #mock_can_execute Bit
- #mock_content Binary})
-
-(type: #rec Mock
- (Dictionary Text (Either Mock_File Mock)))
-
-(def: empty_mock
- Mock
- (dictionary.new text.hash))
-
-(def: (retrieve_mock_file! separator path mock)
- (-> Text Path Mock (Try [Text Mock_File]))
- (loop [directory mock
- trail (text.split_all_with separator path)]
- (case trail
- (#.Cons head tail)
- (case (dictionary.get head directory)
- #.None
- (exception.throw ..cannot_find_file [path])
-
- (#.Some node)
- (case [node tail]
- [(#.Left file) #.Nil]
- (#try.Success [head file])
-
- [(#.Right sub_directory) (#.Cons _)]
- (recur sub_directory tail)
-
- _
- (exception.throw ..cannot_find_file [path])))
-
- #.Nil
- (exception.throw ..cannot_find_file [path]))))
-
-(def: (update_mock_file! / path now content mock)
- (-> Text Path Instant Binary Mock (Try Mock))
- (loop [directory mock
- trail (text.split_all_with / path)]
- (case trail
- (#.Cons head tail)
- (case (dictionary.get head directory)
- #.None
- (case tail
- #.Nil
- (#try.Success (dictionary.put head
- (#.Left {#mock_last_modified now
- #mock_can_execute false
- #mock_content content})
- directory))
-
- (#.Cons _)
- (exception.throw ..cannot_find_file [path]))
-
- (#.Some node)
- (case [node tail]
- [(#.Left file) #.Nil]
- (#try.Success (dictionary.put head
- (#.Left (|> file
- (set@ #mock_last_modified now)
- (set@ #mock_content content)))
- directory))
-
- [(#.Right sub_directory) (#.Cons _)]
- (do try.monad
- [sub_directory (recur sub_directory tail)]
- (wrap (dictionary.put head (#.Right sub_directory) directory)))
-
- _
- (exception.throw ..cannot_find_file [path])))
-
- #.Nil
- (exception.throw ..cannot_find_file [path]))))
-
-(def: (mock_delete! / path mock)
- (-> Text Path Mock (Try Mock))
- (loop [directory mock
- trail (text.split_all_with / path)]
- (case trail
- (#.Cons head tail)
- (case (dictionary.get head directory)
- #.None
- (exception.throw ..cannot_delete [path])
-
- (#.Some node)
- (case tail
- #.Nil
- (case node
- (#.Left file)
- (#try.Success (dictionary.remove head directory))
-
- (#.Right sub_directory)
- (if (dictionary.empty? sub_directory)
- (#try.Success (dictionary.remove head directory))
- (exception.throw ..cannot_delete [path])))
-
- (#.Cons _)
- (case node
- (#.Left file)
- (exception.throw ..cannot_delete [path])
-
- (#.Right sub_directory)
- (do try.monad
- [sub_directory' (recur sub_directory tail)]
- (wrap (dictionary.put head (#.Right sub_directory') directory))))))
-
- #.Nil
- (exception.throw ..cannot_delete [path]))))
-
-(def: (try_update! transform var)
- (All [a] (-> (-> a (Try a)) (Var a) (STM (Try Any))))
- (do {! stm.monad}
- [|var| (stm.read var)]
- (case (transform |var|)
- (#try.Success |var|)
- (do !
- [_ (stm.write |var| var)]
- (wrap (#try.Success [])))
-
- (#try.Failure error)
- (wrap (#try.Failure error)))))
-
-(def: (make_mock_directory! / path mock)
- (-> Text Path Mock (Try Mock))
- (loop [directory mock
- trail (text.split_all_with / path)]
- (case trail
- (#.Cons head tail)
- (case (dictionary.get head directory)
- #.None
- (case tail
- #.Nil
- (#try.Success (dictionary.put head (#.Right ..empty_mock) directory))
-
- (#.Cons _)
- (exception.throw ..cannot_make_directory [path]))
-
- (#.Some node)
- (case [node tail]
- [(#.Right sub_directory) (#.Cons _)]
- (do try.monad
- [sub_directory (recur sub_directory tail)]
- (wrap (dictionary.put head (#.Right sub_directory) directory)))
-
- _
- (exception.throw ..cannot_make_directory [path])))
-
- #.Nil
- (exception.throw ..cannot_make_directory [path]))))
-
-(def: (retrieve_mock_directory! / path mock)
- (-> Text Path Mock (Try Mock))
- (loop [directory mock
- trail (text.split_all_with / path)]
- (case trail
- #.Nil
- (#try.Success directory)
-
- (#.Cons head tail)
- (case (dictionary.get head directory)
- #.None
- (exception.throw ..cannot_find_directory [path])
-
- (#.Some node)
- (case node
- (#.Left _)
- (exception.throw ..cannot_find_directory [path])
-
- (#.Right sub_directory)
- (case tail
- #.Nil
- (#try.Success sub_directory)
-
- (#.Cons _)
- (recur sub_directory tail)))))))
-
-(def: #export (mock separator)
- (-> Text (System Promise))
- (let [store (stm.var ..empty_mock)]
- (`` (implementation
- (def: separator
- separator)
-
- (~~ (template [<method> <retrieve>]
- [(def: (<method> path)
- (|> store
- stm.read
- (\ stm.monad map
- (|>> (<retrieve> separator path)
- (try\map (function.constant true))
- (try.default false)))
- stm.commit))]
-
- [file? ..retrieve_mock_file!]
- [directory? ..retrieve_mock_directory!]))
-
- (def: (make_directory path)
- (stm.commit
- (do {! stm.monad}
- [|store| (stm.read store)]
- (case (..make_mock_directory! separator path |store|)
- (#try.Success |store|)
- (do !
- [_ (stm.write |store| store)]
- (wrap (#try.Success [])))
-
- (#try.Failure error)
- (wrap (#try.Failure error))))))
-
- (~~ (template [<method> <tag>]
- [(def: (<method> path)
- (stm.commit
- (do stm.monad
- [|store| (stm.read store)]
- (wrap (do try.monad
- [directory (..retrieve_mock_directory! separator path |store|)]
- (wrap (|> directory
- dictionary.entries
- (list.all (function (_ [node_name node])
- (case node
- (<tag> _)
- (#.Some (format path separator node_name))
-
- _
- #.None))))))))))]
-
- [directory_files #.Left]
- [sub_directories #.Right]
- ))
-
- (def: (file_size path)
- (stm.commit
- (do stm.monad
- [|store| (stm.read store)]
- (wrap (|> |store|
- (..retrieve_mock_file! separator path)
- (try\map (|>> product.right
- (get@ #mock_content)
- binary.size)))))))
-
- (def: (last_modified path)
- (stm.commit
- (do stm.monad
- [|store| (stm.read store)]
- (wrap (|> |store|
- (..retrieve_mock_file! separator path)
- (try\map (|>> product.right
- (get@ #mock_last_modified))))))))
-
- (def: (can_execute? path)
- (stm.commit
- (do stm.monad
- [|store| (stm.read store)]
- (wrap (|> |store|
- (..retrieve_mock_file! separator path)
- (try\map (|>> product.right
- (get@ #mock_can_execute))))))))
-
- (def: (read path)
- (stm.commit
- (do stm.monad
- [|store| (stm.read store)]
- (wrap (|> |store|
- (..retrieve_mock_file! separator path)
- (try\map (|>> product.right
- (get@ #mock_content))))))))
-
- (def: (delete path)
- (stm.commit
- (..try_update! (..mock_delete! separator path) store)))
-
- (def: (modify now path)
- (stm.commit
- (..try_update! (function (_ |store|)
- (do try.monad
- [[name file] (..retrieve_mock_file! separator path |store|)]
- (..update_mock_file! separator path now (get@ #mock_content file) |store|)))
- store)))
-
- (def: (write content path)
- (do promise.monad
- [now (promise.future instant.now)]
- (stm.commit
- (..try_update! (..update_mock_file! separator path now content) store))))
-
- (def: (append content path)
- (do promise.monad
- [now (promise.future instant.now)]
- (stm.commit
- (..try_update! (function (_ |store|)
- (do try.monad
- [[name file] (..retrieve_mock_file! separator path |store|)]
- (..update_mock_file! separator path now
- (\ binary.monoid compose
- (get@ #mock_content file)
- content)
- |store|)))
- store))))
-
- (def: (move destination origin)
- (stm.commit
- (do {! stm.monad}
- [|store| (stm.read store)]
- (case (do try.monad
- [[name file] (..retrieve_mock_file! separator origin |store|)
- |store| (..mock_delete! separator origin |store|)]
- (..update_mock_file! separator destination (get@ #mock_last_modified file) (get@ #mock_content file) |store|))
- (#try.Success |store|)
- (do !
- [_ (stm.write |store| store)]
- (wrap (#try.Success [])))
-
- (#try.Failure error)
- (wrap (#try.Failure error))))))
- ))))
-
-(def: (check_or_make_directory monad fs path)
- (All [!] (-> (Monad !) (System !) Path (! (Try Any))))
- (do monad
- [? (\ fs directory? path)]
- (if ?
- (wrap (#try.Success []))
- (\ fs make_directory path))))
-
-(def: #export (make_directories monad fs path)
- (All [!] (-> (Monad !) (System !) Path (! (Try Any))))
- (let [rooted? (text.starts_with? (\ fs separator) path)
- segments (text.split_all_with (\ fs separator) path)]
- (case (if rooted?
- (list.drop 1 segments)
- segments)
- #.Nil
- (\ monad wrap (exception.throw ..cannot_make_directory [path]))
-
- (#.Cons head tail)
- (case head
- "" (\ monad wrap (exception.throw ..cannot_make_directory [path]))
- _ (loop [current (if rooted?
- (format (\ fs separator) head)
- head)
- next tail]
- (do monad
- [? (..check_or_make_directory monad fs current)]
- (case ?
- (#try.Success _)
- (case next
- #.Nil
- (wrap (#try.Success []))
-
- (#.Cons head tail)
- (recur (format current (\ fs separator) head)
- tail))
-
- (#try.Failure error)
- (wrap (#try.Failure error)))))))))
-
-(def: #export (make_file monad fs content path)
- (All [!] (-> (Monad !) (System !) Binary Path (! (Try Any))))
- (do monad
- [? (\ fs file? path)]
- (if ?
- (wrap (exception.throw ..cannot_make_file [path]))
- (\ fs write content path))))
diff --git a/stdlib/source/lux/world/file/watch.lux b/stdlib/source/lux/world/file/watch.lux
deleted file mode 100644
index f1415da80..000000000
--- a/stdlib/source/lux/world/file/watch.lux
+++ /dev/null
@@ -1,458 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- ["." ffi (#+ import:)]
- [abstract
- [predicate (#+ Predicate)]
- ["." monad (#+ do)]]
- [control
- ["." io (#+ IO)]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- [concurrency
- ["." promise (#+ Promise)]
- ["." stm (#+ STM Var)]]]
- [data
- ["." product]
- ["." maybe]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary (#+ Dictionary)]
- ["." list ("#\." functor monoid fold)]
- ["." set]
- ["." array]]]
- [math
- [number
- ["n" nat]]]
- [time
- ["." instant (#+ Instant) ("#\." equivalence)]]
- [type
- [abstract (#+ abstract: :representation :abstraction)]]]
- ["." //])
-
-(abstract: #export Concern
- {#create Bit
- #modify Bit
- #delete Bit}
-
- (def: none
- Concern
- (:abstraction
- {#create false
- #modify false
- #delete false}))
-
- (template [<concern> <predicate> <event> <create> <modify> <delete>]
- [(def: #export <concern>
- Concern
- (:abstraction
- {#create <create>
- #modify <modify>
- #delete <delete>}))
-
- (def: #export <predicate>
- (Predicate Concern)
- (|>> :representation (get@ <event>)))]
-
- [creation creation? #create
- true false false]
- [modification modification? #modify
- false true false]
- [deletion deletion? #delete
- false false true]
- )
-
- (def: #export (also left right)
- (-> Concern Concern Concern)
- (:abstraction
- {#create (or (..creation? left) (..creation? right))
- #modify (or (..modification? left) (..modification? right))
- #delete (or (..deletion? left) (..deletion? right))}))
-
- (def: #export all
- Concern
- ($_ ..also
- ..creation
- ..modification
- ..deletion
- ))
- )
-
-(interface: #export (Watcher !)
- (: (-> Concern //.Path (! (Try Any)))
- start)
- (: (-> //.Path (! (Try Concern)))
- concern)
- (: (-> //.Path (! (Try Concern)))
- stop)
- (: (-> [] (! (Try (List [Concern //.Path]))))
- poll))
-
-(template [<name>]
- [(exception: #export (<name> {path //.Path})
- (exception.report
- ["Path" (%.text path)]))]
-
- [not_being_watched]
- [cannot_poll_a_non_existent_directory]
- )
-
-(type: File_Tracker
- (Dictionary //.Path Instant))
-
-(type: Directory_Tracker
- (Dictionary //.Path [Concern File_Tracker]))
-
-(def: (update_watch! new_concern path tracker)
- (-> Concern //.Path (Var Directory_Tracker) (STM Bit))
- (do {! stm.monad}
- [@tracker (stm.read tracker)]
- (case (dictionary.get path @tracker)
- (#.Some [old_concern last_modified])
- (do !
- [_ (stm.update (dictionary.put path [new_concern last_modified]) tracker)]
- (wrap true))
-
- #.None
- (wrap false))))
-
-(def: (file_tracker fs directory)
- (-> (//.System Promise) //.Path (Promise (Try File_Tracker)))
- (do {! (try.with promise.monad)}
- [files (\ fs directory_files directory)]
- (monad.fold !
- (function (_ file tracker)
- (do !
- [last_modified (\ fs last_modified file)]
- (wrap (dictionary.put file last_modified tracker))))
- (: File_Tracker
- (dictionary.new text.hash))
- files)))
-
-(def: (poll_files fs directory)
- (-> (//.System Promise) //.Path (Promise (Try (List [//.Path Instant]))))
- (do {! (try.with promise.monad)}
- [files (\ fs directory_files directory)]
- (monad.map ! (function (_ file)
- (|> file
- (\ fs last_modified)
- (\ ! map (|>> [file]))))
- files)))
-
-(def: (poll_directory_changes fs [directory [concern file_tracker]])
- (-> (//.System Promise) [//.Path [Concern File_Tracker]]
- (Promise (Try [[//.Path [Concern File_Tracker]]
- [(List [//.Path Instant])
- (List [//.Path Instant Instant])
- (List //.Path)]])))
- (do {! (try.with promise.monad)}
- [current_files (..poll_files fs directory)
- #let [creations (if (..creation? concern)
- (list.filter (|>> product.left (dictionary.key? file_tracker) not)
- current_files)
- (list))
- available (|> current_files
- (list\map product.left)
- (set.from_list text.hash))
- deletions (if (..deletion? concern)
- (|> (dictionary.entries file_tracker)
- (list\map product.left)
- (list.filter (|>> (set.member? available) not)))
- (list))
- modifications (list.all (function (_ [path current_modification])
- (do maybe.monad
- [previous_modification (dictionary.get path file_tracker)]
- (wrap [path previous_modification current_modification])))
- current_files)]]
- (wrap [[directory
- [concern
- (let [with_deletions (list\fold dictionary.remove file_tracker deletions)
- with_creations (list\fold (function (_ [path last_modified] tracker)
- (dictionary.put path last_modified tracker))
- with_deletions
- creations)
- with_modifications (list\fold (function (_ [path previous_modification current_modification] tracker)
- (dictionary.put path current_modification tracker))
- with_creations
- modifications)]
- with_modifications)]]
- [creations
- modifications
- deletions]])))
-
-(def: #export (polling fs)
- (-> (//.System Promise) (Watcher Promise))
- (let [tracker (: (Var Directory_Tracker)
- (stm.var (dictionary.new text.hash)))]
- (implementation
- (def: (start new_concern path)
- (do {! promise.monad}
- [exists? (\ fs directory? path)]
- (if exists?
- (do !
- [updated? (stm.commit (..update_watch! new_concern path tracker))]
- (if updated?
- (wrap (#try.Success []))
- (do (try.with !)
- [file_tracker (..file_tracker fs path)]
- (do !
- [_ (stm.commit (stm.update (dictionary.put path [new_concern file_tracker]) tracker))]
- (wrap (#try.Success []))))))
- (wrap (exception.throw ..cannot_poll_a_non_existent_directory [path])))))
- (def: (concern path)
- (stm.commit
- (do stm.monad
- [@tracker (stm.read tracker)]
- (wrap (case (dictionary.get path @tracker)
- (#.Some [concern file_tracker])
- (#try.Success concern)
-
- #.None
- (exception.throw ..not_being_watched [path]))))))
- (def: (stop path)
- (stm.commit
- (do {! stm.monad}
- [@tracker (stm.read tracker)]
- (case (dictionary.get path @tracker)
- (#.Some [concern file_tracker])
- (do !
- [_ (stm.update (dictionary.remove path) tracker)]
- (wrap (#try.Success concern)))
-
- #.None
- (wrap (exception.throw ..not_being_watched [path]))))))
- (def: (poll _)
- (do promise.monad
- [@tracker (stm.commit (stm.read tracker))]
- (do {! (try.with promise.monad)}
- [changes (|> @tracker
- dictionary.entries
- (monad.map ! (..poll_directory_changes fs)))
- _ (do promise.monad
- [_ (stm.commit (stm.write (|> changes
- (list\map product.left)
- (dictionary.from_list text.hash))
- tracker))]
- (wrap (#try.Success [])))
- #let [[creations modifications deletions]
- (list\fold (function (_ [_ [creations modifications deletions]]
- [all_creations all_modifications all_deletions])
- [(list\compose creations all_creations)
- (list\compose modifications all_modifications)
- (list\compose deletions all_deletions)])
- [(list) (list) (list)]
- changes)]]
- (wrap ($_ list\compose
- (list\map (|>> product.left [..creation]) creations)
- (|> modifications
- (list.filter (function (_ [path previous_modification current_modification])
- (not (instant\= previous_modification current_modification))))
- (list\map (|>> product.left [..modification])))
- (list\map (|>> [..deletion]) deletions)
- )))))
- )))
-
-(def: #export (mock separator)
- (-> Text [(//.System Promise) (Watcher Promise)])
- (let [fs (//.mock separator)]
- [fs
- (..polling fs)]))
-
-(with_expansions [<jvm> (as_is (import: java/lang/Object)
-
- (import: java/lang/String)
-
- (import: (java/util/List a)
- ["#::."
- (size [] int)
- (get [int] a)])
-
- (def: (default_list list)
- (All [a] (-> (java/util/List a) (List a)))
- (let [size (.nat (java/util/List::size list))]
- (loop [idx 0
- output #.Nil]
- (if (n.< size idx)
- (recur (inc idx)
- (#.Cons (java/util/List::get (.int idx) list)
- output))
- output))))
-
- (import: (java/nio/file/WatchEvent$Kind a))
-
- (import: (java/nio/file/WatchEvent a)
- ["#::."
- (kind [] (java/nio/file/WatchEvent$Kind a))])
-
- (import: java/nio/file/Watchable)
-
- (import: java/nio/file/Path
- ["#::."
- (register [java/nio/file/WatchService [(java/nio/file/WatchEvent$Kind [? < java/lang/Object])]] #io #try java/nio/file/WatchKey)
- (toString [] java/lang/String)])
-
- (import: java/nio/file/StandardWatchEventKinds
- ["#::."
- (#static ENTRY_CREATE (java/nio/file/WatchEvent$Kind java/nio/file/Path))
- (#static ENTRY_MODIFY (java/nio/file/WatchEvent$Kind java/nio/file/Path))
- (#static ENTRY_DELETE (java/nio/file/WatchEvent$Kind java/nio/file/Path))])
-
- (def: (default_event_concern event)
- (All [a]
- (-> (java/nio/file/WatchEvent a) Concern))
- (let [kind (:as (java/nio/file/WatchEvent$Kind java/nio/file/Path)
- (java/nio/file/WatchEvent::kind event))]
- (cond (is? (java/nio/file/StandardWatchEventKinds::ENTRY_CREATE)
- kind)
- ..creation
-
- (is? (java/nio/file/StandardWatchEventKinds::ENTRY_MODIFY)
- kind)
- ..modification
-
- (is? (java/nio/file/StandardWatchEventKinds::ENTRY_DELETE)
- kind)
- ..deletion
-
- ## else
- ..none
- )))
-
- (import: java/nio/file/WatchKey
- ["#::."
- (reset [] #io boolean)
- (cancel [] #io void)
- (watchable [] java/nio/file/Watchable)
- (pollEvents [] #io (java/util/List (java/nio/file/WatchEvent ?)))])
-
- (def: default_key_concern
- (-> java/nio/file/WatchKey (IO Concern))
- (|>> java/nio/file/WatchKey::pollEvents
- (\ io.monad map (|>> ..default_list
- (list\map default_event_concern)
- (list\fold ..also ..none)))))
-
- (import: java/nio/file/WatchService
- ["#::."
- (poll [] #io #try #? java/nio/file/WatchKey)])
-
- (import: java/nio/file/FileSystem
- ["#::."
- (newWatchService [] #io #try java/nio/file/WatchService)])
-
- (import: java/nio/file/FileSystems
- ["#::."
- (#static getDefault [] java/nio/file/FileSystem)])
-
- (import: java/io/File
- ["#::."
- (new [java/lang/String])
- (toPath [] java/nio/file/Path)])
-
- (type: Watch_Event
- (java/nio/file/WatchEvent$Kind java/lang/Object))
-
- (def: (default_start watch_events watcher path)
- (-> (List Watch_Event) java/nio/file/WatchService //.Path (Promise (Try java/nio/file/WatchKey)))
- (let [watch_events' (list\fold (function (_ [index watch_event] watch_events')
- (ffi.array_write index watch_event watch_events'))
- (ffi.array (java/nio/file/WatchEvent$Kind java/lang/Object)
- (list.size watch_events))
- (list.enumeration watch_events))]
- (promise.future
- (java/nio/file/Path::register watcher
- watch_events'
- (|> path java/io/File::new java/io/File::toPath)))))
-
- (def: (default_poll watcher)
- (-> java/nio/file/WatchService (IO (Try (List [Concern //.Path]))))
- (loop [output (: (List [Concern //.Path])
- (list))]
- (do (try.with io.monad)
- [?key (java/nio/file/WatchService::poll watcher)]
- (case ?key
- (#.Some key)
- (do {! io.monad}
- [valid? (java/nio/file/WatchKey::reset key)]
- (if valid?
- (do !
- [#let [path (|> key
- java/nio/file/WatchKey::watchable
- (:as java/nio/file/Path)
- java/nio/file/Path::toString
- (:as //.Path))]
- concern (..default_key_concern key)]
- (recur (#.Cons [concern path]
- output)))
- (recur output)))
-
- #.None
- (wrap output)))))
-
- (def: (watch_events concern)
- (-> Concern (List Watch_Event))
- ($_ list\compose
- (if (..creation? concern)
- (list (:as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_CREATE)))
- (list))
- (if (..modification? concern)
- (list (:as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_MODIFY)))
- (list))
- (if (..deletion? concern)
- (list (:as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_DELETE)))
- (list))
- ))
-
- (def: #export default
- (IO (Try (Watcher Promise)))
- (do (try.with io.monad)
- [watcher (java/nio/file/FileSystem::newWatchService
- (java/nio/file/FileSystems::getDefault))
- #let [tracker (stm.var (: (Dictionary //.Path [Concern java/nio/file/WatchKey])
- (dictionary.new text.hash)))
-
- stop (: (-> //.Path (Promise (Try Concern)))
- (function (_ path)
- (do {! promise.monad}
- [@tracker (stm.commit (stm.read tracker))]
- (case (dictionary.get path @tracker)
- (#.Some [concern key])
- (do !
- [_ (promise.future
- (java/nio/file/WatchKey::cancel key))
- _ (stm.commit (stm.update (dictionary.remove path) tracker))]
- (wrap (#try.Success concern)))
-
- #.None
- (wrap (exception.throw ..not_being_watched [path]))))))]]
- (wrap (: (Watcher Promise)
- (implementation
- (def: (start concern path)
- (do promise.monad
- [?concern (stop path)]
- (do (try.with promise.monad)
- [key (..default_start (..watch_events (..also (try.default ..none ?concern)
- concern))
- watcher
- path)]
- (do promise.monad
- [_ (stm.commit (stm.update (dictionary.put path [concern key]) tracker))]
- (wrap (#try.Success []))))))
- (def: (concern path)
- (do promise.monad
- [@tracker (stm.commit (stm.read tracker))]
- (case (dictionary.get path @tracker)
- (#.Some [concern key])
- (wrap (#try.Success concern))
-
- #.None
- (wrap (exception.throw ..not_being_watched [path])))))
- (def: stop stop)
- (def: (poll _)
- (promise.future (..default_poll watcher)))
- )))))
- )]
- (for {@.old (as_is <jvm>)
- @.jvm (as_is <jvm>)}
- (as_is)))
diff --git a/stdlib/source/lux/world/input/keyboard.lux b/stdlib/source/lux/world/input/keyboard.lux
deleted file mode 100644
index 90068c197..000000000
--- a/stdlib/source/lux/world/input/keyboard.lux
+++ /dev/null
@@ -1,111 +0,0 @@
-(.module:
- [lux #*])
-
-(type: #export Key
- Nat)
-
-(template [<code> <name>]
- [(def: #export <name> Key <code>)]
-
- [00008 back_space]
- [00010 enter]
- [00016 shift]
- [00017 control]
- [00018 alt]
- [00020 caps_lock]
- [00027 escape]
- [00032 space]
- [00033 page_up]
- [00034 page_down]
- [00035 end]
- [00036 home]
-
- [00037 left]
- [00038 up]
- [00039 right]
- [00040 down]
-
- [00065 a]
- [00066 b]
- [00067 c]
- [00068 d]
- [00069 e]
- [00070 f]
- [00071 g]
- [00072 h]
- [00073 i]
- [00074 j]
- [00075 k]
- [00076 l]
- [00077 m]
- [00078 n]
- [00079 o]
- [00080 p]
- [00081 q]
- [00082 r]
- [00083 s]
- [00084 t]
- [00085 u]
- [00086 v]
- [00087 w]
- [00088 x]
- [00089 y]
- [00090 z]
-
- [00096 num_pad_0]
- [00097 num_pad_1]
- [00098 num_pad_2]
- [00099 num_pad_3]
- [00100 num_pad_4]
- [00101 num_pad_5]
- [00102 num_pad_6]
- [00103 num_pad_7]
- [00104 num_pad_8]
- [00105 num_pad_9]
-
- [00127 delete]
- [00144 num_lock]
- [00145 scroll_lock]
- [00154 print_screen]
- [00155 insert]
- [00524 windows]
-
- [00112 f1]
- [00113 f2]
- [00114 f3]
- [00115 f4]
- [00116 f5]
- [00117 f6]
- [00118 f7]
- [00119 f8]
- [00120 f9]
- [00121 f10]
- [00122 f11]
- [00123 f12]
- [61440 f13]
- [61441 f14]
- [61442 f15]
- [61443 f16]
- [61444 f17]
- [61445 f18]
- [61446 f19]
- [61447 f20]
- [61448 f21]
- [61449 f22]
- [61450 f23]
- [61451 f24]
- )
-
-(type: #export Press
- {#pressed? Bit
- #input Key})
-
-(template [<bit> <name>]
- [(def: #export (<name> key)
- (-> Key Press)
- {#pressed? <bit>
- #input key})]
-
- [#0 release]
- [#1 press]
- )
diff --git a/stdlib/source/lux/world/net.lux b/stdlib/source/lux/world/net.lux
deleted file mode 100644
index e4133710e..000000000
--- a/stdlib/source/lux/world/net.lux
+++ /dev/null
@@ -1,12 +0,0 @@
-(.module:
- [lux (#- Location)])
-
-(type: #export Address Text)
-
-(type: #export Port Nat)
-
-(type: #export URL Text)
-
-(type: #export Location
- {#address Address
- #port Port})
diff --git a/stdlib/source/lux/world/net/http.lux b/stdlib/source/lux/world/net/http.lux
deleted file mode 100644
index 6682c24bd..000000000
--- a/stdlib/source/lux/world/net/http.lux
+++ /dev/null
@@ -1,79 +0,0 @@
-(.module:
- [lux #*
- [control
- [try (#+ Try)]
- [concurrency
- [promise (#+ Promise)]
- [frp (#+ Channel)]]
- [parser
- ["." environment (#+ Environment)]]]
- [data
- [binary (#+ Binary)]]]
- [// (#+ URL)
- [uri (#+ URI)]])
-
-(type: #export Version
- Text)
-
-(type: #export Method
- #Post
- #Get
- #Put
- #Patch
- #Delete
- #Head
- #Connect
- #Options
- #Trace)
-
-(type: #export Port
- Nat)
-
-(type: #export Status
- Nat)
-
-(type: #export Headers
- Environment)
-
-(def: #export empty
- Headers
- environment.empty)
-
-(type: #export Header
- (-> Headers Headers))
-
-(type: #export (Body !)
- (-> (Maybe Nat) (! (Try [Nat Binary]))))
-
-(type: #export Scheme
- #HTTP
- #HTTPS)
-
-(type: #export Address
- {#port Port
- #host Text})
-
-(type: #export Identification
- {#local Address
- #remote Address})
-
-(type: #export Protocol
- {#version Version
- #scheme Scheme})
-
-(type: #export Resource
- {#method Method
- #uri URI})
-
-(type: #export (Message !)
- {#headers Headers
- #body (Body !)})
-
-(type: #export (Request !)
- [Identification Protocol Resource (Message !)])
-
-(type: #export (Response !)
- [Status (Message !)])
-
-(type: #export (Server !)
- (-> (Request !) (! (Response !))))
diff --git a/stdlib/source/lux/world/net/http/client.lux b/stdlib/source/lux/world/net/http/client.lux
deleted file mode 100644
index 986ef0c89..000000000
--- a/stdlib/source/lux/world/net/http/client.lux
+++ /dev/null
@@ -1,226 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- ["." ffi]
- [abstract
- ["." monad (#+ do)]]
- [control
- [pipe (#+ case>)]
- ["." io (#+ IO)]
- ["." try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." binary (#+ Binary)]
- ["." maybe ("#\." functor)]
- ["." text]
- [collection
- ["." dictionary]]]
- [math
- [number
- ["n" nat]
- ["i" int]]]]
- ["." //
- [// (#+ URL)]])
-
-(interface: #export (Client !)
- (: (-> //.Method URL //.Headers (Maybe Binary)
- (! (Try (//.Response !))))
- request))
-
-(template [<name> <method>]
- [(def: #export (<name> url headers data client)
- (All [!]
- (-> URL //.Headers (Maybe Binary) (Client !)
- (! (Try (//.Response !)))))
- (\ client request <method> url headers data))]
-
- [post #//.Post]
- [get #//.Get]
- [put #//.Put]
- [patch #//.Patch]
- [delete #//.Delete]
- [head #//.Head]
- [connect #//.Connect]
- [options #//.Options]
- [trace #//.Trace]
- )
-
-(def: default_buffer_size
- (n.* 1,024 1,024))
-
-(def: empty_body
- [Nat Binary]
- [0 (binary.create 0)])
-
-(def: (body_of data)
- (-> Binary [Nat Binary])
- [(binary.size data) data])
-
-(with_expansions [<jvm> (as_is (ffi.import: java/lang/String)
-
- (ffi.import: java/lang/AutoCloseable
- ["#::."
- (close [] #io #try void)])
-
- (ffi.import: java/io/InputStream)
-
- (ffi.import: java/io/OutputStream
- ["#::."
- (flush [] #io #try void)
- (write [[byte]] #io #try void)])
-
- (ffi.import: java/net/URLConnection
- ["#::."
- (setDoOutput [boolean] #io #try void)
- (setRequestProperty [java/lang/String java/lang/String] #io #try void)
- (getInputStream [] #io #try java/io/InputStream)
- (getOutputStream [] #io #try java/io/OutputStream)
- (getHeaderFieldKey [int] #io #try #? java/lang/String)
- (getHeaderField [int] #io #try #? java/lang/String)])
-
- (ffi.import: java/net/HttpURLConnection
- ["#::."
- (setRequestMethod [java/lang/String] #io #try void)
- (getResponseCode [] #io #try int)])
-
- (ffi.import: java/net/URL
- ["#::."
- (new [java/lang/String])
- (openConnection [] #io #try java/net/URLConnection)])
-
- (ffi.import: java/io/BufferedInputStream
- ["#::."
- (new [java/io/InputStream])
- (read [[byte] int int] #io #try int)])
-
- (def: jvm_method
- (-> //.Method Text)
- (|>> (case> #//.Post "POST"
- #//.Get "GET"
- #//.Put "PUT"
- #//.Patch "PATCH"
- #//.Delete "DELETE"
- #//.Head "HEAD"
- #//.Connect "CONNECT"
- #//.Options "OPTIONS"
- #//.Trace "TRACE")))
-
- (def: (default_body input)
- (-> java/io/BufferedInputStream (//.Body IO))
- (|>> (maybe\map (|>> [true]))
- (maybe.default [false ..default_buffer_size])
- (case> [_ 0]
- (do (try.with io.monad)
- [_ (java/lang/AutoCloseable::close input)]
- (wrap ..empty_body))
-
- [partial? buffer_size]
- (let [buffer (binary.create buffer_size)]
- (if partial?
- (loop [so_far +0]
- (do {! (try.with io.monad)}
- [#let [remaining (i.- so_far (.int buffer_size))]
- bytes_read (java/io/BufferedInputStream::read buffer so_far remaining input)]
- (case bytes_read
- -1 (do !
- [_ (java/lang/AutoCloseable::close input)]
- (wrap [(.nat so_far) buffer]))
- +0 (recur so_far)
- _ (if (i.= remaining bytes_read)
- (wrap [buffer_size buffer])
- (recur (i.+ bytes_read so_far))))))
- (loop [so_far +0
- output (\ binary.monoid identity)]
- (do {! (try.with io.monad)}
- [#let [remaining (i.- so_far (.int buffer_size))]
- bytes_read (java/io/BufferedInputStream::read buffer so_far remaining input)]
- (case bytes_read
- -1 (do !
- [_ (java/lang/AutoCloseable::close input)]
- (case so_far
- +0 (wrap (..body_of output))
- _ (|> buffer
- (binary.slice 0 (.nat so_far))
- (\ try.functor map
- (|>> (\ binary.monoid compose output)
- ..body_of))
- (\ io.monad wrap))))
- +0 (recur so_far output)
- _ (if (i.= remaining bytes_read)
- (recur +0
- (\ binary.monoid compose output buffer))
- (recur (i.+ bytes_read so_far)
- output))))))))))
-
- (def: (default_headers connection)
- (-> java/net/HttpURLConnection (IO (Try //.Headers)))
- (loop [index +0
- headers //.empty]
- (do {! (try.with io.monad)}
- [?name (java/net/URLConnection::getHeaderFieldKey index connection)]
- (case ?name
- (#.Some name)
- (do !
- [?value (java/net/URLConnection::getHeaderField index connection)]
- (recur (inc index)
- (dictionary.put name (maybe.default "" ?value) headers)))
-
- #.None
- (wrap headers)))))
-
- (implementation: #export default
- (Client IO)
-
- (def: (request method url headers data)
- (: (IO (Try (//.Response IO)))
- (do {! (try.with io.monad)}
- [connection (|> url java/net/URL::new java/net/URL::openConnection)
- #let [connection (:as java/net/HttpURLConnection connection)]
- _ (java/net/HttpURLConnection::setRequestMethod (..jvm_method method) connection)
- _ (monad.map ! (function (_ [name value])
- (java/net/URLConnection::setRequestProperty name value connection))
- (dictionary.entries headers))
- _ (case data
- (#.Some data)
- (do !
- [_ (java/net/URLConnection::setDoOutput true connection)
- stream (java/net/URLConnection::getOutputStream connection)
- _ (java/io/OutputStream::write data stream)
- _ (java/io/OutputStream::flush stream)
- _ (java/lang/AutoCloseable::close stream)]
- (wrap []))
-
- #.None
- (wrap []))
- status (java/net/HttpURLConnection::getResponseCode connection)
- headers (..default_headers connection)
- input (|> connection
- java/net/URLConnection::getInputStream
- (\ ! map (|>> java/io/BufferedInputStream::new)))]
- (wrap [(.nat status)
- {#//.headers headers
- #//.body (..default_body input)}]))))))]
- (for {@.old (as_is <jvm>)
- @.jvm (as_is <jvm>)}
- (as_is)))
-
-(implementation: #export (async client)
- (-> (Client IO) (Client Promise))
-
- (def: (request method url headers data)
- (|> (\ client request method url headers data)
- promise.future
- (\ promise.monad map
- (|>> (case> (#try.Success [status message])
- (#try.Success [status (update@ #//.body (: (-> (//.Body IO) (//.Body Promise))
- (function (_ body)
- (|>> body promise.future)))
- message)])
-
- (#try.Failure error)
- (#try.Failure error)))))))
-
-(def: #export headers
- (-> (List [Text Text]) //.Headers)
- (dictionary.from_list text.hash))
diff --git a/stdlib/source/lux/world/net/http/cookie.lux b/stdlib/source/lux/world/net/http/cookie.lux
deleted file mode 100644
index 969f951ec..000000000
--- a/stdlib/source/lux/world/net/http/cookie.lux
+++ /dev/null
@@ -1,87 +0,0 @@
-(.module:
- [lux #*
- [control
- [monad (#+ do)]
- ["." try (#+ Try)]
- ["p" parser ("#\." monad)
- ["l" text (#+ Parser)]]]
- [data
- [number
- ["i" int]]
- [text
- ["%" format (#+ format)]]
- [format
- ["." context (#+ Context)]]
- [collection
- ["." dictionary]]]
- [time
- ["." duration (#+ Duration)]]]
- ["." // (#+ Header)
- ["." header]])
-
-(type: #export Directive (-> Text Text))
-
-(def: (directive extension)
- (-> Text Directive)
- (function (_ so-far)
- (format so-far "; " extension)))
-
-(def: #export (set name value)
- (-> Text Text Header)
- (header.add "Set-Cookie" (format name "=" value)))
-
-(def: #export (max-age duration)
- (-> Duration Directive)
- (let [seconds (duration.query duration.second duration)]
- (..directive (format "Max-Age=" (if (i.< +0 seconds)
- (%.int seconds)
- (%.nat (.nat seconds)))))))
-
-(template [<name> <prefix>]
- [(def: #export (<name> value)
- (-> Text Directive)
- (..directive (format <prefix> "=" value)))]
-
- [domain "Domain"]
- [path "Path"]
- )
-
-(template [<name> <tag>]
- [(def: #export <name>
- Directive
- (..directive <tag>))]
-
- [secure "Secure"]
- [http-only "HttpOnly"]
- )
-
-(type: #export CSRF-Policy
- #Strict
- #Lax)
-
-(def: #export (same-site policy)
- (-> CSRF-Policy Directive)
- (..directive (format "SameSite=" (case policy
- #Strict "Strict"
- #Lax "Lax"))))
-
-(def: (cookie context)
- (-> Context (Parser Context))
- (do p.monad
- [key (l.slice (l.many! (l.none-of! "=")))
- _ (l.this "=")
- value (l.slice (l.many! (l.none-of! ";")))]
- (wrap (dictionary.put key value context))))
-
-(def: (cookies context)
- (-> Context (Parser Context))
- ($_ p.either
- (do p.monad
- [context' (..cookie context)
- _ (l.this "; ")]
- (cookies context'))
- (p\wrap context)))
-
-(def: #export (get header)
- (-> Text (Try Context))
- (l.run header (..cookies context.empty)))
diff --git a/stdlib/source/lux/world/net/http/header.lux b/stdlib/source/lux/world/net/http/header.lux
deleted file mode 100644
index 4cd1daa67..000000000
--- a/stdlib/source/lux/world/net/http/header.lux
+++ /dev/null
@@ -1,34 +0,0 @@
-(.module:
- [lux #*
- [control
- [pipe (#+ case>)]]
- [data
- [text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary (#+ Dictionary)]]]]
- [// (#+ Header)
- ["." mime (#+ MIME)]
- [// (#+ URL)]])
-
-(def: #export (add name value)
- (-> Text Text Header)
- (dictionary.upsert name ""
- (|>> (case>
- ""
- value
-
- previous
- (format previous "," value)))))
-
-(def: #export content-length
- (-> Nat Header)
- (|>> %.nat (..add "Content-Length")))
-
-(def: #export content-type
- (-> MIME Header)
- (|>> mime.name (..add "Content-Type")))
-
-(def: #export location
- (-> URL Header)
- (..add "Location"))
diff --git a/stdlib/source/lux/world/net/http/mime.lux b/stdlib/source/lux/world/net/http/mime.lux
deleted file mode 100644
index 1029e6bb9..000000000
--- a/stdlib/source/lux/world/net/http/mime.lux
+++ /dev/null
@@ -1,99 +0,0 @@
-(.module:
- [lux #*
- [data
- ["." text
- ["%" format (#+ format)]
- ["." encoding (#+ Encoding)]]]
- [type
- abstract]])
-
-(abstract: #export MIME
- Text
-
- {#doc "Multipurpose Internet Mail Extensions"}
-
- (def: #export mime
- (-> Text MIME)
- (|>> :abstraction))
-
- (def: #export name
- (-> MIME Text)
- (|>> :representation))
- )
-
-## https://developer.mozilla.org/en-US/docs/Web/HTTP/Basics_of_HTTP/MIME_types/Complete_list_of_MIME_types
-(template [<name> <type>]
- [(def: #export <name> MIME (..mime <type>))]
-
- [aac-audio "audio/aac"]
- [abiword "application/x-abiword"]
- [avi "video/x-msvideo"]
- [amazon-kindle-ebook "application/vnd.amazon.ebook"]
- [binary "application/octet-stream"]
- [bitmap "image/bmp"]
- [bzip "application/x-bzip"]
- [bzip2 "application/x-bzip2"]
- [c-shell "application/x-csh"]
- [css "text/css"]
- [csv "text/csv"]
- [microsoft-word "application/msword"]
- [microsoft-word-openxml "application/vnd.openxmlformats-officedocument.wordprocessingml.document"]
- [ms-embedded-opentype-fonts "application/vnd.ms-fontobject"]
- [epub "application/epub+zip"]
- [ecmascript "application/ecmascript"]
- [gif "image/gif"]
- [html "text/html"]
- [icon "image/x-icon"]
- [icalendar "text/calendar"]
- [jar "application/java-archive"]
- [jpeg "image/jpeg"]
- [javascript "application/javascript"]
- [json "application/json"]
- [midi "audio/midi"]
- [mpeg "video/mpeg"]
- [apple-installer-package "application/vnd.apple.installer+xml"]
- [opendocument-presentation "application/vnd.oasis.opendocument.presentation"]
- [opendocument-spreadsheet "application/vnd.oasis.opendocument.spreadsheet"]
- [opendocument-text "application/vnd.oasis.opendocument.text"]
- [ogg-audio "audio/ogg"]
- [ogg-video "video/ogg"]
- [ogg "application/ogg"]
- [opentype-font "font/otf"]
- [png "image/png"]
- [pdf "application/pdf"]
- [microsoft-powerpoint "application/vnd.ms-powerpoint"]
- [microsoft-powerpoint-openxml "application/vnd.openxmlformats-officedocument.presentationml.presentation"]
- [rar "application/x-rar-compressed"]
- [rtf "application/rtf"]
- [bourne-shell "application/x-sh"]
- [svg "image/svg+xml"]
- [flash "application/x-shockwave-flash"]
- [tar "application/x-tar"]
- [tiff "image/tiff"]
- [typescript "application/typescript"]
- [truetype-font "font/ttf"]
- [microsoft-visio "application/vnd.visio"]
- [wav "audio/wav"]
- [webm-audio "audio/webm"]
- [webm-video "video/webm"]
- [webp "image/webp"]
- [woff "font/woff"]
- [woff2 "font/woff2"]
- [xhtml "application/xhtml+xml"]
- [microsoft-excel "application/vnd.ms-excel"]
- [microsoft-excel-openxml "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"]
- [xml "application/xml"]
- [xul "application/vnd.mozilla.xul+xml"]
- [zip "application/zip"]
- [!3gpp-audio "audio/3gpp"]
- [!3gpp "video/3gpp"]
- [!3gpp2-audio "audio/3gpp2"]
- [!3gpp2 "video/3gpp2"]
- [!7z "application/x-7z-compressed"]
- )
-
-(def: #export (text encoding)
- (-> Encoding MIME)
- (..mime (format "text/plain; charset=" text.double-quote (encoding.name encoding) text.double-quote)))
-
-(def: #export utf-8 MIME (..text encoding.utf-8))
diff --git a/stdlib/source/lux/world/net/http/query.lux b/stdlib/source/lux/world/net/http/query.lux
deleted file mode 100644
index 006942bfe..000000000
--- a/stdlib/source/lux/world/net/http/query.lux
+++ /dev/null
@@ -1,64 +0,0 @@
-(.module:
- [lux #*
- [control
- pipe
- [monad (#+ do)]
- ["." try (#+ Try)]
- ["p" parser
- ["l" text (#+ Parser)]]]
- [data
- [number
- ["." nat]]
- ["." text
- ["%" format (#+ format)]]
- [format
- ["." context (#+ Context)]]
- [collection
- ["." dictionary]]]])
-
-(def: component
- (Parser Text)
- (p.rec
- (function (_ component)
- (do {! p.monad}
- [head (l.some (l.none-of "+%&;"))]
- ($_ p.either
- (p.after (p.either l.end
- (l.this "&"))
- (wrap head))
- (do !
- [_ (l.this "+")
- tail component]
- (wrap (format head " " tail)))
- (do !
- [_ (l.this "%")
- code (|> (l.exactly 2 l.hexadecimal)
- (p.codec nat.hex)
- (\ ! map text.from-code))
- tail component]
- (wrap (format head code tail))))))))
-
-(def: (form context)
- (-> Context (Parser Context))
- ($_ p.either
- (do p.monad
- [_ l.end]
- (wrap context))
- (do {! p.monad}
- [key (l.some (l.none-of "=&;"))
- key (l.local key ..component)]
- (p.either (do !
- [_ (l.this "=")
- value ..component]
- (form (dictionary.put key value context)))
- (do !
- [_ ($_ p.or
- (l.one-of "&;")
- l.end)]
- (form (dictionary.put key "" context)))))
- ## if invalid form data, just stop parsing...
- (\ p.monad wrap context)))
-
-(def: #export (parameters raw)
- (-> Text (Try Context))
- (l.run raw (..form context.empty)))
diff --git a/stdlib/source/lux/world/net/http/request.lux b/stdlib/source/lux/world/net/http/request.lux
deleted file mode 100644
index 0d9354cd8..000000000
--- a/stdlib/source/lux/world/net/http/request.lux
+++ /dev/null
@@ -1,127 +0,0 @@
-(.module:
- [lux #*
- [control
- pipe
- ["." monad (#+ do)]
- ["." try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise)]
- ["." frp]]
- [parser
- ["<.>" json]]]
- [data
- ["." maybe]
- ["." number
- ["n" nat]]
- ["." text
- ["." encoding]]
- [format
- ["." json (#+ JSON)]
- ["." context (#+ Context Property)]]
- [collection
- ["." list ("#\." functor fold)]
- ["." dictionary]]]
- [world
- ["." binary (#+ Binary)]]]
- ["." // (#+ Body Response Server)
- ["#." response]
- ["#." query]
- ["#." cookie]])
-
-(def: (merge inputs)
- (-> (List Binary) Binary)
- (let [[_ output] (try.assume
- (monad.fold try.monad
- (function (_ input [offset output])
- (let [amount (binary.size input)]
- (\ try.functor map (|>> [(n.+ amount offset)])
- (binary.copy amount 0 input offset output))))
- [0 (|> inputs
- (list\map binary.size)
- (list\fold n.+ 0)
- binary.create)]
- inputs))]
- output))
-
-(def: (read-text-body body)
- (-> Body (Promise (Try Text)))
- (do promise.monad
- [blobs (frp.consume body)]
- (wrap (\ encoding.utf8 decode (merge blobs)))))
-
-(def: failure (//response.bad-request ""))
-
-(def: #export (json reader server)
- (All [a] (-> (<json>.Reader a) (-> a Server) Server))
- (function (_ (^@ request [identification protocol resource message]))
- (do promise.monad
- [?raw (read-text-body (get@ #//.body message))]
- (case (do try.monad
- [raw ?raw
- content (\ json.codec decode raw)]
- (json.run content reader))
- (#try.Success input)
- (server input request)
-
- (#try.Failure error)
- (promise.resolved ..failure)))))
-
-(def: #export (text server)
- (-> (-> Text Server) Server)
- (function (_ (^@ request [identification protocol resource message]))
- (do promise.monad
- [?raw (read-text-body (get@ #//.body message))]
- (case ?raw
- (#try.Success content)
- (server content request)
-
- (#try.Failure error)
- (promise.resolved ..failure)))))
-
-(def: #export (query property server)
- (All [a] (-> (Property a) (-> a Server) Server))
- (function (_ [identification protocol resource message])
- (let [full (get@ #//.uri resource)
- [uri query] (|> full
- (text.split-with "?")
- (maybe.default [full ""]))]
- (case (do try.monad
- [query (//query.parameters query)
- input (context.run query property)]
- (wrap [[identification protocol (set@ #//.uri uri resource) message]
- input]))
- (#try.Success [request input])
- (server input request)
-
- (#try.Failure error)
- (promise.resolved ..failure)))))
-
-(def: #export (form property server)
- (All [a] (-> (Property a) (-> a Server) Server))
- (function (_ (^@ request [identification protocol resource message]))
- (do promise.monad
- [?body (read-text-body (get@ #//.body message))]
- (case (do try.monad
- [body ?body
- form (//query.parameters body)]
- (context.run form property))
- (#try.Success input)
- (server input request)
-
- (#try.Failure error)
- (promise.resolved ..failure)))))
-
-(def: #export (cookies property server)
- (All [a] (-> (Property a) (-> a Server) Server))
- (function (_ (^@ request [identification protocol resource message]))
- (case (do try.monad
- [cookies (|> (get@ #//.headers message)
- (dictionary.get "Cookie")
- (maybe.default "")
- //cookie.get)]
- (context.run cookies property))
- (#try.Success input)
- (server input request)
-
- (#try.Failure error)
- (promise.resolved ..failure))))
diff --git a/stdlib/source/lux/world/net/http/response.lux b/stdlib/source/lux/world/net/http/response.lux
deleted file mode 100644
index 3e06614d2..000000000
--- a/stdlib/source/lux/world/net/http/response.lux
+++ /dev/null
@@ -1,73 +0,0 @@
-(.module:
- [lux (#- static)
- [control
- [concurrency
- ["." promise]
- ["." frp ("#\." monad)]]]
- [data
- ["." text
- ["." encoding]]
- [format
- ["." html]
- ["." css (#+ CSS)]
- ["." context]
- ["." json (#+ JSON) ("#\." codec)]]]
- ["." io]
- [world
- ["." binary (#+ Binary)]]]
- ["." // (#+ Status Body Response Server)
- ["." status]
- ["." mime (#+ MIME)]
- ["." header]
- [// (#+ URL)]])
-
-(def: #export (static response)
- (-> Response Server)
- (function (_ request)
- (promise.resolved response)))
-
-(def: #export empty
- (-> Status Response)
- (let [body (frp\wrap (\ encoding.utf8 encode ""))]
- (function (_ status)
- [status
- {#//.headers (|> context.empty
- (header.content-length 0)
- (header.content-type mime.utf-8))
- #//.body body}])))
-
-(def: #export (temporary-redirect to)
- (-> URL Response)
- (let [[status message] (..empty status.temporary-redirect)]
- [status (update@ #//.headers (header.location to) message)]))
-
-(def: #export not-found
- Response
- (..empty status.not-found))
-
-(def: #export (content status type data)
- (-> Status MIME Binary Response)
- [status
- {#//.headers (|> context.empty
- (header.content-length (binary.size data))
- (header.content-type type))
- #//.body (frp\wrap data)}])
-
-(def: #export bad-request
- (-> Text Response)
- (|>> (\ encoding.utf8 encode) (content status.bad-request mime.utf-8)))
-
-(def: #export ok
- (-> MIME Binary Response)
- (content status.ok))
-
-(template [<name> <type> <mime> <pre>]
- [(def: #export <name>
- (-> <type> Response)
- (|>> <pre> (\ encoding.utf8 encode) (..ok <mime>)))]
-
- [text Text mime.utf-8 (<|)]
- [html html.Document mime.html html.html]
- [css CSS mime.css css.css]
- [json JSON mime.json json\encode]
- )
diff --git a/stdlib/source/lux/world/net/http/route.lux b/stdlib/source/lux/world/net/http/route.lux
deleted file mode 100644
index 32bdf1213..000000000
--- a/stdlib/source/lux/world/net/http/route.lux
+++ /dev/null
@@ -1,73 +0,0 @@
-(.module:
- [lux (#- or)
- [control
- [monad (#+ do)]
- [concurrency
- ["." promise]]]
- [data
- ["." maybe]
- ["." text]
- [number
- ["n" nat]]]]
- ["." // (#+ URI Server)
- ["#." status]
- ["#." response]])
-
-(template [<scheme> <name>]
- [(def: #export (<name> server)
- (-> Server Server)
- (function (_ (^@ request [identification protocol resource message]))
- (case (get@ #//.scheme protocol)
- <scheme>
- (server request)
-
- _
- (promise.resolved //response.not-found))))]
-
- [#//.HTTP http]
- [#//.HTTPS https]
- )
-
-(template [<method> <name>]
- [(def: #export (<name> server)
- (-> Server Server)
- (function (_ (^@ request [identification protocol resource message]))
- (case (get@ #//.method resource)
- <method>
- (server request)
-
- _
- (promise.resolved //response.not-found))))]
-
- [#//.Get get]
- [#//.Post post]
- [#//.Put put]
- [#//.Patch patch]
- [#//.Delete delete]
- [#//.Head head]
- [#//.Connect connect]
- [#//.Options options]
- [#//.Trace trace]
- )
-
-(def: #export (uri path server)
- (-> URI Server Server)
- (function (_ [identification protocol resource message])
- (if (text.starts-with? path (get@ #//.uri resource))
- (server [identification
- protocol
- (update@ #//.uri
- (|>> (text.clip' (text.size path)) maybe.assume)
- resource)
- message])
- (promise.resolved //response.not-found))))
-
-(def: #export (or primary alternative)
- (-> Server Server Server)
- (function (_ request)
- (do promise.monad
- [response (primary request)
- #let [[status message] response]]
- (if (n.= //status.not-found status)
- (alternative request)
- (wrap response)))))
diff --git a/stdlib/source/lux/world/net/http/status.lux b/stdlib/source/lux/world/net/http/status.lux
deleted file mode 100644
index cb0e8a8af..000000000
--- a/stdlib/source/lux/world/net/http/status.lux
+++ /dev/null
@@ -1,82 +0,0 @@
-(.module:
- [lux #*]
- [// (#+ Status)])
-
-## https://en.wikipedia.org/wiki/List_of_HTTP_status_codes
-(template [<status> <name>]
- [(def: #export <name>
- Status
- <status>)]
-
- ## 1xx Informational response
- [100 continue]
- [101 switching_protocols]
- [102 processing]
- [103 early_hints]
-
- ## 2xx Success
- [200 ok]
- [201 created]
- [202 accepted]
- [203 non_authoritative_information]
- [204 no_content]
- [205 reset_content]
- [206 partial_content]
- [207 multi_status]
- [208 already_reported]
- [226 im_used]
-
- ## 3xx Redirection
- [300 multiple_choices]
- [301 moved_permanently]
- [302 found]
- [303 see_other]
- [304 not_modified]
- [305 use_proxy]
- [306 switch_proxy]
- [307 temporary_redirect]
- [308 permanent_redirect]
-
- ## 4xx Client errors
- [400 bad_request]
- [401 unauthorized]
- [402 payment_required]
- [403 forbidden]
- [404 not_found]
- [405 method_not_allowed]
- [406 not_acceptable]
- [407 proxy_authentication_required]
- [408 request_timeout]
- [409 conflict]
- [410 gone]
- [411 length_required]
- [412 precondition_failed]
- [413 payload_too_large]
- [414 uri_too_long]
- [415 unsupported_media_type]
- [416 range_not_satisfiable]
- [417 expectation_failed]
- [418 im_a_teapot]
- [421 misdirected_request]
- [422 unprocessable_entity]
- [423 locked]
- [424 failed_dependency]
- [426 upgrade_required]
- [428 precondition_required]
- [429 too_many_requests]
- [431 request_header_fields_too_large]
- [451 unavailable_for_legal_reasons]
-
- ## 5xx Server errors
- [500 internal_server_error]
- [501 not_implemented]
- [502 bad_gateway]
- [503 service_unavailable]
- [504 gateway_timeout]
- [505 http_version_not_supported]
- [506 variant_also_negotiates]
- [507 insufficient_storage]
- [508 loop_detected]
- [510 not_extended]
- [511 network_authentication_required]
- )
diff --git a/stdlib/source/lux/world/net/http/version.lux b/stdlib/source/lux/world/net/http/version.lux
deleted file mode 100644
index 4a693766d..000000000
--- a/stdlib/source/lux/world/net/http/version.lux
+++ /dev/null
@@ -1,12 +0,0 @@
-(.module:
- [lux #*]
- [// (#+ Version)])
-
-(template [<name> <version>]
- [(def: #export <name> Version <version>)]
-
- [v0_9 "0.9"]
- [v1_0 "1.0"]
- [v1_1 "1.1"]
- [v2_0 "2.0"]
- )
diff --git a/stdlib/source/lux/world/net/uri.lux b/stdlib/source/lux/world/net/uri.lux
deleted file mode 100644
index e7d70d108..000000000
--- a/stdlib/source/lux/world/net/uri.lux
+++ /dev/null
@@ -1,8 +0,0 @@
-(.module:
- [lux #*])
-
-(type: #export URI
- Text)
-
-(def: #export separator
- "/")
diff --git a/stdlib/source/lux/world/output/video/resolution.lux b/stdlib/source/lux/world/output/video/resolution.lux
deleted file mode 100644
index 2dbe1c8bc..000000000
--- a/stdlib/source/lux/world/output/video/resolution.lux
+++ /dev/null
@@ -1,46 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]]
- [data
- ["." product]]
- [math
- [number
- ["." nat]]]])
-
-(type: #export Resolution
- {#width Nat
- #height Nat})
-
-(def: #export hash
- (Hash Resolution)
- (product.hash nat.hash nat.hash))
-
-(def: #export equivalence
- (Equivalence Resolution)
- (\ ..hash &equivalence))
-
-## https://en.wikipedia.org/wiki/Display_resolution#Common_display_resolutions
-(template [<name> <width> <height>]
- [(def: #export <name>
- Resolution
- {#width <width>
- #height <height>})]
-
- [svga 800 600]
- [wsvga 1024 600]
- [xga 1024 768]
- [xga+ 1152 864]
- [wxga/16:9 1280 720]
- [wxga/5:3 1280 768]
- [wxga/16:10 1280 800]
- [sxga 1280 1024]
- [wxga+ 1440 900]
- [hd+ 1600 900]
- [wsxga+ 1680 1050]
- [fhd 1920 1080]
- [wuxga 1920 1200]
- [wqhd 2560 1440]
- [uhd-4k 3840 2160]
- )
diff --git a/stdlib/source/lux/world/program.lux b/stdlib/source/lux/world/program.lux
deleted file mode 100644
index c64f9ffa7..000000000
--- a/stdlib/source/lux/world/program.lux
+++ /dev/null
@@ -1,450 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- ["." ffi (#+ import:)]
- [abstract
- ["." monad (#+ Monad do)]]
- [control
- ["." function]
- ["." io (#+ IO)]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- [concurrency
- ["." atom]
- ["." promise (#+ Promise)]]
- [parser
- ["." environment (#+ Environment)]]]
- [data
- ["." bit ("#\." equivalence)]
- ["." maybe]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." array (#+ Array)]
- ["." dictionary (#+ Dictionary)]
- ["." list ("#\." functor)]]]
- ["." macro
- ["." template]]
- [math
- [number
- ["i" int]]]
- [type
- abstract]]
- [//
- [file (#+ Path)]
- [shell (#+ Exit)]])
-
-(exception: #export (unknown_environment_variable {name Text})
- (exception.report
- ["Name" (%.text name)]))
-
-(interface: #export (Program !)
- (: (-> Any (! (List Text)))
- available_variables)
- (: (-> Text (! (Try Text)))
- variable)
- (: Path
- home)
- (: Path
- directory)
- (: (-> Exit (! Nothing))
- exit))
-
-(def: #export (environment monad program)
- (All [!] (-> (Monad !) (Program !) (! Environment)))
- (do {! monad}
- [variables (\ program available_variables [])
- entries (monad.map ! (function (_ name)
- (\ ! map (|>> [name]) (\ program variable name)))
- variables)]
- (wrap (|> entries
- (list.all (function (_ [name value])
- (case value
- (#try.Success value)
- (#.Some [name value])
-
- (#try.Failure _)
- #.None)))
- (dictionary.from_list text.hash)))))
-
-(`` (implementation: #export (async program)
- (-> (Program IO) (Program Promise))
-
- (~~ (template [<method>]
- [(def: <method>
- (\ program <method>))]
-
- [home]
- [directory]
- ))
-
- (~~ (template [<method>]
- [(def: <method>
- (|>> (\ program <method>) promise.future))]
-
- [available_variables]
- [variable]
- [exit]
- ))))
-
-(def: #export (mock environment home directory)
- (-> Environment Path Path (Program IO))
- (let [@dead? (atom.atom false)]
- (implementation
- (def: available_variables
- (function.constant (io.io (dictionary.keys environment))))
- (def: (variable name)
- (io.io (case (dictionary.get name environment)
- (#.Some value)
- (#try.Success value)
-
- #.None
- (exception.throw ..unknown_environment_variable [name]))))
- (def: home
- home)
- (def: directory
- directory)
- (def: (exit code)
- (io.io (error! (%.int code)))))))
-
-## Do not trust the values of environment variables
-## https://wiki.sei.cmu.edu/confluence/display/java/ENV02-J.+Do+not+trust+the+values+of+environment+variables
-
-(with_expansions [<jvm> (as_is (import: java/lang/String)
-
- (import: (java/util/Iterator a)
- ["#::."
- (hasNext [] boolean)
- (next [] a)])
-
- (import: (java/util/Set a)
- ["#::."
- (iterator [] (java/util/Iterator a))])
-
- (import: (java/util/Map k v)
- ["#::."
- (keySet [] (java/util/Set k))])
-
- (import: java/lang/System
- ["#::."
- (#static getenv [] (java/util/Map java/lang/String java/lang/String))
- (#static getenv #as resolveEnv [java/lang/String] #io #? java/lang/String)
- (#static getProperty [java/lang/String] #? java/lang/String)
- (#static exit [int] #io void)])
-
- (def: (jvm\\consume iterator)
- (All [a] (-> (java/util/Iterator a) (List a)))
- (if (java/util/Iterator::hasNext iterator)
- (#.Cons (java/util/Iterator::next iterator)
- (jvm\\consume iterator))
- #.Nil))
- )]
- (for {@.old (as_is <jvm>)
- @.jvm (as_is <jvm>)
- @.js (as_is (def: default_exit!
- (-> Exit (IO Nothing))
- (|>> %.int error! io.io))
-
- (import: NodeJs_Process
- ["#::."
- (exit [ffi.Number] #io Nothing)
- (cwd [] #io Path)])
-
- (def: (exit_node_js! code)
- (-> Exit (IO Nothing))
- (case (ffi.constant ..NodeJs_Process [process])
- (#.Some process)
- (NodeJs_Process::exit (i.frac code) process)
-
- #.None
- (..default_exit! code)))
-
- (import: Browser_Window
- ["#::."
- (close [] Nothing)])
-
- (import: Browser_Location
- ["#::."
- (reload [] Nothing)])
-
- (def: (exit_browser! code)
- (-> Exit (IO Nothing))
- (case [(ffi.constant ..Browser_Window [window])
- (ffi.constant ..Browser_Location [location])]
- [(#.Some window) (#.Some location)]
- (exec
- (Browser_Window::close [] window)
- (Browser_Location::reload [] location)
- (..default_exit! code))
-
- [(#.Some window) #.None]
- (exec
- (Browser_Window::close [] window)
- (..default_exit! code))
-
- [#.None (#.Some location)]
- (exec
- (Browser_Location::reload [] location)
- (..default_exit! code))
-
- [#.None #.None]
- (..default_exit! code)))
-
- (import: Object
- ["#::."
- (#static entries [Object] (Array (Array ffi.String)))])
-
- (import: NodeJs_OS
- ["#::."
- (homedir [] #io Path)])
-
- (template [<name> <path>]
- [(def: (<name> _)
- (-> [] (Maybe (-> ffi.String Any)))
- (ffi.constant (-> ffi.String Any) <path>))]
-
- [normal_require [require]]
- [global_require [global require]]
- [process_load [global process mainModule constructor _load]]
- )
-
- (def: (require _)
- (-> [] (-> ffi.String Any))
- (case [(normal_require []) (global_require []) (process_load [])]
- (^or [(#.Some require) _ _]
- [_ (#.Some require) _]
- [_ _ (#.Some require)])
- require
-
- _
- (undefined))))
- @.python (as_is (import: os
- ["#::."
- (#static getcwd [] #io ffi.String)
- (#static _exit [ffi.Integer] #io Nothing)])
-
- (import: os/path
- ["#::."
- (#static expanduser [ffi.String] #io ffi.String)])
-
- (import: os/environ
- ["#::."
- (#static keys [] #io (Array ffi.String))
- (#static get [ffi.String] #io #? ffi.String)]))
- @.lua (as_is (ffi.import: LuaFile
- ["#::."
- (read [ffi.String] #io #? ffi.String)
- (close [] #io ffi.Boolean)])
-
- (ffi.import: (io/popen [ffi.String] #io #try #? LuaFile))
- (ffi.import: (os/getenv [ffi.String] #io #? ffi.String))
- (ffi.import: (os/exit [ffi.Integer] #io Nothing))
-
- (def: (run_command default command)
- (-> Text Text (IO Text))
- (do {! io.monad}
- [outcome (io/popen [command])]
- (case outcome
- (#try.Success outcome)
- (case outcome
- (#.Some file)
- (do !
- [?output (LuaFile::read ["*l"] file)
- _ (LuaFile::close [] file)]
- (wrap (maybe.default default ?output)))
-
- #.None
- (wrap default))
-
- (#try.Failure _)
- (wrap default)))))
- @.ruby (as_is (ffi.import: Env #as RubyEnv
- ["#::."
- (#static keys [] (Array Text))
- (#static fetch [Text] #io #? Text)])
-
- (ffi.import: "fileutils" FileUtils #as RubyFileUtils
- ["#::."
- (#static pwd [] #io Path)])
-
- (ffi.import: Dir #as RubyDir
- ["#::."
- (#static home [] #io Path)])
-
- (ffi.import: Kernel #as RubyKernel
- ["#::."
- (#static exit [Int] #io Nothing)]))
-
- ## @.php
- ## (as_is (ffi.import: (exit [Int] #io Nothing))
- ## ## https://www.php.net/manual/en/function.exit.php
- ## (ffi.import: (getcwd [] #io ffi.String))
- ## ## https://www.php.net/manual/en/function.getcwd.php
- ## (ffi.import: (getenv #as getenv/1 [ffi.String] #io ffi.String))
- ## (ffi.import: (getenv #as getenv/0 [] #io (Array ffi.String)))
- ## ## https://www.php.net/manual/en/function.getenv.php
- ## ## https://www.php.net/manual/en/function.array-keys.php
- ## (ffi.import: (array_keys [(Array ffi.String)] (Array ffi.String)))
- ## )
-
- ## @.scheme
- ## (as_is (ffi.import: (exit [Int] #io Nothing))
- ## ## https://srfi.schemers.org/srfi-98/srfi-98.html
- ## (abstract: Pair Any)
- ## (abstract: PList Any)
- ## (ffi.import: (get-environment-variables [] #io PList))
- ## (ffi.import: (car [Pair] Text))
- ## (ffi.import: (cdr [Pair] Text))
- ## (ffi.import: (car #as head [PList] Pair))
- ## (ffi.import: (cdr #as tail [PList] PList)))
- }
- (as_is)))
-
-(implementation: #export default
- (Program IO)
-
- (def: (available_variables _)
- (with_expansions [<jvm> (io.io (|> (java/lang/System::getenv)
- java/util/Map::keySet
- java/util/Set::iterator
- ..jvm\\consume))]
- (for {@.old <jvm>
- @.jvm <jvm>
- @.js (io.io (if ffi.on_node_js?
- (case (ffi.constant Object [process env])
- (#.Some process/env)
- (|> (Object::entries [process/env])
- array.to_list
- (list\map (|>> (array.read 0) maybe.assume)))
-
- #.None
- (list))
- (list)))
- @.python (\ io.monad map array.to_list (os/environ::keys []))
- ## Lua offers no way to get all the environment variables available.
- @.lua (io.io (list))
- @.ruby (|> (RubyEnv::keys [])
- array.to_list
- io.io)
- ## @.php (do io.monad
- ## [environment (..getenv/0 [])]
- ## (wrap (|> environment
- ## ..array_keys
- ## array.to_list
- ## (list\map (function (_ variable)
- ## [variable ("php array read" (:as Nat variable) environment)]))
- ## (dictionary.from_list text.hash))))
- ## @.scheme (do io.monad
- ## [input (..get-environment-variables [])]
- ## (loop [input input
- ## output environment.empty]
- ## (if ("scheme object nil?" input)
- ## (wrap output)
- ## (let [entry (..head input)]
- ## (recur (..tail input)
- ## (dictionary.put (..car entry) (..cdr entry) output))))))
- })))
-
- (def: (variable name)
- (template.let [(!fetch <method>)
- [(do io.monad
- [value (<method> name)]
- (wrap (case value
- (#.Some value)
- (#try.Success value)
-
- #.None
- (exception.throw ..unknown_environment_variable [name]))))]]
- (with_expansions [<jvm> (!fetch java/lang/System::resolveEnv)]
- (for {@.old <jvm>
- @.jvm <jvm>
- @.js (io.io (if ffi.on_node_js?
- (case (do maybe.monad
- [process/env (ffi.constant Object [process env])]
- (array.read (:as Nat name)
- (:as (Array Text) process/env)))
- (#.Some value)
- (#try.Success value)
-
- #.None
- (exception.throw ..unknown_environment_variable [name]))
- (exception.throw ..unknown_environment_variable [name])))
- @.python (!fetch os/environ::get)
- @.lua (!fetch os/getenv)
- @.ruby (!fetch RubyEnv::fetch)
- }))))
-
- (def: home
- (io.run
- (with_expansions [<default> (io.io "~")
- <jvm> (io.io (maybe.default "" (java/lang/System::getProperty "user.home")))]
- (for {@.old <jvm>
- @.jvm <jvm>
- @.js (if ffi.on_node_js?
- (|> (..require [] "os")
- (:as NodeJs_OS)
- (NodeJs_OS::homedir []))
- <default>)
- @.python (os/path::expanduser ["~"])
- @.lua (..run_command "~" "echo ~")
- @.ruby (RubyDir::home [])
- ## @.php (do io.monad
- ## [output (..getenv/1 ["HOME"])]
- ## (wrap (if (bit\= false (:as Bit output))
- ## "~"
- ## output)))
- }
- ## TODO: Replace dummy implementation.
- <default>))))
-
- (def: directory
- (io.run
- (with_expansions [<default> "."
- <jvm> (io.io (maybe.default "" (java/lang/System::getProperty "user.dir")))]
- (for {@.old <jvm>
- @.jvm <jvm>
- @.js (if ffi.on_node_js?
- (case (ffi.constant ..NodeJs_Process [process])
- (#.Some process)
- (NodeJs_Process::cwd [] process)
-
- #.None
- (io.io <default>))
- (io.io <default>))
- @.python (os::getcwd [])
- @.lua (do io.monad
- [#let [default <default>]
- on_windows (..run_command default "cd")]
- (if (is? default on_windows)
- (..run_command default "pwd")
- (wrap on_windows)))
- @.ruby (RubyFileUtils::pwd [])
- ## @.php (do io.monad
- ## [output (..getcwd [])]
- ## (wrap (if (bit\= false (:as Bit output))
- ## "."
- ## output)))
- }
- ## TODO: Replace dummy implementation.
- (io.io <default>)))))
-
- (def: (exit code)
- (with_expansions [<jvm> (do io.monad
- [_ (java/lang/System::exit code)]
- (wrap (undefined)))]
- (for {@.old <jvm>
- @.jvm <jvm>
- @.js (cond ffi.on_node_js?
- (..exit_node_js! code)
-
- ffi.on_browser?
- (..exit_browser! code)
-
- ## else
- (..default_exit! code))
- @.python (os::_exit [code])
- @.lua (os/exit [code])
- @.ruby (RubyKernel::exit [code])
- ## @.php (..exit [code])
- ## @.scheme (..exit [code])
- }))))
diff --git a/stdlib/source/lux/world/service/authentication.lux b/stdlib/source/lux/world/service/authentication.lux
deleted file mode 100644
index a9acda426..000000000
--- a/stdlib/source/lux/world/service/authentication.lux
+++ /dev/null
@@ -1,24 +0,0 @@
-(.module:
- [lux #*
- [control
- [try (#+ Try)]
- [security
- [capability (#+ Capability)]]]])
-
-(type: #export (Can-Register ! account secret value)
- (Capability [account secret value] (! (Try Any))))
-
-(type: #export (Can-Authenticate ! account secret value)
- (Capability [account secret] (! (Try value))))
-
-(type: #export (Can-Reset ! account secret)
- (Capability [account secret] (! (Try Any))))
-
-(type: #export (Can-Forget ! account)
- (Capability [account] (! (Try Any))))
-
-(type: #export (Service ! account secret value)
- {#can-register (Can-Register ! account secret value)
- #can-authenticate (Can-Authenticate ! account secret value)
- #can-reset (Can-Reset ! account secret)
- #can-forget (Can-Forget ! account)})
diff --git a/stdlib/source/lux/world/service/crud.lux b/stdlib/source/lux/world/service/crud.lux
deleted file mode 100644
index 82fee2c75..000000000
--- a/stdlib/source/lux/world/service/crud.lux
+++ /dev/null
@@ -1,32 +0,0 @@
-(.module:
- [lux #*
- [control
- ["." try (#+ Try)]
- [security
- ["!" capability (#+ capability:)]]]
- [time
- ["." instant (#+ Instant)]]])
-
-(type: #export ID Nat)
-
-(type: #export Time
- {#created Instant
- #updated Instant})
-
-(capability: #export (Can-Create ! entity)
- (can-create [Instant entity] (! (Try ID))))
-
-(capability: #export (Can-Retrieve ! entity)
- (can-retrieve ID (! (Try [Time entity]))))
-
-(capability: #export (Can-Update ! entity)
- (can-update [ID Instant entity] (! (Try Any))))
-
-(capability: #export (Can-Delete ! entity)
- (can-delete ID (! (Try Any))))
-
-(type: #export (CRUD ! entity)
- {#can-create (Can-Create ! entity)
- #can-retrieve (Can-Retrieve ! entity)
- #can-update (Can-Update ! entity)
- #can-delete (Can-Delete ! entity)})
diff --git a/stdlib/source/lux/world/service/inventory.lux b/stdlib/source/lux/world/service/inventory.lux
deleted file mode 100644
index dbdc93d6d..000000000
--- a/stdlib/source/lux/world/service/inventory.lux
+++ /dev/null
@@ -1,30 +0,0 @@
-(.module:
- [lux #*
- [control
- [try (#+ Try)]
- [security
- ["!" capability (#+ capability:)]]]])
-
-(type: #export ID Nat)
-
-(type: #export Ownership
- {#owner ID
- #property ID})
-
-(capability: #export (Can-Own !)
- (can-own Ownership (! (Try Any))))
-
-(capability: #export (Can-Disown !)
- (can-disown Ownership (! (Try Any))))
-
-(capability: #export (Can-Check !)
- (can-check Ownership (! (Try Bit))))
-
-(capability: #export (Can-List-Property !)
- (can-list-property ID (! (Try (List ID)))))
-
-(type: #export (Inventory !)
- {#can-own (Can-Own !)
- #can-disown (Can-Disown !)
- #can-check (Can-Check !)
- #can-list-property (Can-List-Property !)})
diff --git a/stdlib/source/lux/world/service/journal.lux b/stdlib/source/lux/world/service/journal.lux
deleted file mode 100644
index f05195c4f..000000000
--- a/stdlib/source/lux/world/service/journal.lux
+++ /dev/null
@@ -1,50 +0,0 @@
-(.module:
- [lux #*
- [control
- [equivalence (#+ Equivalence)]
- [interval (#+ Interval)]
- [try (#+ Try)]
- [security
- ["!" capability (#+ capability:)]]]
- [data
- ["." text ("#\." equivalence)]]
- [time
- ["." instant (#+ Instant) ("#\." equivalence)]]])
-
-(type: #export (Entry a)
- {#what a
- #why Text
- #how Text
- #who Text
- #where Text
- #when Instant})
-
-(type: #export Range
- (Interval Instant))
-
-(def: #export (range start end)
- (-> Instant Instant Range)
- (implementation
- (def: &enum instant.enum)
- (def: bottom start)
- (def: top end)))
-
-(implementation: #export (equivalence (^open "_\."))
- (All [a] (-> (Equivalence a) (Equivalence (Entry a))))
- (def: (= reference sample)
- (and (_\= (get@ #what reference) (get@ #what sample))
- (text\= (get@ #why reference) (get@ #why sample))
- (text\= (get@ #how reference) (get@ #how sample))
- (text\= (get@ #who reference) (get@ #who sample))
- (text\= (get@ #where reference) (get@ #where sample))
- (instant\= (get@ #when reference) (get@ #when sample)))))
-
-(capability: #export (Can-Write ! a)
- (can-write (Entry a) (! (Try Any))))
-
-(capability: #export (Can-Read ! a)
- (can-read Range (! (Try (List (Entry a))))))
-
-(type: #export (Journal ! a)
- {#can-write (Can-Write ! a)
- #can-read (Can-Read ! a)})
diff --git a/stdlib/source/lux/world/service/mail.lux b/stdlib/source/lux/world/service/mail.lux
deleted file mode 100644
index eb49c6131..000000000
--- a/stdlib/source/lux/world/service/mail.lux
+++ /dev/null
@@ -1,18 +0,0 @@
-(.module:
- [lux #*
- [control
- [try (#+ Try)]
- [concurrency
- [frp (#+ Channel)]]
- [security
- ["!" capability (#+ capability:)]]]])
-
-(capability: #export (Can-Send ! address message)
- (can-send [address message] (! (Try Any))))
-
-(capability: #export (Can-Subscribe ! address message)
- (can-subscribe [address] (! (Try (Channel message)))))
-
-(type: #export (Service ! address message)
- {#can-send (Can-Send ! address message)
- #can-subscribe (Can-Subscribe ! address message)})
diff --git a/stdlib/source/lux/world/shell.lux b/stdlib/source/lux/world/shell.lux
deleted file mode 100644
index 254e813ad..000000000
--- a/stdlib/source/lux/world/shell.lux
+++ /dev/null
@@ -1,373 +0,0 @@
-(.module:
- [lux #*
- ["@" target]
- ["jvm" ffi (#+ import:)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." function]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." io (#+ IO)]
- [security
- ["?" policy (#+ Context Safety Safe)]]
- [concurrency
- ["." atom (#+ Atom)]
- ["." promise (#+ Promise)]]
- [parser
- [environment (#+ Environment)]]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." array (#+ Array)]
- ["." list ("#\." fold functor)]
- ["." dictionary]]]
- [math
- [number (#+ hex)
- ["n" nat]]]]
- [//
- [file (#+ Path)]])
-
-(type: #export Exit
- Int)
-
-(template [<code> <name>]
- [(def: #export <name>
- Exit
- <code>)]
-
- [+0 normal]
- [+1 error]
- )
-
-(interface: #export (Process !)
- (: (-> [] (! (Try Text)))
- read)
- (: (-> [] (! (Try Text)))
- error)
- (: (-> Text (! (Try Any)))
- write)
- (: (-> [] (! (Try Any)))
- destroy)
- (: (-> [] (! (Try Exit)))
- await))
-
-(def: (async_process process)
- (-> (Process IO) (Process Promise))
- (`` (implementation
- (~~ (template [<method>]
- [(def: <method>
- (|>> (\ process <method>)
- promise.future))]
-
- [read]
- [error]
- [write]
- [destroy]
- [await]
- )))))
-
-(type: #export Command
- Text)
-
-(type: #export Argument
- Text)
-
-(interface: #export (Shell !)
- (: (-> [Environment Path Command (List Argument)] (! (Try (Process !))))
- execute))
-
-(def: #export (async shell)
- (-> (Shell IO) (Shell Promise))
- (implementation
- (def: (execute input)
- (promise.future
- (do (try.with io.monad)
- [process (\ shell execute input)]
- (wrap (..async_process process)))))))
-
-## https://en.wikipedia.org/wiki/Code_injection#Shell_injection
-(interface: (Policy ?)
- (: (-> Command (Safe Command ?))
- command)
- (: (-> Argument (Safe Argument ?))
- argument)
- (: (All [a] (-> (Safe a ?) a))
- value))
-
-(type: (Sanitizer a)
- (-> a a))
-
-(type: Replacer
- (-> Text Text))
-
-(def: (replace bad replacer)
- (-> Text Replacer (-> Text Text))
- (text.replace_all bad (replacer bad)))
-
-(def: sanitize_common_command
- (-> Replacer (Sanitizer Command))
- (let [x0A (text.from_code (hex "0A"))
- xFF (text.from_code (hex "FF"))]
- (function (_ replacer)
- (|>> (..replace x0A replacer)
- (..replace xFF replacer)
- (..replace "\" replacer)
- (..replace "&" replacer)
- (..replace "#" replacer)
- (..replace ";" replacer)
- (..replace "`" replacer)
- (..replace "|" replacer)
- (..replace "*" replacer)
- (..replace "?" replacer)
- (..replace "~" replacer)
- (..replace "^" replacer)
- (..replace "$" replacer)
- (..replace "<" replacer) (..replace ">" replacer)
- (..replace "(" replacer) (..replace ")" replacer)
- (..replace "[" replacer) (..replace "]" replacer)
- (..replace "{" replacer) (..replace "}" replacer)))))
-
-(def: (policy sanitize_command sanitize_argument)
- (Ex [?] (-> (Sanitizer Command) (Sanitizer Argument) (Policy ?)))
- (?.with_policy
- (: (Context Safety Policy)
- (function (_ (^open "?\."))
- (implementation
- (def: command (|>> sanitize_command ?\can_upgrade))
- (def: argument (|>> sanitize_argument ?\can_upgrade))
- (def: value ?\can_downgrade))))))
-
-(def: unix_policy
- (let [replacer (: Replacer
- (|>> (format "\")))
- sanitize_command (: (Sanitizer Command)
- (..sanitize_common_command replacer))
- sanitize_argument (: (Sanitizer Argument)
- (|>> (..replace "'" replacer)
- (text.enclose' "'")))]
- (..policy sanitize_command sanitize_argument)))
-
-(def: windows_policy
- (let [replacer (: Replacer
- (function.constant " "))
- sanitize_command (: (Sanitizer Command)
- (|>> (..sanitize_common_command replacer)
- (..replace "%" replacer)
- (..replace "!" replacer)))
- sanitize_argument (: (Sanitizer Argument)
- (|>> (..replace "%" replacer)
- (..replace "!" replacer)
- (..replace text.double_quote replacer)
- (text.enclose' text.double_quote)))]
- (..policy sanitize_command sanitize_argument)))
-
-(with_expansions [<jvm> (as_is (import: java/lang/String
- ["#::."
- (toLowerCase [] java/lang/String)])
-
- (def: (jvm::arguments_array arguments)
- (-> (List Argument) (Array java/lang/String))
- (product.right
- (list\fold (function (_ argument [idx output])
- [(inc idx) (jvm.array_write idx
- (:as java/lang/String argument)
- output)])
- [0 (jvm.array java/lang/String (list.size arguments))]
- arguments)))
-
- (import: (java/util/Map k v)
- ["#::."
- (put [k v] v)])
-
- (def: (jvm::load_environment input target)
- (-> Environment
- (java/util/Map java/lang/String java/lang/String)
- (java/util/Map java/lang/String java/lang/String))
- (list\fold (function (_ [key value] target')
- (exec (java/util/Map::put (:as java/lang/String key)
- (:as java/lang/String value)
- target')
- target'))
- target
- (dictionary.entries input)))
-
- (import: java/io/Reader
- ["#::."
- (read [] #io #try int)])
-
- (import: java/io/BufferedReader
- ["#::."
- (new [java/io/Reader])
- (readLine [] #io #try #? java/lang/String)])
-
- (import: java/io/InputStream)
-
- (import: java/io/InputStreamReader
- ["#::."
- (new [java/io/InputStream])])
-
- (import: java/io/OutputStream
- ["#::."
- (write [[byte]] #io #try void)])
-
- (import: java/lang/Process
- ["#::."
- (getInputStream [] #io #try java/io/InputStream)
- (getErrorStream [] #io #try java/io/InputStream)
- (getOutputStream [] #io #try java/io/OutputStream)
- (destroy [] #io #try void)
- (waitFor [] #io #try int)])
-
- (exception: #export no_more_output)
-
- (def: (default_process process)
- (-> java/lang/Process (IO (Try (Process IO))))
- (do {! (try.with io.monad)}
- [jvm_input (java/lang/Process::getInputStream process)
- jvm_error (java/lang/Process::getErrorStream process)
- jvm_output (java/lang/Process::getOutputStream process)
- #let [jvm_input (|> jvm_input
- java/io/InputStreamReader::new
- java/io/BufferedReader::new)
- jvm_error (|> jvm_error
- java/io/InputStreamReader::new
- java/io/BufferedReader::new)]]
- (wrap (: (Process IO)
- (`` (implementation
- (~~ (template [<name> <stream>]
- [(def: (<name> _)
- (do !
- [output (java/io/BufferedReader::readLine <stream>)]
- (case output
- (#.Some output)
- (wrap output)
-
- #.None
- (\ io.monad wrap (exception.throw ..no_more_output [])))))]
-
- [read jvm_input]
- [error jvm_error]
- ))
- (def: (write message)
- (java/io/OutputStream::write (\ utf8.codec encode message) jvm_output))
- (~~ (template [<name> <method>]
- [(def: (<name> _)
- (<method> process))]
-
- [destroy java/lang/Process::destroy]
- [await java/lang/Process::waitFor]
- ))))))))
-
- (import: java/io/File
- ["#::."
- (new [java/lang/String])])
-
- (import: java/lang/ProcessBuilder
- ["#::."
- (new [[java/lang/String]])
- (environment [] #try (java/util/Map java/lang/String java/lang/String))
- (directory [java/io/File] java/lang/ProcessBuilder)
- (start [] #io #try java/lang/Process)])
-
- (import: java/lang/System
- ["#::."
- (#static getProperty [java/lang/String] #io #try java/lang/String)])
-
- ## https://en.wikipedia.org/wiki/Code_injection#Shell_injection
- (def: windows?
- (IO (Try Bit))
- (\ (try.with io.monad) map
- (|>> java/lang/String::toLowerCase (text.starts_with? "windows"))
- (java/lang/System::getProperty "os.name")))
-
- (implementation: #export default
- (Shell IO)
-
- (def: (execute [environment working_directory command arguments])
- (do {! (try.with io.monad)}
- [#let [builder (|> (list& command arguments)
- ..jvm::arguments_array
- java/lang/ProcessBuilder::new
- (java/lang/ProcessBuilder::directory (java/io/File::new working_directory)))]
- _ (|> builder
- java/lang/ProcessBuilder::environment
- (\ try.functor map (..jvm::load_environment environment))
- (\ io.monad wrap))
- process (java/lang/ProcessBuilder::start builder)]
- (..default_process process))))
- )]
- (for {@.old (as_is <jvm>)
- @.jvm (as_is <jvm>)}
- (as_is)))
-
-(interface: #export (Mock s)
- (: (-> s (Try [s Text]))
- on_read)
- (: (-> s (Try [s Text]))
- on_error)
- (: (-> Text s (Try s))
- on_write)
- (: (-> s (Try s))
- on_destroy)
- (: (-> s (Try [s Exit]))
- on_await))
-
-(`` (implementation: (mock_process mock state)
- (All [s] (-> (Mock s) (Atom s) (Process IO)))
-
- (~~ (template [<name> <mock>]
- [(def: (<name> _)
- (do {! io.monad}
- [|state| (atom.read state)]
- (case (\ mock <mock> |state|)
- (#try.Success [|state| output])
- (do !
- [_ (atom.write |state| state)]
- (wrap (#try.Success output)))
-
- (#try.Failure error)
- (wrap (#try.Failure error)))))]
-
- [read on_read]
- [error on_error]
- [await on_await]
- ))
- (def: (write message)
- (do {! io.monad}
- [|state| (atom.read state)]
- (case (\ mock on_write message |state|)
- (#try.Success |state|)
- (do !
- [_ (atom.write |state| state)]
- (wrap (#try.Success [])))
-
- (#try.Failure error)
- (wrap (#try.Failure error)))))
- (def: (destroy _)
- (do {! io.monad}
- [|state| (atom.read state)]
- (case (\ mock on_destroy |state|)
- (#try.Success |state|)
- (do !
- [_ (atom.write |state| state)]
- (wrap (#try.Success [])))
-
- (#try.Failure error)
- (wrap (#try.Failure error)))))))
-
-(implementation: #export (mock mock init)
- (All [s]
- (-> (-> [Environment Path Command (List Argument)]
- (Try (Mock s)))
- s
- (Shell IO)))
-
- (def: (execute input)
- (io.io (do try.monad
- [mock (mock input)]
- (wrap (..mock_process mock (atom.atom init)))))))
diff --git a/stdlib/source/poly/lux/abstract/equivalence.lux b/stdlib/source/poly/lux/abstract/equivalence.lux
index 590c3c92a..080e64af0 100644
--- a/stdlib/source/poly/lux/abstract/equivalence.lux
+++ b/stdlib/source/poly/lux/abstract/equivalence.lux
@@ -1,44 +1,45 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ Monad do)]]
- [control
- ["p" parser
- ["<.>" type]
- ["s" code (#+ Parser)]]]
- [data
- ["." product]
- ["." bit]
- ["." maybe]
- ["." text ("#\." monoid)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." monad)]
- ["." row]
- ["." array]
- ["." queue]
- ["." set]
- ["." dictionary (#+ Dictionary)]
- ["." tree]]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]
- ["." poly (#+ poly:)]]
- [math
- [number
- ["." nat ("#\." decimal)]
- ["." int]
- ["." rev]
- ["." frac]]]
- [time
- ["." duration]
- ["." date]
- ["." instant]
- ["." day]
- ["." month]]
- ["." type
- ["." unit]]]
- [\\
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ Monad do)]]
+ [control
+ ["p" parser
+ ["<.>" type]
+ ["s" code (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." bit]
+ ["." maybe]
+ ["." text ("#\." monoid)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." monad)]
+ ["." row]
+ ["." array]
+ ["." queue]
+ ["." set]
+ ["." dictionary (#+ Dictionary)]
+ ["." tree]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]
+ ["." poly (#+ poly:)]]
+ [math
+ [number
+ ["." nat ("#\." decimal)]
+ ["." int]
+ ["." rev]
+ ["." frac]]]
+ [time
+ ["." duration]
+ ["." date]
+ ["." instant]
+ ["." day]
+ ["." month]]
+ ["." type
+ ["." unit]]]]
+ [\\library
["." /]])
(poly: #export equivalence
diff --git a/stdlib/source/poly/lux/abstract/functor.lux b/stdlib/source/poly/lux/abstract/functor.lux
index 1d90bf0d9..fbd3e2519 100644
--- a/stdlib/source/poly/lux/abstract/functor.lux
+++ b/stdlib/source/poly/lux/abstract/functor.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- ["." type]
- [abstract
- [monad (#+ Monad do)]]
- [control
- ["p" parser
- ["<.>" type]
- ["s" code (#+ Parser)]]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." monad monoid)]]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]
- ["." poly (#+ poly:)]]
- [math
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["." type]
+ [abstract
+ [monad (#+ Monad do)]]
+ [control
+ ["p" parser
+ ["<.>" type]
+ ["s" code (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." monad monoid)]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]
+ ["." poly (#+ poly:)]]
+ [math
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(poly: #export functor
diff --git a/stdlib/source/poly/lux/data/format/json.lux b/stdlib/source/poly/lux/data/format/json.lux
index 3022a59a8..d7409df9f 100644
--- a/stdlib/source/poly/lux/data/format/json.lux
+++ b/stdlib/source/poly/lux/data/format/json.lux
@@ -1,45 +1,46 @@
(.module: {#.doc "Codecs for values in the JSON format."}
- [lux #*
- ["." debug]
- [abstract
- [monad (#+ Monad do)]
- [equivalence (#+ Equivalence)]
- ["." codec]]
- [control
- ["." try]
- ["<>" parser
- ["<.>" type]
- ["</>" json]]]
- [data
- ["." bit]
- maybe
- ["." sum]
- ["." product]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." fold monad)]
- ["." row (#+ Row row) ("#\." monad)]
- ["d" dictionary]]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]
- ["." poly (#+ poly:)]]
- [math
- [number
- ["." i64]
- ["n" nat ("#\." decimal)]
- ["." int]
- ["." frac ("#\." decimal)]]]
- [time
- ## ["." instant]
- ## ["." duration]
- ["." date]
- ["." day]
- ["." month]]
- ["." type
- ["." unit]]]
- [\\
+ [library
+ [lux #*
+ ["." debug]
+ [abstract
+ [monad (#+ Monad do)]
+ [equivalence (#+ Equivalence)]
+ ["." codec]]
+ [control
+ ["." try]
+ ["<>" parser
+ ["<.>" type]
+ ["</>" json]]]
+ [data
+ ["." bit]
+ maybe
+ ["." sum]
+ ["." product]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." fold monad)]
+ ["." row (#+ Row row) ("#\." monad)]
+ ["d" dictionary]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]
+ ["." poly (#+ poly:)]]
+ [math
+ [number
+ ["." i64]
+ ["n" nat ("#\." decimal)]
+ ["." int]
+ ["." frac ("#\." decimal)]]]
+ [time
+ ## ["." instant]
+ ## ["." duration]
+ ["." date]
+ ["." day]
+ ["." month]]
+ ["." type
+ ["." unit]]]]
+ [\\library
["." / (#+ JSON)]])
(def: tag
diff --git a/stdlib/source/program/aedifex.lux b/stdlib/source/program/aedifex.lux
index 4cfc376d3..b046a7ace 100644
--- a/stdlib/source/program/aedifex.lux
+++ b/stdlib/source/program/aedifex.lux
@@ -1,44 +1,45 @@
(.module:
- [lux (#- Name)
- [program (#+ program:)]
- ["." debug]
- [abstract
- [monad (#+ do)]]
- [control
- [pipe (#+ do>)]
- ["." io (#+ IO)]
- ["." try (#+ Try) ("#\." functor)]
- ["." exception (#+ exception:)]
- [parser
- [environment (#+ Environment)]]
- [concurrency
- ["." promise (#+ Promise) ("#\." monad)]]]
- [data
- [binary (#+ Binary)]
- ["." text
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [format
- ["." xml]]
- [collection
- ["." set]
- ["." dictionary (#+ Dictionary)]
- ["." list ("#\." functor)]]]
- [tool
- [compiler
- [language
- [lux
- ["." syntax]]]]]
- [world
- ["." shell (#+ Exit Shell)]
- ["." console (#+ Console)]
- ["." program (#+ Program)]
- ["." file (#+ Path)
- ["." watch]]
- [net
- ["." http #_
- ["#" client]]]]]
+ [library
+ [lux (#- Name)
+ [program (#+ program:)]
+ ["." debug]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ do>)]
+ ["." io (#+ IO)]
+ ["." try (#+ Try) ("#\." functor)]
+ ["." exception (#+ exception:)]
+ [parser
+ [environment (#+ Environment)]]
+ [concurrency
+ ["." promise (#+ Promise) ("#\." monad)]]]
+ [data
+ [binary (#+ Binary)]
+ ["." text
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [format
+ ["." xml]]
+ [collection
+ ["." set]
+ ["." dictionary (#+ Dictionary)]
+ ["." list ("#\." functor)]]]
+ [tool
+ [compiler
+ [language
+ [lux
+ ["." syntax]]]]]
+ [world
+ ["." shell (#+ Exit Shell)]
+ ["." console (#+ Console)]
+ ["." program (#+ Program)]
+ ["." file (#+ Path)
+ ["." watch]]
+ [net
+ ["." http #_
+ ["#" client]]]]]]
["." / #_
["#" profile]
["#." action (#+ Action)]
diff --git a/stdlib/source/program/aedifex/action.lux b/stdlib/source/program/aedifex/action.lux
index e8a88facd..61c5ba3de 100644
--- a/stdlib/source/program/aedifex/action.lux
+++ b/stdlib/source/program/aedifex/action.lux
@@ -1,11 +1,12 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ Monad)]]
- [control
- ["." try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise)]]]])
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ Monad)]]
+ [control
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]]]]])
(type: #export (Action a)
(Promise (Try a)))
diff --git a/stdlib/source/program/aedifex/artifact.lux b/stdlib/source/program/aedifex/artifact.lux
index e5d37f7bb..631de6ebe 100644
--- a/stdlib/source/program/aedifex/artifact.lux
+++ b/stdlib/source/program/aedifex/artifact.lux
@@ -1,19 +1,20 @@
(.module:
- [lux (#- Name)
- [abstract
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]
- [hash (#+ Hash)]]
- [data
- ["." product]
- ["." text ("#\." order)
- ["%" format (#+ Format)]]
- [collection
- ["." list ("#\." monoid)]]]
- [world
- ["." file (#+ Path)]
- [net
- ["." uri (#+ URI)]]]])
+ [library
+ [lux (#- Name)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]
+ [hash (#+ Hash)]]
+ [data
+ ["." product]
+ ["." text ("#\." order)
+ ["%" format (#+ Format)]]
+ [collection
+ ["." list ("#\." monoid)]]]
+ [world
+ ["." file (#+ Path)]
+ [net
+ ["." uri (#+ URI)]]]]])
(type: #export Group
Text)
diff --git a/stdlib/source/program/aedifex/artifact/extension.lux b/stdlib/source/program/aedifex/artifact/extension.lux
index ad0122512..d1102437d 100644
--- a/stdlib/source/program/aedifex/artifact/extension.lux
+++ b/stdlib/source/program/aedifex/artifact/extension.lux
@@ -1,10 +1,11 @@
(.module:
- [lux (#- type)
- [data
- ["." text
- ["%" format (#+ format)]]]
- [macro
- ["." template]]]
+ [library
+ [lux (#- type)
+ [data
+ ["." text
+ ["%" format (#+ format)]]]
+ [macro
+ ["." template]]]]
["." // #_
["#" type]])
diff --git a/stdlib/source/program/aedifex/artifact/snapshot.lux b/stdlib/source/program/aedifex/artifact/snapshot.lux
index 89897316d..b377c1b38 100644
--- a/stdlib/source/program/aedifex/artifact/snapshot.lux
+++ b/stdlib/source/program/aedifex/artifact/snapshot.lux
@@ -1,16 +1,17 @@
(.module:
- [lux (#- Name Type)
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]]
- [control
- ["<>" parser
- ["<.>" xml (#+ Parser)]
- ["<.>" text]]]
- [data
- ["." sum]
- [format
- ["." xml (#+ XML)]]]]
+ [library
+ [lux (#- Name Type)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<.>" xml (#+ Parser)]
+ ["<.>" text]]]
+ [data
+ ["." sum]
+ [format
+ ["." xml (#+ XML)]]]]]
["." / #_
["#." stamp (#+ Stamp)]])
diff --git a/stdlib/source/program/aedifex/artifact/snapshot/build.lux b/stdlib/source/program/aedifex/artifact/snapshot/build.lux
index cd87c283e..0e8692054 100644
--- a/stdlib/source/program/aedifex/artifact/snapshot/build.lux
+++ b/stdlib/source/program/aedifex/artifact/snapshot/build.lux
@@ -1,20 +1,21 @@
(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]]
- [control
- ["<>" parser
- ["<.>" xml (#+ Parser)]
- ["<.>" text]]]
- [data
- [text
- ["%" format]]
- [format
- ["." xml (#+ XML)]]]
- [math
- [number
- ["." nat]]]])
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<.>" xml (#+ Parser)]
+ ["<.>" text]]]
+ [data
+ [text
+ ["%" format]]
+ [format
+ ["." xml (#+ XML)]]]
+ [math
+ [number
+ ["." nat]]]]])
(type: #export Build
Nat)
diff --git a/stdlib/source/program/aedifex/artifact/snapshot/stamp.lux b/stdlib/source/program/aedifex/artifact/snapshot/stamp.lux
index 2d127af21..147369711 100644
--- a/stdlib/source/program/aedifex/artifact/snapshot/stamp.lux
+++ b/stdlib/source/program/aedifex/artifact/snapshot/stamp.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]]
- [control
- ["<>" parser
- ["<.>" xml (#+ Parser)]
- ["<.>" text]]]
- [data
- ["." product]
- [format
- ["." xml (#+ XML)]]]]
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<.>" xml (#+ Parser)]
+ ["<.>" text]]]
+ [data
+ ["." product]
+ [format
+ ["." xml (#+ XML)]]]]]
["." // #_
["#." time (#+ Time)]
["#." build (#+ Build)]])
diff --git a/stdlib/source/program/aedifex/artifact/snapshot/time.lux b/stdlib/source/program/aedifex/artifact/snapshot/time.lux
index e0cb8c112..46c9b149e 100644
--- a/stdlib/source/program/aedifex/artifact/snapshot/time.lux
+++ b/stdlib/source/program/aedifex/artifact/snapshot/time.lux
@@ -1,20 +1,21 @@
(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]]
- [control
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<.>" text]
- ["<.>" xml (#+ Parser)]]]
- [data
- [text
- ["%" format]]
- [format
- ["." xml (#+ XML)]]]
- [time
- ["." instant (#+ Instant)]]]
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<.>" text]
+ ["<.>" xml (#+ Parser)]]]
+ [data
+ [text
+ ["%" format]]
+ [format
+ ["." xml (#+ XML)]]]
+ [time
+ ["." instant (#+ Instant)]]]]
["." /// #_
["#." time
["#/." date]
diff --git a/stdlib/source/program/aedifex/artifact/snapshot/version.lux b/stdlib/source/program/aedifex/artifact/snapshot/version.lux
index 806d2b261..a1a50fcc2 100644
--- a/stdlib/source/program/aedifex/artifact/snapshot/version.lux
+++ b/stdlib/source/program/aedifex/artifact/snapshot/version.lux
@@ -1,17 +1,18 @@
(.module:
- [lux (#- Type)
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]]
- [control
- ["<>" parser
- ["<.>" xml (#+ Parser)]
- ["<.>" text]]]
- [data
- ["." product]
- ["." text]
- [format
- ["." xml (#+ XML)]]]]
+ [library
+ [lux (#- Type)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<.>" xml (#+ Parser)]
+ ["<.>" text]]]
+ [data
+ ["." product]
+ ["." text]
+ [format
+ ["." xml (#+ XML)]]]]]
["." /// #_
["#." type (#+ Type)]
["#." time (#+ Time)]])
diff --git a/stdlib/source/program/aedifex/artifact/snapshot/version/value.lux b/stdlib/source/program/aedifex/artifact/snapshot/version/value.lux
index 7356d897c..ce9a09f1a 100644
--- a/stdlib/source/program/aedifex/artifact/snapshot/version/value.lux
+++ b/stdlib/source/program/aedifex/artifact/snapshot/version/value.lux
@@ -1,11 +1,12 @@
(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- ["." product]
- ["." text
- ["%" format]]]]
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format]]]]]
["." /// (#+ Snapshot)
["#." time]
["#." stamp]])
diff --git a/stdlib/source/program/aedifex/artifact/time.lux b/stdlib/source/program/aedifex/artifact/time.lux
index b227c3954..41ee0d418 100644
--- a/stdlib/source/program/aedifex/artifact/time.lux
+++ b/stdlib/source/program/aedifex/artifact/time.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["." time]
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["<>" parser
- ["<.>" text (#+ Parser)]]]
- [data
- ["." product]
- [text
- ["%" format (#+ Format)]]]
- [time
- ["." instant (#+ Instant)]]]
+ [library
+ [lux #*
+ ["." time]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["<>" parser
+ ["<.>" text (#+ Parser)]]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ Format)]]]
+ [time
+ ["." instant (#+ Instant)]]]]
["." / #_
["#." date]
["#." time]])
diff --git a/stdlib/source/program/aedifex/artifact/time/date.lux b/stdlib/source/program/aedifex/artifact/time/date.lux
index 655b8f6c2..f6b8ae5a9 100644
--- a/stdlib/source/program/aedifex/artifact/time/date.lux
+++ b/stdlib/source/program/aedifex/artifact/time/date.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ do)]
- [equivalence (#+ Equivalence)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<.>" text (#+ Parser)]]]
- [data
- [text
- ["%" format]]]
- [math
- [number
- ["n" nat]
- ["i" int]]]
- [time
- ["." date ("#\." equivalence)]
- ["." year]
- ["." month]]
- [type
- abstract]])
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]
+ [equivalence (#+ Equivalence)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<.>" text (#+ Parser)]]]
+ [data
+ [text
+ ["%" format]]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]]]
+ [time
+ ["." date ("#\." equivalence)]
+ ["." year]
+ ["." month]]
+ [type
+ abstract]]])
(def: #export (pad value)
(-> Nat Text)
diff --git a/stdlib/source/program/aedifex/artifact/time/time.lux b/stdlib/source/program/aedifex/artifact/time/time.lux
index 5c074c20b..78b85f8cd 100644
--- a/stdlib/source/program/aedifex/artifact/time/time.lux
+++ b/stdlib/source/program/aedifex/artifact/time/time.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- ["." time]
- [abstract
- [monad (#+ do)]]
- [control
- ["<>" parser
- ["<.>" text (#+ Parser)]]]
- [data
- [text
- ["%" format]]]
- [math
- [number
- ["n" nat]]]]
+ [library
+ [lux #*
+ ["." time]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<.>" text (#+ Parser)]]]
+ [data
+ [text
+ ["%" format]]]
+ [math
+ [number
+ ["n" nat]]]]]
["." // #_
["#" date]])
diff --git a/stdlib/source/program/aedifex/artifact/type.lux b/stdlib/source/program/aedifex/artifact/type.lux
index cbf0a35ed..22cbd8253 100644
--- a/stdlib/source/program/aedifex/artifact/type.lux
+++ b/stdlib/source/program/aedifex/artifact/type.lux
@@ -1,5 +1,6 @@
(.module:
- [lux (#- Type)])
+ [library
+ [lux (#- Type)]])
## https://maven.apache.org/ref/3.6.3/maven-core/artifact-handlers.html
(type: #export Type
diff --git a/stdlib/source/program/aedifex/artifact/versioning.lux b/stdlib/source/program/aedifex/artifact/versioning.lux
index be192e9a5..9fdc2d84d 100644
--- a/stdlib/source/program/aedifex/artifact/versioning.lux
+++ b/stdlib/source/program/aedifex/artifact/versioning.lux
@@ -1,29 +1,30 @@
(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]]
- [control
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<.>" xml (#+ Parser)]
- ["<.>" text]]]
- [data
- ["." product]
- ["." maybe]
- ["." text
- ["%" format]]
- [format
- ["." xml (#+ XML)]]
- [collection
- ["." list ("#\." functor)]]]
- [math
- [number
- ["n" nat]]]
- ["." time (#+ Time)
- ["." date (#+ Date)]
- ["." year]
- ["." month]]]
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<.>" xml (#+ Parser)]
+ ["<.>" text]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text
+ ["%" format]]
+ [format
+ ["." xml (#+ XML)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ [number
+ ["n" nat]]]
+ ["." time (#+ Time)
+ ["." date (#+ Date)]
+ ["." year]
+ ["." month]]]]
["." // #_
["#." time]
["#." snapshot (#+ Snapshot)
diff --git a/stdlib/source/program/aedifex/cli.lux b/stdlib/source/program/aedifex/cli.lux
index 0c943efc9..c763d572e 100644
--- a/stdlib/source/program/aedifex/cli.lux
+++ b/stdlib/source/program/aedifex/cli.lux
@@ -1,14 +1,15 @@
(.module:
- [lux (#- Name)
- [abstract
- [equivalence (#+ Equivalence)]]
- [control
- ["<>" parser
- ["." cli (#+ Parser)]]]
- [data
- ["." sum]
- ["." product]
- ["." text]]]
+ [library
+ [lux (#- Name)
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [control
+ ["<>" parser
+ ["." cli (#+ Parser)]]]
+ [data
+ ["." sum]
+ ["." product]
+ ["." text]]]]
[//
[repository
[identity (#+ Identity)]]
diff --git a/stdlib/source/program/aedifex/command.lux b/stdlib/source/program/aedifex/command.lux
index 5248b0273..c8f8106b4 100644
--- a/stdlib/source/program/aedifex/command.lux
+++ b/stdlib/source/program/aedifex/command.lux
@@ -1,5 +1,6 @@
(.module:
- [lux #*]
+ [library
+ [lux #*]]
["." // #_
["#" profile]
["#." action (#+ Action)]])
diff --git a/stdlib/source/program/aedifex/command/auto.lux b/stdlib/source/program/aedifex/command/auto.lux
index ee2ab4bbd..2460215b4 100644
--- a/stdlib/source/program/aedifex/command/auto.lux
+++ b/stdlib/source/program/aedifex/command/auto.lux
@@ -1,21 +1,22 @@
(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- [collection
- ["." list]
- ["." set]]]
- [world
- [program (#+ Program)]
- [shell (#+ Exit Shell)]
- [console (#+ Console)]
- ["." file
- ["." watch (#+ Watcher)]]]]
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ [collection
+ ["." list]
+ ["." set]]]
+ [world
+ [program (#+ Program)]
+ [shell (#+ Exit Shell)]
+ [console (#+ Console)]
+ ["." file
+ ["." watch (#+ Watcher)]]]]]
["." // #_
["/#" // #_
[command (#+ Command)]
diff --git a/stdlib/source/program/aedifex/command/build.lux b/stdlib/source/program/aedifex/command/build.lux
index 34351f636..c0f9566a8 100644
--- a/stdlib/source/program/aedifex/command/build.lux
+++ b/stdlib/source/program/aedifex/command/build.lux
@@ -1,32 +1,33 @@
(.module:
- [lux (#- Name)
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." io (#+ IO)]
- [concurrency
- ["." promise (#+ Promise) ("#\." monad)]]]
- [data
- ["." product]
- ["." maybe]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]
- ["." dictionary]
- ["." set]]]
- [math
- [number
- ["i" int]]]
- [world
- ["." program (#+ Program)]
- ["." file (#+ Path)]
- ["." shell (#+ Exit Process Shell)]
- ["." console (#+ Console)]
- [net
- ["." uri]]]]
+ [library
+ [lux (#- Name)
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO)]
+ [concurrency
+ ["." promise (#+ Promise) ("#\." monad)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." dictionary]
+ ["." set]]]
+ [math
+ [number
+ ["i" int]]]
+ [world
+ ["." program (#+ Program)]
+ ["." file (#+ Path)]
+ ["." shell (#+ Exit Process Shell)]
+ ["." console (#+ Console)]
+ [net
+ ["." uri]]]]]
["." /// #_
["#" profile]
["#." action]
diff --git a/stdlib/source/program/aedifex/command/clean.lux b/stdlib/source/program/aedifex/command/clean.lux
index c37c46367..3a27e400a 100644
--- a/stdlib/source/program/aedifex/command/clean.lux
+++ b/stdlib/source/program/aedifex/command/clean.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- [abstract
- ["." monad (#+ do)]]
- [control
- [try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- [text
- ["%" format (#+ format)]]]
- [world
- ["." file (#+ Path)]
- ["." console (#+ Console)]]]
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ [try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ [text
+ ["%" format (#+ format)]]]
+ [world
+ ["." file (#+ Path)]
+ ["." console (#+ Console)]]]]
["." /// #_
[command (#+ Command)]
["#" profile]
diff --git a/stdlib/source/program/aedifex/command/deploy.lux b/stdlib/source/program/aedifex/command/deploy.lux
index 5ec42be78..e70e6f762 100644
--- a/stdlib/source/program/aedifex/command/deploy.lux
+++ b/stdlib/source/program/aedifex/command/deploy.lux
@@ -1,31 +1,32 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- [pipe (#+ do>)]
- ["." try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise) ("#\." monad)]]
- ["<>" parser
- ["<.>" xml]]]
- [data
- [binary (#+ Binary)]
- [text
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." set]]
- [format
- ["." binary]
- ["." tar]
- ["." xml]]]
- [time
- ["." instant (#+ Instant)]]
- [world
- ["." file]
- ["." console (#+ Console)]]]
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ do>)]
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise) ("#\." monad)]]
+ ["<>" parser
+ ["<.>" xml]]]
+ [data
+ [binary (#+ Binary)]
+ [text
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." set]]
+ [format
+ ["." binary]
+ ["." tar]
+ ["." xml]]]
+ [time
+ ["." instant (#+ Instant)]]
+ [world
+ ["." file]
+ ["." console (#+ Console)]]]]
[program
[compositor
["." export]]]
diff --git a/stdlib/source/program/aedifex/command/deps.lux b/stdlib/source/program/aedifex/command/deps.lux
index 416544e01..c2344ea80 100644
--- a/stdlib/source/program/aedifex/command/deps.lux
+++ b/stdlib/source/program/aedifex/command/deps.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." exception]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- [collection
- ["." set (#+ Set)]
- ["." list ("#\." fold)]
- ["." dictionary]]
- [text
- ["%" format]]]
- [world
- [net (#+ URL)]
- [program (#+ Program)]
- ["." file]
- ["." console (#+ Console)]]]
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." exception]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ [collection
+ ["." set (#+ Set)]
+ ["." list ("#\." fold)]
+ ["." dictionary]]
+ [text
+ ["%" format]]]
+ [world
+ [net (#+ URL)]
+ [program (#+ Program)]
+ ["." file]
+ ["." console (#+ Console)]]]]
["." // #_
["#." clean]
["/#" // #_
diff --git a/stdlib/source/program/aedifex/command/install.lux b/stdlib/source/program/aedifex/command/install.lux
index 39bdea8b2..4cc4ede68 100644
--- a/stdlib/source/program/aedifex/command/install.lux
+++ b/stdlib/source/program/aedifex/command/install.lux
@@ -1,27 +1,28 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- [binary (#+ Binary)]
- [text
- [encoding
- ["." utf8]]]
- [collection
- ["." set]]
- [format
- ["." binary]
- ["." tar]
- ["." xml]]]
- [world
- [program (#+ Program)]
- ["." file]
- ["." console (#+ Console)]]]
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ [binary (#+ Binary)]
+ [text
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." set]]
+ [format
+ ["." binary]
+ ["." tar]
+ ["." xml]]]
+ [world
+ [program (#+ Program)]
+ ["." file]
+ ["." console (#+ Console)]]]]
[program
[compositor
["." export]]]
diff --git a/stdlib/source/program/aedifex/command/pom.lux b/stdlib/source/program/aedifex/command/pom.lux
index 00427ee39..6d26f4792 100644
--- a/stdlib/source/program/aedifex/command/pom.lux
+++ b/stdlib/source/program/aedifex/command/pom.lux
@@ -1,21 +1,22 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." try ("#\." functor)]
- [concurrency
- ["." promise (#+ Promise) ("#\." monad)]]]
- [data
- [text
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [format
- ["." xml]]]
- [world
- ["." file]
- ["." console (#+ Console)]]]
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try ("#\." functor)]
+ [concurrency
+ ["." promise (#+ Promise) ("#\." monad)]]]
+ [data
+ [text
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [format
+ ["." xml]]]
+ [world
+ ["." file]
+ ["." console (#+ Console)]]]]
["." /// #_
[command (#+ Command)]
["#." action]
diff --git a/stdlib/source/program/aedifex/command/test.lux b/stdlib/source/program/aedifex/command/test.lux
index 55614ba80..15f8d6f22 100644
--- a/stdlib/source/program/aedifex/command/test.lux
+++ b/stdlib/source/program/aedifex/command/test.lux
@@ -1,21 +1,22 @@
(.module:
- [lux (#- Name)
- [abstract
- [monad (#+ do)]]
- [control
- [concurrency
- ["." promise (#+ Promise) ("#\." monad)]]]
- [data
- [text
- ["%" format (#+ format)]]]
- [math
- [number
- ["i" int]]]
- [world
- ["." program (#+ Program)]
- ["." file]
- ["." shell (#+ Exit Shell)]
- ["." console (#+ Console)]]]
+ [library
+ [lux (#- Name)
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [concurrency
+ ["." promise (#+ Promise) ("#\." monad)]]]
+ [data
+ [text
+ ["%" format (#+ format)]]]
+ [math
+ [number
+ ["i" int]]]
+ [world
+ ["." program (#+ Program)]
+ ["." file]
+ ["." shell (#+ Exit Shell)]
+ ["." console (#+ Console)]]]]
["." // #_
["#." build]
["/#" // #_
diff --git a/stdlib/source/program/aedifex/command/version.lux b/stdlib/source/program/aedifex/command/version.lux
index be40d54eb..cd724843c 100644
--- a/stdlib/source/program/aedifex/command/version.lux
+++ b/stdlib/source/program/aedifex/command/version.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- [control
- [concurrency
- ["." promise (#+ Promise)]]]
- [tool
- [compiler
- ["." version]
- ["." language #_
- ["#/." lux #_
- ["#" version]]]]]
- [world
- ["." console (#+ Console)]]]
+ [library
+ [lux #*
+ [control
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [tool
+ [compiler
+ ["." version]
+ ["." language #_
+ ["#/." lux #_
+ ["#" version]]]]]
+ [world
+ ["." console (#+ Console)]]]]
[///
[command (#+ Command)]])
diff --git a/stdlib/source/program/aedifex/dependency.lux b/stdlib/source/program/aedifex/dependency.lux
index f06b00260..1ac750d62 100644
--- a/stdlib/source/program/aedifex/dependency.lux
+++ b/stdlib/source/program/aedifex/dependency.lux
@@ -1,13 +1,14 @@
(.module:
- [lux (#- Type)
- [abstract
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]
- [hash (#+ Hash)]]
- [data
- ["." product]
- ["." text ("#\." order)
- ["%" format (#+ format)]]]]
+ [library
+ [lux (#- Type)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]
+ [hash (#+ Hash)]]
+ [data
+ ["." product]
+ ["." text ("#\." order)
+ ["%" format (#+ format)]]]]]
["." // #_
["#" artifact (#+ Artifact) ("#\." order)
[type (#+ Type)]]])
diff --git a/stdlib/source/program/aedifex/dependency/deployment.lux b/stdlib/source/program/aedifex/dependency/deployment.lux
index edfa3142b..7939173dd 100644
--- a/stdlib/source/program/aedifex/dependency/deployment.lux
+++ b/stdlib/source/program/aedifex/dependency/deployment.lux
@@ -1,25 +1,26 @@
(.module:
- [lux #*
- [abstract
- [codec (#+ Codec)]
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- [binary (#+ Binary)]
- ["." product]
- [text
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." dictionary]
- ["." set (#+ Set)]
- ["." list ("#\." monoid)]]]
- [time
- ["." instant (#+ Instant)]]]
+ [library
+ [lux #*
+ [abstract
+ [codec (#+ Codec)]
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ [binary (#+ Binary)]
+ ["." product]
+ [text
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." dictionary]
+ ["." set (#+ Set)]
+ ["." list ("#\." monoid)]]]
+ [time
+ ["." instant (#+ Instant)]]]]
["." /// #_
[repository (#+ Repository)]
["#." hash (#+ Hash)]
diff --git a/stdlib/source/program/aedifex/dependency/resolution.lux b/stdlib/source/program/aedifex/dependency/resolution.lux
index 698678f41..15a32959b 100644
--- a/stdlib/source/program/aedifex/dependency/resolution.lux
+++ b/stdlib/source/program/aedifex/dependency/resolution.lux
@@ -1,42 +1,43 @@
(.module:
- [lux (#- Name)
- ["." debug]
- ["." ffi (#+ import:)]
- [abstract
- [codec (#+ Codec)]
- [equivalence (#+ Equivalence)]
- [monad (#+ Monad do)]]
- [control
- ["." try (#+ Try) ("#\." functor)]
- ["." exception (#+ Exception exception:)]
- ["<>" parser
- ["<.>" xml (#+ Parser)]]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." binary (#+ Binary)]
- ["." name]
- ["." maybe]
- ["." text
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [format
- ["." xml (#+ Tag XML)]]
- [collection
- ["." dictionary (#+ Dictionary)]
- ["." set]
- ["." list ("#\." functor monoid)]]]
- [math
- [number
- ["n" nat]
- ["." i64]]]
- [world
- [console (#+ Console)]
- [net (#+ URL)
- ["." uri]
- ["." http #_
- ["#" client]]]]]
+ [library
+ [lux (#- Name)
+ ["." debug]
+ ["." ffi (#+ import:)]
+ [abstract
+ [codec (#+ Codec)]
+ [equivalence (#+ Equivalence)]
+ [monad (#+ Monad do)]]
+ [control
+ ["." try (#+ Try) ("#\." functor)]
+ ["." exception (#+ Exception exception:)]
+ ["<>" parser
+ ["<.>" xml (#+ Parser)]]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." binary (#+ Binary)]
+ ["." name]
+ ["." maybe]
+ ["." text
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [format
+ ["." xml (#+ Tag XML)]]
+ [collection
+ ["." dictionary (#+ Dictionary)]
+ ["." set]
+ ["." list ("#\." functor monoid)]]]
+ [math
+ [number
+ ["n" nat]
+ ["." i64]]]
+ [world
+ [console (#+ Console)]
+ [net (#+ URL)
+ ["." uri]
+ ["." http #_
+ ["#" client]]]]]]
["." // (#+ Dependency)
["#." status (#+ Status)]
["/#" // #_
diff --git a/stdlib/source/program/aedifex/dependency/status.lux b/stdlib/source/program/aedifex/dependency/status.lux
index f501ebc8b..db97f59b0 100644
--- a/stdlib/source/program/aedifex/dependency/status.lux
+++ b/stdlib/source/program/aedifex/dependency/status.lux
@@ -1,11 +1,12 @@
(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- [binary (#+ Binary)]
- ["." sum]
- ["." product]]]
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ [binary (#+ Binary)]
+ ["." sum]
+ ["." product]]]]
["." /// #_
["#." hash (#+ Hash SHA-1 MD5)]])
diff --git a/stdlib/source/program/aedifex/format.lux b/stdlib/source/program/aedifex/format.lux
index c7fc93b5a..1896415ea 100644
--- a/stdlib/source/program/aedifex/format.lux
+++ b/stdlib/source/program/aedifex/format.lux
@@ -1,14 +1,15 @@
(.module:
- [lux #*
- [data
- ["." text ("#\." equivalence)]
- [collection
- ["." dictionary (#+ Dictionary)]
- ["." list ("#\." functor)]
- ["." set (#+ Set)]]]
- [macro
- ["." code]
- ["." template]]]
+ [library
+ [lux #*
+ [data
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." dictionary (#+ Dictionary)]
+ ["." list ("#\." functor)]
+ ["." set (#+ Set)]]]
+ [macro
+ ["." code]
+ ["." template]]]]
["." // #_
["/" profile]
["#." runtime (#+ Runtime)]
diff --git a/stdlib/source/program/aedifex/hash.lux b/stdlib/source/program/aedifex/hash.lux
index 2e0e35db0..760c05ce1 100644
--- a/stdlib/source/program/aedifex/hash.lux
+++ b/stdlib/source/program/aedifex/hash.lux
@@ -1,24 +1,25 @@
(.module:
- [lux #*
- ["." ffi (#+ import:)]
- [abstract
- [codec (#+ Codec)]
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." binary (#+ Binary)]
- ["." text
- ["%" format (#+ Format format)]
- ["." encoding]]]
- [math
- [number
- ["n" nat]
- ["." i64]]]
- [type
- abstract]])
+ [library
+ [lux #*
+ ["." ffi (#+ import:)]
+ [abstract
+ [codec (#+ Codec)]
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." binary (#+ Binary)]
+ ["." text
+ ["%" format (#+ Format format)]
+ ["." encoding]]]
+ [math
+ [number
+ ["n" nat]
+ ["." i64]]]
+ [type
+ abstract]]])
## TODO: Replace with pure-Lux implementations of these algorithms
## https://en.wikipedia.org/wiki/SHA-1#SHA-1_pseudocode
diff --git a/stdlib/source/program/aedifex/input.lux b/stdlib/source/program/aedifex/input.lux
index 606fefdeb..1ece2cf17 100644
--- a/stdlib/source/program/aedifex/input.lux
+++ b/stdlib/source/program/aedifex/input.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ Monad do)]]
- [control
- [pipe (#+ do>)]
- ["." try (#+ Try)]
- [parser
- ["<.>" code]]]
- [data
- [binary (#+ Binary)]
- ["." text
- [encoding
- ["." utf8]]]]
- [meta
- ["." location]]
- [tool
- [compiler
- [language
- [lux
- ["." syntax]]]]]
- [world
- ["." file]]]
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ Monad do)]]
+ [control
+ [pipe (#+ do>)]
+ ["." try (#+ Try)]
+ [parser
+ ["<.>" code]]]
+ [data
+ [binary (#+ Binary)]
+ ["." text
+ [encoding
+ ["." utf8]]]]
+ [meta
+ ["." location]]
+ [tool
+ [compiler
+ [language
+ [lux
+ ["." syntax]]]]]
+ [world
+ ["." file]]]]
["." // #_
[profile (#+ Profile)]
["#." project (#+ Project)]
diff --git a/stdlib/source/program/aedifex/local.lux b/stdlib/source/program/aedifex/local.lux
index bf8c0f780..b3a358484 100644
--- a/stdlib/source/program/aedifex/local.lux
+++ b/stdlib/source/program/aedifex/local.lux
@@ -1,11 +1,12 @@
(.module:
- [lux #*
- [data
- [text
- ["%" format (#+ format)]]]
- [world
- [net
- ["." uri (#+ URI)]]]]
+ [library
+ [lux #*
+ [data
+ [text
+ ["%" format (#+ format)]]]
+ [world
+ [net
+ ["." uri (#+ URI)]]]]]
["." // #_
["#." artifact (#+ Version Artifact)]])
diff --git a/stdlib/source/program/aedifex/metadata.lux b/stdlib/source/program/aedifex/metadata.lux
index 843f2e056..40a7bd612 100644
--- a/stdlib/source/program/aedifex/metadata.lux
+++ b/stdlib/source/program/aedifex/metadata.lux
@@ -1,12 +1,13 @@
(.module:
- [lux #*
- [data
- ["." text
- ["%" format (#+ format)]]]
- [world
- [file (#+ Path)]
- [net
- ["." uri (#+ URI)]]]]
+ [library
+ [lux #*
+ [data
+ ["." text
+ ["%" format (#+ format)]]]
+ [world
+ [file (#+ Path)]
+ [net
+ ["." uri (#+ URI)]]]]]
["." // #_
["#." artifact (#+ Artifact)]])
diff --git a/stdlib/source/program/aedifex/metadata/artifact.lux b/stdlib/source/program/aedifex/metadata/artifact.lux
index 50f228e50..0f8a5737c 100644
--- a/stdlib/source/program/aedifex/metadata/artifact.lux
+++ b/stdlib/source/program/aedifex/metadata/artifact.lux
@@ -1,37 +1,38 @@
(.module:
- [lux (#- Name)
- [abstract
- [monad (#+ do)]
- [equivalence (#+ Equivalence)]]
- [control
- [pipe (#+ do>)]
- ["." try (#+ Try)]
- ["<>" parser
- ["<.>" xml (#+ Parser)]
- ["<.>" text]]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." product]
- ["." text
- ["%" format]
- [encoding
- ["." utf8]]]
- [format
- ["." xml (#+ XML)]]
- [collection
- ["." list ("#\." functor)]]]
- [math
- [number
- ["n" nat]]]
- ["." time (#+ Time)
- ["." instant (#+ Instant)]
- ["." date (#+ Date)]
- ["." year]
- ["." month]]
- [world
- [net
- ["." uri (#+ URI)]]]]
+ [library
+ [lux (#- Name)
+ [abstract
+ [monad (#+ do)]
+ [equivalence (#+ Equivalence)]]
+ [control
+ [pipe (#+ do>)]
+ ["." try (#+ Try)]
+ ["<>" parser
+ ["<.>" xml (#+ Parser)]
+ ["<.>" text]]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format]
+ [encoding
+ ["." utf8]]]
+ [format
+ ["." xml (#+ XML)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ [number
+ ["n" nat]]]
+ ["." time (#+ Time)
+ ["." instant (#+ Instant)]
+ ["." date (#+ Date)]
+ ["." year]
+ ["." month]]
+ [world
+ [net
+ ["." uri (#+ URI)]]]]]
["." //
["/#" // #_
[repository (#+ Repository)]
diff --git a/stdlib/source/program/aedifex/metadata/snapshot.lux b/stdlib/source/program/aedifex/metadata/snapshot.lux
index 41a0d9986..032214c90 100644
--- a/stdlib/source/program/aedifex/metadata/snapshot.lux
+++ b/stdlib/source/program/aedifex/metadata/snapshot.lux
@@ -1,38 +1,39 @@
(.module:
- [lux (#- Name Type)
- [abstract
- [monad (#+ do)]
- [equivalence (#+ Equivalence)]]
- [control
- [pipe (#+ do> case>)]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["<>" parser
- ["<.>" xml (#+ Parser)]
- ["<.>" text]]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." product]
- ["." text
- ["%" format]
- [encoding
- ["." utf8]]]
- [format
- ["." xml (#+ XML)]]
- [collection
- ["." list ("#\." functor)]]]
- [math
- [number
- ["n" nat]]]
- ["." time (#+ Time)
- ["." instant (#+ Instant)]
- ["." date (#+ Date)]
- ["." year]
- ["." month]]
- [world
- [net
- ["." uri (#+ URI)]]]]
+ [library
+ [lux (#- Name Type)
+ [abstract
+ [monad (#+ do)]
+ [equivalence (#+ Equivalence)]]
+ [control
+ [pipe (#+ do> case>)]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<.>" xml (#+ Parser)]
+ ["<.>" text]]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format]
+ [encoding
+ ["." utf8]]]
+ [format
+ ["." xml (#+ XML)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ [number
+ ["n" nat]]]
+ ["." time (#+ Time)
+ ["." instant (#+ Instant)]
+ ["." date (#+ Date)]
+ ["." year]
+ ["." month]]
+ [world
+ [net
+ ["." uri (#+ URI)]]]]]
["." //
["/#" // #_
[repository (#+ Repository)]
diff --git a/stdlib/source/program/aedifex/package.lux b/stdlib/source/program/aedifex/package.lux
index acfa7bd62..1144e8f4a 100644
--- a/stdlib/source/program/aedifex/package.lux
+++ b/stdlib/source/program/aedifex/package.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]
- [control
- ["." try (#+ Try) ("#\." functor)]
- [parser
- ["<.>" xml]]]
- [data
- ["." sum]
- ["." product]
- ["." binary (#+ Binary)]
- [text
- [encoding
- ["." utf8]]]
- [format
- ["." xml (#+ XML)]]
- [collection
- [set (#+ Set)]]]]
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [control
+ ["." try (#+ Try) ("#\." functor)]
+ [parser
+ ["<.>" xml]]]
+ [data
+ ["." sum]
+ ["." product]
+ ["." binary (#+ Binary)]
+ [text
+ [encoding
+ ["." utf8]]]
+ [format
+ ["." xml (#+ XML)]]
+ [collection
+ [set (#+ Set)]]]]]
["." // #_
["/" profile]
["#." hash]
diff --git a/stdlib/source/program/aedifex/parser.lux b/stdlib/source/program/aedifex/parser.lux
index 6374f8807..d0dd59133 100644
--- a/stdlib/source/program/aedifex/parser.lux
+++ b/stdlib/source/program/aedifex/parser.lux
@@ -1,22 +1,23 @@
(.module:
- [lux (#- Module type)
- [abstract
- [monad (#+ do)]]
- [control
- ["<>" parser
- ["<.>" code (#+ Parser)]]]
- [data
- ["." text]
- [collection
- ["." dictionary (#+ Dictionary)]
- ["." set (#+ Set)]]]
- [tool
- [compiler
- [meta
- [archive
- [descriptor (#+ Module)]]]]]
- [world
- [net (#+ URL)]]]
+ [library
+ [lux (#- Module type)
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<.>" code (#+ Parser)]]]
+ [data
+ ["." text]
+ [collection
+ ["." dictionary (#+ Dictionary)]
+ ["." set (#+ Set)]]]
+ [tool
+ [compiler
+ [meta
+ [archive
+ [descriptor (#+ Module)]]]]]
+ [world
+ [net (#+ URL)]]]]
["." // #_
["/" profile]
["#." runtime (#+ Runtime)]
diff --git a/stdlib/source/program/aedifex/pom.lux b/stdlib/source/program/aedifex/pom.lux
index 8f45dda36..8f1dae1ea 100644
--- a/stdlib/source/program/aedifex/pom.lux
+++ b/stdlib/source/program/aedifex/pom.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- [pipe (#+ case>)]
- ["." try (#+ Try)]
- ["." exception]
- ["<>" parser
- ["<xml>" xml (#+ Parser)]]]
- [data
- ["." name]
- ["." maybe ("#\." functor)]
- ["." text]
- [format
- ["_" xml (#+ Tag XML)]]
- [collection
- ["." list ("#\." monoid functor fold)]
- ["." set]
- ["." dictionary]]]]
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try (#+ Try)]
+ ["." exception]
+ ["<>" parser
+ ["<xml>" xml (#+ Parser)]]]
+ [data
+ ["." name]
+ ["." maybe ("#\." functor)]
+ ["." text]
+ [format
+ ["_" xml (#+ Tag XML)]]
+ [collection
+ ["." list ("#\." monoid functor fold)]
+ ["." set]
+ ["." dictionary]]]]]
["." // #_
["/" profile]
["#." dependency (#+ Dependency)]
diff --git a/stdlib/source/program/aedifex/profile.lux b/stdlib/source/program/aedifex/profile.lux
index 9fe05b10b..4953032a8 100644
--- a/stdlib/source/program/aedifex/profile.lux
+++ b/stdlib/source/program/aedifex/profile.lux
@@ -1,28 +1,29 @@
(.module:
- [lux (#- Info Source Module Name)
- [abstract
- [monoid (#+ Monoid)]
- [equivalence (#+ Equivalence)]]
- [control
- ["." exception (#+ exception:)]]
- [data
- ["." product]
- ["." maybe ("#\." monoid)]
- ["." text ("#\." equivalence)]
- [collection
- ["." dictionary (#+ Dictionary)]
- ["." list ("#\." monoid)]
- ["." set (#+ Set)]]]
- [macro
- ["." template]]
- [world
- [net (#+ URL)]
- [file (#+ Path)]]
- [tool
- [compiler
- [meta
- [archive
- [descriptor (#+ Module)]]]]]]
+ [library
+ [lux (#- Info Source Module Name)
+ [abstract
+ [monoid (#+ Monoid)]
+ [equivalence (#+ Equivalence)]]
+ [control
+ ["." exception (#+ exception:)]]
+ [data
+ ["." product]
+ ["." maybe ("#\." monoid)]
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." dictionary (#+ Dictionary)]
+ ["." list ("#\." monoid)]
+ ["." set (#+ Set)]]]
+ [macro
+ ["." template]]
+ [world
+ [net (#+ URL)]
+ [file (#+ Path)]]
+ [tool
+ [compiler
+ [meta
+ [archive
+ [descriptor (#+ Module)]]]]]]]
[//
["." runtime (#+ Runtime) ("#\." equivalence)]
["." dependency (#+ Dependency) ("#\." equivalence)]
diff --git a/stdlib/source/program/aedifex/project.lux b/stdlib/source/program/aedifex/project.lux
index a35a3651c..321e86661 100644
--- a/stdlib/source/program/aedifex/project.lux
+++ b/stdlib/source/program/aedifex/project.lux
@@ -1,19 +1,20 @@
(.module:
- [lux (#- Name)
- [abstract
- [equivalence (#+ Equivalence)]
- [monoid (#+ Monoid)]
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary (#+ Dictionary)]
- ["." set (#+ Set)]
- ["." list ("#\." fold)]]]]
+ [library
+ [lux (#- Name)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monoid (#+ Monoid)]
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary (#+ Dictionary)]
+ ["." set (#+ Set)]
+ ["." list ("#\." fold)]]]]]
["." // #_
["#" profile (#+ Name Profile)]])
diff --git a/stdlib/source/program/aedifex/repository.lux b/stdlib/source/program/aedifex/repository.lux
index 05560c6c9..93e9096e7 100644
--- a/stdlib/source/program/aedifex/repository.lux
+++ b/stdlib/source/program/aedifex/repository.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- [io (#+ IO)]
- ["." try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise)]
- ["." stm]]]
- [data
- [binary (#+ Binary)]]
- [world
- [net
- [uri (#+ URI)]]]])
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [io (#+ IO)]
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]
+ ["." stm]]]
+ [data
+ [binary (#+ Binary)]]
+ [world
+ [net
+ [uri (#+ URI)]]]]])
(interface: #export (Repository !)
(: Text
diff --git a/stdlib/source/program/aedifex/repository/identity.lux b/stdlib/source/program/aedifex/repository/identity.lux
index ef7b0c934..dccecf291 100644
--- a/stdlib/source/program/aedifex/repository/identity.lux
+++ b/stdlib/source/program/aedifex/repository/identity.lux
@@ -1,14 +1,15 @@
(.module:
- [lux #*
- ["." ffi (#+ import:)]
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]]])
+ [library
+ [lux #*
+ ["." ffi (#+ import:)]
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]]]])
(type: #export User
Text)
diff --git a/stdlib/source/program/aedifex/repository/local.lux b/stdlib/source/program/aedifex/repository/local.lux
index b68425609..e7dbb7d4d 100644
--- a/stdlib/source/program/aedifex/repository/local.lux
+++ b/stdlib/source/program/aedifex/repository/local.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." text
- ["%" format (#+ format)]]]
- [world
- [program (#+ Program)]
- ["." file]
- [net
- ["." uri (#+ URI)]]]]
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]]
+ [world
+ [program (#+ Program)]
+ ["." file]
+ [net
+ ["." uri (#+ URI)]]]]]
["." //
["/#" // #_
["#." local]
diff --git a/stdlib/source/program/aedifex/repository/origin.lux b/stdlib/source/program/aedifex/repository/origin.lux
index ca97a8cff..be7d24a6e 100644
--- a/stdlib/source/program/aedifex/repository/origin.lux
+++ b/stdlib/source/program/aedifex/repository/origin.lux
@@ -1,13 +1,14 @@
(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- ["." sum]
- ["." text]]
- [world
- [file (#+ Path)]
- [net (#+ URL)]]])
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." sum]
+ ["." text]]
+ [world
+ [file (#+ Path)]
+ [net (#+ URL)]]]])
(type: #export Origin
(#Local Path)
diff --git a/stdlib/source/program/aedifex/repository/remote.lux b/stdlib/source/program/aedifex/repository/remote.lux
index 7feaa9710..118085389 100644
--- a/stdlib/source/program/aedifex/repository/remote.lux
+++ b/stdlib/source/program/aedifex/repository/remote.lux
@@ -1,28 +1,29 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." io (#+ IO)]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]]
- [tool
- [compiler
- ["." version]
- ["." language #_
- ["#/." lux #_
- ["#" version]]]]]
- [world
- [net (#+ URL)
- [uri (#+ URI)]
- ["." http #_
- ["#" client]
- ["#/." status]
- ["@#" /]]]]]
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io (#+ IO)]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]]
+ [tool
+ [compiler
+ ["." version]
+ ["." language #_
+ ["#/." lux #_
+ ["#" version]]]]]
+ [world
+ [net (#+ URL)
+ [uri (#+ URI)]
+ ["." http #_
+ ["#" client]
+ ["#/." status]
+ ["@#" /]]]]]]
["." //
["#." identity (#+ Identity)]
["/#" // #_
diff --git a/stdlib/source/program/aedifex/runtime.lux b/stdlib/source/program/aedifex/runtime.lux
index 571a9fc43..f5aeef36a 100644
--- a/stdlib/source/program/aedifex/runtime.lux
+++ b/stdlib/source/program/aedifex/runtime.lux
@@ -1,17 +1,18 @@
(.module:
- [lux (#- for)
- [abstract
- [equivalence (#+ Equivalence)]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." monoid)]]]
- [macro
- ["." template]]
- [world
- ["." file]]])
+ [library
+ [lux (#- for)
+ [abstract
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." monoid)]]]
+ [macro
+ ["." template]]
+ [world
+ ["." file]]]])
(type: #export Runtime
{#program Text
diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux
index b964e6502..6c0f700c2 100644
--- a/stdlib/source/program/compositor.lux
+++ b/stdlib/source/program/compositor.lux
@@ -1,54 +1,55 @@
(.module:
- [lux (#- Module)
- [type (#+ :share)]
- ["." debug]
- [abstract
- [monad (#+ Monad do)]]
- [control
- ["." io (#+ IO io)]
- ["." try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise) ("#\." monad)]]]
- [data
- [binary (#+ Binary)]
- ["." product]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary]
- ["." row (#+ Row)]]]
- [time
- ["." instant]]
- ["." world #_
- ["." file]
- ["#/." program]
- ## ["." console]
- ]
- [tool
- [compiler
- ["." phase]
- [default
- ["." platform (#+ Platform)]]
- [language
- ["$" lux
- ["#/." program (#+ Program)]
- ["." syntax]
- ["." analysis
- [macro (#+ Expander)]]
- ["." generation (#+ Buffer Context)]
- ["." directive]
- [phase
- [extension (#+ Extender)]]]]
- [meta
- [packager (#+ Packager)]
- [archive (#+ Archive)
- [descriptor (#+ Module)]]
- [cache
- ["." dependency]]
- [io
- ["ioW" archive]]]]
- ## ["." interpreter]
- ]]
+ [library
+ [lux (#- Module)
+ [type (#+ :share)]
+ ["." debug]
+ [abstract
+ [monad (#+ Monad do)]]
+ [control
+ ["." io (#+ IO io)]
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise) ("#\." monad)]]]
+ [data
+ [binary (#+ Binary)]
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary]
+ ["." row (#+ Row)]]]
+ [time
+ ["." instant]]
+ ["." world #_
+ ["." file]
+ ["#/." program]
+ ## ["." console]
+ ]
+ [tool
+ [compiler
+ ["." phase]
+ [default
+ ["." platform (#+ Platform)]]
+ [language
+ ["$" lux
+ ["#/." program (#+ Program)]
+ ["." syntax]
+ ["." analysis
+ [macro (#+ Expander)]]
+ ["." generation (#+ Buffer Context)]
+ ["." directive]
+ [phase
+ [extension (#+ Extender)]]]]
+ [meta
+ [packager (#+ Packager)]
+ [archive (#+ Archive)
+ [descriptor (#+ Module)]]
+ [cache
+ ["." dependency]]
+ [io
+ ["ioW" archive]]]]
+ ## ["." interpreter]
+ ]]]
["." / #_
["#." cli (#+ Service)]
["#." static (#+ Static)]
diff --git a/stdlib/source/program/compositor/cli.lux b/stdlib/source/program/compositor/cli.lux
index 4c4384636..d3b61640b 100644
--- a/stdlib/source/program/compositor/cli.lux
+++ b/stdlib/source/program/compositor/cli.lux
@@ -1,16 +1,17 @@
(.module:
- [lux (#- Module Source)
- [control
- [pipe (#+ case>)]
- ["<>" parser
- ["." cli (#+ Parser)]]]
- [tool
- [compiler
- [meta
- [archive
- [descriptor (#+ Module)]]]]]
- [world
- [file (#+ Path)]]])
+ [library
+ [lux (#- Module Source)
+ [control
+ [pipe (#+ case>)]
+ ["<>" parser
+ ["." cli (#+ Parser)]]]
+ [tool
+ [compiler
+ [meta
+ [archive
+ [descriptor (#+ Module)]]]]]
+ [world
+ [file (#+ Path)]]]])
(type: #export Source
Path)
diff --git a/stdlib/source/program/compositor/export.lux b/stdlib/source/program/compositor/export.lux
index 24ba3492c..9c2bdef52 100644
--- a/stdlib/source/program/compositor/export.lux
+++ b/stdlib/source/program/compositor/export.lux
@@ -1,29 +1,30 @@
(.module:
- [lux (#- Source)
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary]
- ["." row]]
- [format
- ["." binary]
- ["." tar]]]
- [time
- ["." instant]]
- [tool
- [compiler
- [meta
- ["." io #_
- ["#" context (#+ Extension)]]]]]
- [world
- ["." file]]]
+ [library
+ [lux (#- Source)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary]
+ ["." row]]
+ [format
+ ["." binary]
+ ["." tar]]]
+ [time
+ ["." instant]]
+ [tool
+ [compiler
+ [meta
+ ["." io #_
+ ["#" context (#+ Extension)]]]]]
+ [world
+ ["." file]]]]
[//
[cli (#+ Source Export)]])
diff --git a/stdlib/source/program/compositor/import.lux b/stdlib/source/program/compositor/import.lux
index f91ad03e7..4edb82a5e 100644
--- a/stdlib/source/program/compositor/import.lux
+++ b/stdlib/source/program/compositor/import.lux
@@ -1,30 +1,31 @@
(.module:
- [lux (#- Module)
- [abstract
- ["." monad (#+ Monad do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- [concurrency
- ["." promise (#+ Promise) ("#\." monad)]]
- ["<>" parser
- ["<.>" binary]]]
- [data
- [binary (#+ Binary)]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary (#+ Dictionary)]
- ["." row]]
- [format
- ["." tar]]]
- [tool
- [compiler
- [meta
- [archive
- [descriptor (#+ Module)]]]]]
- [world
- ["." file]]]
+ [library
+ [lux (#- Module)
+ [abstract
+ ["." monad (#+ Monad do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ [concurrency
+ ["." promise (#+ Promise) ("#\." monad)]]
+ ["<>" parser
+ ["<.>" binary]]]
+ [data
+ [binary (#+ Binary)]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary (#+ Dictionary)]
+ ["." row]]
+ [format
+ ["." tar]]]
+ [tool
+ [compiler
+ [meta
+ [archive
+ [descriptor (#+ Module)]]]]]
+ [world
+ ["." file]]]]
[//
[cli (#+ Library)]])
diff --git a/stdlib/source/program/compositor/static.lux b/stdlib/source/program/compositor/static.lux
index d5e100f30..ee65f9f72 100644
--- a/stdlib/source/program/compositor/static.lux
+++ b/stdlib/source/program/compositor/static.lux
@@ -1,8 +1,9 @@
(.module:
- [lux #*
- [target (#+ Target)]
- [world
- [file (#+ Path)]]])
+ [library
+ [lux #*
+ [target (#+ Target)]
+ [world
+ [file (#+ Path)]]]])
(type: #export Static
{#host Target
diff --git a/stdlib/source/program/scriptum.lux b/stdlib/source/program/scriptum.lux
index 0d86b0f1c..420b40a8b 100644
--- a/stdlib/source/program/scriptum.lux
+++ b/stdlib/source/program/scriptum.lux
@@ -272,8 +272,9 @@
(def: (lux-module? module-name)
(-> Text Bit)
- (or (text\= "lux" module-name)
- (text.starts-with? "lux/" module-name)))
+ (let [prefix (format .prelude_module "/")]
+ (or (text\= .prelude_module module-name)
+ (text.starts-with? prefix module-name))))
(def: (add-definition [name [def-type def-annotations def-value]] organization)
(-> [Text Definition] Organization Organization)
diff --git a/stdlib/source/spec/aedifex/repository.lux b/stdlib/source/spec/aedifex/repository.lux
index 882937a0b..de9a05fde 100644
--- a/stdlib/source/spec/aedifex/repository.lux
+++ b/stdlib/source/spec/aedifex/repository.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." binary
- ["_#" \test]]]
- [math
- ["." random]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." binary
+ ["_#" \\test]]]
+ [math
+ ["." random]]]]
[\\program
["." /
["#." remote]
diff --git a/stdlib/source/spec/compositor/generation/case.lux b/stdlib/source/spec/compositor/generation/case.lux
index 4f45a480c..2424aa330 100644
--- a/stdlib/source/spec/compositor/generation/case.lux
+++ b/stdlib/source/spec/compositor/generation/case.lux
@@ -140,7 +140,7 @@
(def: special-input
Synthesis
(let [_cursor_ (: Synthesis
- (synthesis.tuple (list (synthesis.text "lux")
+ (synthesis.tuple (list (synthesis.text .prelude_module)
(synthesis.i64 +901)
(synthesis.i64 +13))))
_code_ (: (-> Synthesis Synthesis)
@@ -178,7 +178,7 @@
(|> _nil_
(_cons_ (__apply__ (__identifier__ ["" "form$"])
(__list__ (list (__apply__ (__identifier__ ["" "tag$"])
- (__tuple__ (list (__text__ "lux")
+ (__tuple__ (list (__text__ .prelude_module)
(__text__ "Cons"))))
(__identifier__ ["" "export?-meta"])
(__identifier__ ["" "tail"])))))
diff --git a/stdlib/source/spec/lux/abstract/apply.lux b/stdlib/source/spec/lux/abstract/apply.lux
index 749d82a28..691e8c01c 100644
--- a/stdlib/source/spec/lux/abstract/apply.lux
+++ b/stdlib/source/spec/lux/abstract/apply.lux
@@ -1,15 +1,16 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." function]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." function]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Apply)]]
[//
[functor (#+ Injection Comparison)]])
diff --git a/stdlib/source/spec/lux/abstract/codec.lux b/stdlib/source/spec/lux/abstract/codec.lux
index d892436f3..f58f6ce91 100644
--- a/stdlib/source/spec/lux/abstract/codec.lux
+++ b/stdlib/source/spec/lux/abstract/codec.lux
@@ -1,13 +1,14 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /
[//
[equivalence (#+ Equivalence)]]]])
diff --git a/stdlib/source/spec/lux/abstract/comonad.lux b/stdlib/source/spec/lux/abstract/comonad.lux
index 7d68d7a24..85d00b8f2 100644
--- a/stdlib/source/spec/lux/abstract/comonad.lux
+++ b/stdlib/source/spec/lux/abstract/comonad.lux
@@ -1,13 +1,14 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ CoMonad)]]
[//
[functor (#+ Injection Comparison)]])
diff --git a/stdlib/source/spec/lux/abstract/enum.lux b/stdlib/source/spec/lux/abstract/enum.lux
index 2823c7b38..ddb2a80f1 100644
--- a/stdlib/source/spec/lux/abstract/enum.lux
+++ b/stdlib/source/spec/lux/abstract/enum.lux
@@ -1,11 +1,12 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /]])
(def: #export (spec (^open "\.") gen-sample)
diff --git a/stdlib/source/spec/lux/abstract/equivalence.lux b/stdlib/source/spec/lux/abstract/equivalence.lux
index 14e84c05b..4d6d0900a 100644
--- a/stdlib/source/spec/lux/abstract/equivalence.lux
+++ b/stdlib/source/spec/lux/abstract/equivalence.lux
@@ -1,11 +1,12 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." / (#+ Equivalence)]])
(def: #export (spec (^open "_//.") random)
diff --git a/stdlib/source/spec/lux/abstract/fold.lux b/stdlib/source/spec/lux/abstract/fold.lux
index 204987ded..2b4a7617f 100644
--- a/stdlib/source/spec/lux/abstract/fold.lux
+++ b/stdlib/source/spec/lux/abstract/fold.lux
@@ -1,15 +1,16 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
[//
[functor (#+ Injection Comparison)]]
- [\\
+ [\\library
["." /]])
(def: #export (spec injection comparison (^open "@//."))
diff --git a/stdlib/source/spec/lux/abstract/functor.lux b/stdlib/source/spec/lux/abstract/functor.lux
index 8aa3b5e95..cfa6cc2ff 100644
--- a/stdlib/source/spec/lux/abstract/functor.lux
+++ b/stdlib/source/spec/lux/abstract/functor.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]]
- [control
- ["." function]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]]
+ [control
+ ["." function]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Functor)]])
(type: #export (Injection f)
diff --git a/stdlib/source/spec/lux/abstract/functor/contravariant.lux b/stdlib/source/spec/lux/abstract/functor/contravariant.lux
index 21a2a62c6..cba839e94 100644
--- a/stdlib/source/spec/lux/abstract/functor/contravariant.lux
+++ b/stdlib/source/spec/lux/abstract/functor/contravariant.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]]
- [control
- ["." function]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]]
+ [control
+ ["." function]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Functor)]])
(def: (identity equivalence value (^open "@//."))
diff --git a/stdlib/source/spec/lux/abstract/hash.lux b/stdlib/source/spec/lux/abstract/hash.lux
index 94b9cf92b..4722a48a0 100644
--- a/stdlib/source/spec/lux/abstract/hash.lux
+++ b/stdlib/source/spec/lux/abstract/hash.lux
@@ -1,15 +1,16 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- ["." bit ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." bit ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: #export (spec (^open "\.") random)
diff --git a/stdlib/source/spec/lux/abstract/interval.lux b/stdlib/source/spec/lux/abstract/interval.lux
index a3735f50f..5b74bc34d 100644
--- a/stdlib/source/spec/lux/abstract/interval.lux
+++ b/stdlib/source/spec/lux/abstract/interval.lux
@@ -1,12 +1,13 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- ["." order]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ ["." order]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /]])
(def: #export (spec (^open "@//.") gen-sample)
diff --git a/stdlib/source/spec/lux/abstract/monad.lux b/stdlib/source/spec/lux/abstract/monad.lux
index 4d79a43b0..869eb24c7 100644
--- a/stdlib/source/spec/lux/abstract/monad.lux
+++ b/stdlib/source/spec/lux/abstract/monad.lux
@@ -1,11 +1,12 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ do)]]
[//
[functor (#+ Injection Comparison)]])
diff --git a/stdlib/source/spec/lux/abstract/monoid.lux b/stdlib/source/spec/lux/abstract/monoid.lux
index a590f09a1..f8626fe74 100644
--- a/stdlib/source/spec/lux/abstract/monoid.lux
+++ b/stdlib/source/spec/lux/abstract/monoid.lux
@@ -1,11 +1,12 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /
[//
[equivalence (#+ Equivalence)]]]])
diff --git a/stdlib/source/spec/lux/abstract/order.lux b/stdlib/source/spec/lux/abstract/order.lux
index e1a9eea1b..61fc22611 100644
--- a/stdlib/source/spec/lux/abstract/order.lux
+++ b/stdlib/source/spec/lux/abstract/order.lux
@@ -1,11 +1,12 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /]])
(def: #export (spec (^open "@//.") generator)
diff --git a/stdlib/source/spec/lux/world/console.lux b/stdlib/source/spec/lux/world/console.lux
index cda425364..f454b61c9 100644
--- a/stdlib/source/spec/lux/world/console.lux
+++ b/stdlib/source/spec/lux/world/console.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- [io (#+ IO)]
- ["." try]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." text
- ["%" format (#+ format)]]]
- [math
- ["." random]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [io (#+ IO)]
+ ["." try]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]]
+ [math
+ ["." random]]]]
+ [\\library
["." /]])
(def: #export (spec console)
diff --git a/stdlib/source/spec/lux/world/file.lux b/stdlib/source/spec/lux/world/file.lux
index a207817f1..7bdefb173 100644
--- a/stdlib/source/spec/lux/world/file.lux
+++ b/stdlib/source/spec/lux/world/file.lux
@@ -1,33 +1,34 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- ["." predicate]]
- [control
- [pipe (#+ case>)]
- [io (#+ IO)]
- ["." try ("#\." functor)]
- ["." exception]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." maybe ("#\." functor)]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]
- [encoding
- ["." utf8 ("#\." codec)]]]
- ["." binary (#+ Binary) ("#\." equivalence monoid)
- ["$#" \test]]
- [collection
- ["." list]]]
- [math
- ["." random]
- [number
- ["n" nat]]]
- [time
- ["." instant (#+ Instant) ("#\." equivalence)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ ["." predicate]]
+ [control
+ [pipe (#+ case>)]
+ [io (#+ IO)]
+ ["." try ("#\." functor)]
+ ["." exception]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." maybe ("#\." functor)]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8 ("#\." codec)]]]
+ ["." binary (#+ Binary) ("#\." equivalence monoid)
+ ["$#" \\test]]
+ [collection
+ ["." list]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]
+ [time
+ ["." instant (#+ Instant) ("#\." equivalence)]]]]
+ [\\library
["." /]])
(def: (for_path fs)
diff --git a/stdlib/source/spec/lux/world/program.lux b/stdlib/source/spec/lux/world/program.lux
index cf413ed55..e79429627 100644
--- a/stdlib/source/spec/lux/world/program.lux
+++ b/stdlib/source/spec/lux/world/program.lux
@@ -1,20 +1,21 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." text]
- [collection
- ["." dictionary]
- ["." list]]]
- [math
- ["." random]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." text]
+ [collection
+ ["." dictionary]
+ ["." list]]]
+ [math
+ ["." random]]]]
+ [\\library
["." /]])
(def: #export (spec subject)
diff --git a/stdlib/source/spec/lux/world/shell.lux b/stdlib/source/spec/lux/world/shell.lux
index 78bbd5521..c4fc51b99 100644
--- a/stdlib/source/spec/lux/world/shell.lux
+++ b/stdlib/source/spec/lux/world/shell.lux
@@ -1,24 +1,25 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try ("#\." functor)]
- [concurrency
- ["." promise (#+ Promise) ("#\." monad)]]
- [parser
- ["." environment (#+ Environment)]]]
- [data
- ["." product]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]
- [math
- ["." random]
- [number
- ["n" nat]
- ["i" int]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try ("#\." functor)]
+ [concurrency
+ ["." promise (#+ Promise) ("#\." monad)]]
+ [parser
+ ["." environment (#+ Environment)]]]
+ [data
+ ["." product]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]
+ ["i" int]]]]]
+ [\\library
["." /
[//
[file (#+ Path)]]]])
diff --git a/stdlib/source/test/aedifex.lux b/stdlib/source/test/aedifex.lux
index b6f54f8f4..dc04f13de 100644
--- a/stdlib/source/test/aedifex.lux
+++ b/stdlib/source/test/aedifex.lux
@@ -1,9 +1,10 @@
(.module:
- [lux #*
- [program (#+ program:)]
- ["_" test (#+ Test)]
- [control
- ["." io]]]
+ [library
+ [lux #*
+ [program (#+ program:)]
+ ["_" test (#+ Test)]
+ [control
+ ["." io]]]]
["." / #_
["#." artifact]
["#." cli]
diff --git a/stdlib/source/test/aedifex/artifact.lux b/stdlib/source/test/aedifex/artifact.lux
index b1bb102c1..6a1021b4c 100644
--- a/stdlib/source/test/aedifex/artifact.lux
+++ b/stdlib/source/test/aedifex/artifact.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [hash (#+ Hash)]
- [\spec
- ["$." equivalence]]]
- [control
- [concurrency
- [promise (#+ Promise)]]]
- [data
- ["." text ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]]
- [world
- ["." file]
- [net
- ["." uri]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [hash (#+ Hash)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ [concurrency
+ [promise (#+ Promise)]]]
+ [data
+ ["." text ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]]
+ [world
+ ["." file]
+ [net
+ ["." uri]]]]]
["." / #_
["#." extension]
["#." snapshot]
diff --git a/stdlib/source/test/aedifex/artifact/extension.lux b/stdlib/source/test/aedifex/artifact/extension.lux
index 9ae382975..fd28c5d92 100644
--- a/stdlib/source/test/aedifex/artifact/extension.lux
+++ b/stdlib/source/test/aedifex/artifact/extension.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- ["." text ("#\." equivalence)]
- [collection
- ["." set]
- ["." list]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." set]
+ ["." list]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
[\\program
["." /
["/#" // #_
diff --git a/stdlib/source/test/aedifex/artifact/snapshot.lux b/stdlib/source/test/aedifex/artifact/snapshot.lux
index 4e968904d..94d98cf22 100644
--- a/stdlib/source/test/aedifex/artifact/snapshot.lux
+++ b/stdlib/source/test/aedifex/artifact/snapshot.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try ("#\." functor)]
- [parser
- ["<.>" xml]]]
- [math
- ["." random (#+ Random) ("#\." monad)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try ("#\." functor)]
+ [parser
+ ["<.>" xml]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]]]]
["$." / #_
["#." build]
["#." stamp]
diff --git a/stdlib/source/test/aedifex/artifact/snapshot/build.lux b/stdlib/source/test/aedifex/artifact/snapshot/build.lux
index 156be7af4..731219b91 100644
--- a/stdlib/source/test/aedifex/artifact/snapshot/build.lux
+++ b/stdlib/source/test/aedifex/artifact/snapshot/build.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try ("#\." functor)]
- [parser
- ["<.>" xml]]]
- [math
- ["." random (#+ Random)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try ("#\." functor)]
+ [parser
+ ["<.>" xml]]]
+ [math
+ ["." random (#+ Random)]]]]
[\\program
["." /]])
diff --git a/stdlib/source/test/aedifex/artifact/snapshot/stamp.lux b/stdlib/source/test/aedifex/artifact/snapshot/stamp.lux
index aa3dbcff1..ba0c9f368 100644
--- a/stdlib/source/test/aedifex/artifact/snapshot/stamp.lux
+++ b/stdlib/source/test/aedifex/artifact/snapshot/stamp.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try ("#\." functor)]
- [parser
- ["<.>" xml]]]
- [math
- ["." random (#+ Random)]]
- [time
- ["." instant]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try ("#\." functor)]
+ [parser
+ ["<.>" xml]]]
+ [math
+ ["." random (#+ Random)]]
+ [time
+ ["." instant]]]]
[\\program
["." /]]
["$." // #_
diff --git a/stdlib/source/test/aedifex/artifact/snapshot/time.lux b/stdlib/source/test/aedifex/artifact/snapshot/time.lux
index f6861bf9c..9cfe28fb0 100644
--- a/stdlib/source/test/aedifex/artifact/snapshot/time.lux
+++ b/stdlib/source/test/aedifex/artifact/snapshot/time.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try ("#\." functor)]
- [parser
- ["<.>" text]]]
- [math
- ["." random (#+ Random)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try ("#\." functor)]
+ [parser
+ ["<.>" text]]]
+ [math
+ ["." random (#+ Random)]]]]
[\\program
["." /]]
["$." /// #_
diff --git a/stdlib/source/test/aedifex/artifact/snapshot/version.lux b/stdlib/source/test/aedifex/artifact/snapshot/version.lux
index 06adc7239..f0fc26321 100644
--- a/stdlib/source/test/aedifex/artifact/snapshot/version.lux
+++ b/stdlib/source/test/aedifex/artifact/snapshot/version.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try ("#\." functor)]
- [parser
- ["<.>" xml]]]
- [math
- ["." random (#+ Random)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try ("#\." functor)]
+ [parser
+ ["<.>" xml]]]
+ [math
+ ["." random (#+ Random)]]]]
[\\program
["." /]]
["." / #_
diff --git a/stdlib/source/test/aedifex/artifact/snapshot/version/value.lux b/stdlib/source/test/aedifex/artifact/snapshot/version/value.lux
index 3ed0b32ce..dcb23646d 100644
--- a/stdlib/source/test/aedifex/artifact/snapshot/version/value.lux
+++ b/stdlib/source/test/aedifex/artifact/snapshot/version/value.lux
@@ -1,24 +1,25 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try ("#\." functor)]
- [parser
- ["<.>" text]]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]
- [math
- ["." random (#+ Random) ("#\." monad)]
- [number
- ["n" nat]
- ["i" int]]]
- [time
- ["." instant]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try ("#\." functor)]
+ [parser
+ ["<.>" text]]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]
+ [number
+ ["n" nat]
+ ["i" int]]]
+ [time
+ ["." instant]]]]
["$." /// #_
["#." stamp]]
[\\program
diff --git a/stdlib/source/test/aedifex/artifact/time.lux b/stdlib/source/test/aedifex/artifact/time.lux
index c2ab6a354..f4fc185be 100644
--- a/stdlib/source/test/aedifex/artifact/time.lux
+++ b/stdlib/source/test/aedifex/artifact/time.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try ("#\." functor)]
- [parser
- ["<.>" text]]]
- [math
- ["." random (#+ Random)]
- [number
- ["i" int]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try ("#\." functor)]
+ [parser
+ ["<.>" text]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["i" int]]]]]
[\\program
["." /]]
["." / #_
diff --git a/stdlib/source/test/aedifex/artifact/time/date.lux b/stdlib/source/test/aedifex/artifact/time/date.lux
index 494aa5e07..e68645b8a 100644
--- a/stdlib/source/test/aedifex/artifact/time/date.lux
+++ b/stdlib/source/test/aedifex/artifact/time/date.lux
@@ -1,20 +1,21 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try ("#\." functor)]
- [parser
- ["<.>" text]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["i" int]]]
- [time
- ["." date]
- ["." year]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try ("#\." functor)]
+ [parser
+ ["<.>" text]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["i" int]]]
+ [time
+ ["." date]
+ ["." year]]]]
[\\program
["." /]])
diff --git a/stdlib/source/test/aedifex/artifact/time/time.lux b/stdlib/source/test/aedifex/artifact/time/time.lux
index a17f9c40c..dd4b63904 100644
--- a/stdlib/source/test/aedifex/artifact/time/time.lux
+++ b/stdlib/source/test/aedifex/artifact/time/time.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["." time]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try ("#\." functor)]
- [parser
- ["<.>" text]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["i" int]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." time]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try ("#\." functor)]
+ [parser
+ ["<.>" text]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["i" int]]]]]
[\\program
["." /]])
diff --git a/stdlib/source/test/aedifex/artifact/type.lux b/stdlib/source/test/aedifex/artifact/type.lux
index 447b60bac..8418febee 100644
--- a/stdlib/source/test/aedifex/artifact/type.lux
+++ b/stdlib/source/test/aedifex/artifact/type.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- ["." text]
- [collection
- ["." set]
- ["." list]]]
- [math
- ["." random (#+ Random) ("#\." monad)]
- [number
- ["n" nat]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." text]
+ [collection
+ ["." set]
+ ["." list]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]
+ [number
+ ["n" nat]]]]]
[\\program
["." /]])
diff --git a/stdlib/source/test/aedifex/artifact/versioning.lux b/stdlib/source/test/aedifex/artifact/versioning.lux
index d1d4da7ef..9efdca98a 100644
--- a/stdlib/source/test/aedifex/artifact/versioning.lux
+++ b/stdlib/source/test/aedifex/artifact/versioning.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try ("#\." functor)]
- [parser
- ["<.>" xml]]]
- [math
- ["." random (#+ Random)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try ("#\." functor)]
+ [parser
+ ["<.>" xml]]]
+ [math
+ ["." random (#+ Random)]]]]
[\\program
["." /]]
["$." // #_
diff --git a/stdlib/source/test/aedifex/cache.lux b/stdlib/source/test/aedifex/cache.lux
index d61a88057..20dcf506d 100644
--- a/stdlib/source/test/aedifex/cache.lux
+++ b/stdlib/source/test/aedifex/cache.lux
@@ -1,29 +1,30 @@
(.module:
- [lux (#- Type type)
- ["_" test (#+ Test)]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try]
- [concurrency
- ["." promise (#+ Promise)]]
- [parser
- ["." environment]]]
- [data
- [binary (#+ Binary)]
- ["." text]
- [format
- [xml (#+ XML)]]
- [collection
- ["." set]
- ["." dictionary]]]
- [math
- ["." random (#+ Random) ("#\." monad)]
- [number
- ["n" nat]]]
- [world
- ["." file]
- ["." program]]]
+ [library
+ [lux (#- Type type)
+ ["_" test (#+ Test)]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]
+ [concurrency
+ ["." promise (#+ Promise)]]
+ [parser
+ ["." environment]]]
+ [data
+ [binary (#+ Binary)]
+ ["." text]
+ [format
+ [xml (#+ XML)]]
+ [collection
+ ["." set]
+ ["." dictionary]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]
+ [number
+ ["n" nat]]]
+ [world
+ ["." file]
+ ["." program]]]]
[//
["@." profile]
["@." artifact]
diff --git a/stdlib/source/test/aedifex/cli.lux b/stdlib/source/test/aedifex/cli.lux
index 30813fb94..d2eed16d7 100644
--- a/stdlib/source/test/aedifex/cli.lux
+++ b/stdlib/source/test/aedifex/cli.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- [pipe (#+ case>)]
- ["." try]
- [parser
- ["." cli]]]
- [data
- ["." text ("#\." equivalence)]]
- [math
- ["." random (#+ Random) ("#\." monad)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]
+ [parser
+ ["." cli]]]
+ [data
+ ["." text ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]]]]
[\\program
["." /
["/#" // #_
diff --git a/stdlib/source/test/aedifex/command.lux b/stdlib/source/test/aedifex/command.lux
index 1ba7e6319..fe760258b 100644
--- a/stdlib/source/test/aedifex/command.lux
+++ b/stdlib/source/test/aedifex/command.lux
@@ -1,6 +1,7 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]]]
["." / #_
["#." version]
["#." pom]
diff --git a/stdlib/source/test/aedifex/command/auto.lux b/stdlib/source/test/aedifex/command/auto.lux
index 193a5b8d8..8539ce672 100644
--- a/stdlib/source/test/aedifex/command/auto.lux
+++ b/stdlib/source/test/aedifex/command/auto.lux
@@ -1,36 +1,37 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- [pipe (#+ case>)]
- ["." try]
- [parser
- ["." environment]]
- [concurrency
- ["." atom (#+ Atom)]
- ["." promise (#+ Promise)]]]
- [data
- ["." binary]
- ["." text
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." set]]]
- [math
- ["." random]
- [number
- ["n" nat]]]
- [time
- ["." instant]]
- [world
- [console (#+ Console)]
- ["." shell (#+ Exit Shell)]
- ["." program (#+ Program)]
- ["." file
- ["." watch]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]
+ [parser
+ ["." environment]]
+ [concurrency
+ ["." atom (#+ Atom)]
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." binary]
+ ["." text
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." set]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]
+ [time
+ ["." instant]]
+ [world
+ [console (#+ Console)]
+ ["." shell (#+ Exit Shell)]
+ ["." program (#+ Program)]
+ ["." file
+ ["." watch]]]]]
["." // #_
["$." version]
["$." build]]
diff --git a/stdlib/source/test/aedifex/command/build.lux b/stdlib/source/test/aedifex/command/build.lux
index 191ac1039..a702d4c3d 100644
--- a/stdlib/source/test/aedifex/command/build.lux
+++ b/stdlib/source/test/aedifex/command/build.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- [io (#+ IO)]
- ["." try]
- ["." exception]
- [concurrency
- ["." promise (#+ Promise)]]
- [parser
- ["." environment]]]
- [data
- ["." text ("#\." equivalence)]
- [collection
- ["." dictionary]]]
- [math
- ["." random (#+ Random)]]
- [world
- ["." file]
- ["." shell (#+ Shell)]
- ["." program]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [io (#+ IO)]
+ ["." try]
+ ["." exception]
+ [concurrency
+ ["." promise (#+ Promise)]]
+ [parser
+ ["." environment]]]
+ [data
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." dictionary]]]
+ [math
+ ["." random (#+ Random)]]
+ [world
+ ["." file]
+ ["." shell (#+ Shell)]
+ ["." program]]]]
["." // #_
["@." version]
["$/#" // #_
diff --git a/stdlib/source/test/aedifex/command/clean.lux b/stdlib/source/test/aedifex/command/clean.lux
index 6ee155b33..f0a5f4b58 100644
--- a/stdlib/source/test/aedifex/command/clean.lux
+++ b/stdlib/source/test/aedifex/command/clean.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- [binary (#+ Binary)]
- ["." product]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]
- ["." set]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]
- [world
- ["." file (#+ Path)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ [binary (#+ Binary)]
+ ["." product]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]
+ ["." set]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]
+ [world
+ ["." file (#+ Path)]]]]
[//
["@." version]
[//
diff --git a/stdlib/source/test/aedifex/command/deploy.lux b/stdlib/source/test/aedifex/command/deploy.lux
index 7b3664da8..d1b955c77 100644
--- a/stdlib/source/test/aedifex/command/deploy.lux
+++ b/stdlib/source/test/aedifex/command/deploy.lux
@@ -1,32 +1,33 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise)]]
- [parser
- ["." environment]]]
- [data
- ["." maybe]
- ["." binary ("#\." equivalence)]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- ["." format #_
- ["#" binary]
- ["." tar]
- ["." xml]]
- [collection
- ["." set]]]
- [math
- ["." random]]
- [world
- ["." file]
- ["." program (#+ Program)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]]
+ [parser
+ ["." environment]]]
+ [data
+ ["." maybe]
+ ["." binary ("#\." equivalence)]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ ["." format #_
+ ["#" binary]
+ ["." tar]
+ ["." xml]]
+ [collection
+ ["." set]]]
+ [math
+ ["." random]]
+ [world
+ ["." file]
+ ["." program (#+ Program)]]]]
[program
[compositor
["." export]]]
diff --git a/stdlib/source/test/aedifex/command/deps.lux b/stdlib/source/test/aedifex/command/deps.lux
index 63561542d..738cd5090 100644
--- a/stdlib/source/test/aedifex/command/deps.lux
+++ b/stdlib/source/test/aedifex/command/deps.lux
@@ -1,30 +1,31 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- ["." predicate]]
- [control
- ["." try]
- [concurrency
- ["." promise]]
- [parser
- ["." environment]]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." dictionary]
- ["." set]]
- [format
- ["." xml]]]
- [math
- ["." random (#+ Random)]]
- [world
- ["." program]
- ["." file]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ ["." predicate]]
+ [control
+ ["." try]
+ [concurrency
+ ["." promise]]
+ [parser
+ ["." environment]]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." dictionary]
+ ["." set]]
+ [format
+ ["." xml]]]
+ [math
+ ["." random (#+ Random)]]
+ [world
+ ["." program]
+ ["." file]]]]
["." // #_
["@." version]
["$/#" // #_
diff --git a/stdlib/source/test/aedifex/command/install.lux b/stdlib/source/test/aedifex/command/install.lux
index ae9885401..70df9b7a3 100644
--- a/stdlib/source/test/aedifex/command/install.lux
+++ b/stdlib/source/test/aedifex/command/install.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try) ("#\." functor)]
- ["." exception]
- [concurrency
- ["." promise (#+ Promise)]]
- [parser
- ["." environment]]]
- [data
- ["." binary]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." set (#+ Set)]]]
- [math
- ["." random]]
- [world
- ["." file]
- ["." program (#+ Program)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try) ("#\." functor)]
+ ["." exception]
+ [concurrency
+ ["." promise (#+ Promise)]]
+ [parser
+ ["." environment]]]
+ [data
+ ["." binary]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." set (#+ Set)]]]
+ [math
+ ["." random]]
+ [world
+ ["." file]
+ ["." program (#+ Program)]]]]
[//
["$." version]
[//
diff --git a/stdlib/source/test/aedifex/command/pom.lux b/stdlib/source/test/aedifex/command/pom.lux
index 39e2eecfc..624be95bd 100644
--- a/stdlib/source/test/aedifex/command/pom.lux
+++ b/stdlib/source/test/aedifex/command/pom.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try ("#\." functor)]
- [concurrency
- ["." promise]]]
- [data
- ["." binary ("#\." equivalence)]
- ["." text ("#\." equivalence)
- [encoding
- ["." utf8]]]
- [format
- ["." xml]]]
- [math
- ["." random]]
- [world
- ["." file]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try ("#\." functor)]
+ [concurrency
+ ["." promise]]]
+ [data
+ ["." binary ("#\." equivalence)]
+ ["." text ("#\." equivalence)
+ [encoding
+ ["." utf8]]]
+ [format
+ ["." xml]]]
+ [math
+ ["." random]]
+ [world
+ ["." file]]]]
[//
["@." version]
[//
diff --git a/stdlib/source/test/aedifex/command/test.lux b/stdlib/source/test/aedifex/command/test.lux
index a6029ba8c..4621028ae 100644
--- a/stdlib/source/test/aedifex/command/test.lux
+++ b/stdlib/source/test/aedifex/command/test.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["." exception]
- [concurrency
- ["." promise]]
- [parser
- ["." environment]]]
- [data
- ["." text ("#\." equivalence)]
- [collection
- ["." dictionary]
- ["." list]]]
- [math
- ["." random]]
- [world
- ["." file]
- ["." shell]
- ["." program]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception]
+ [concurrency
+ ["." promise]]
+ [parser
+ ["." environment]]]
+ [data
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." dictionary]
+ ["." list]]]
+ [math
+ ["." random]]
+ [world
+ ["." file]
+ ["." shell]
+ ["." program]]]]
["." // #_
["@." version]
["@." build]
diff --git a/stdlib/source/test/aedifex/command/version.lux b/stdlib/source/test/aedifex/command/version.lux
index d3f815ed1..4a8ccc1be 100644
--- a/stdlib/source/test/aedifex/command/version.lux
+++ b/stdlib/source/test/aedifex/command/version.lux
@@ -1,27 +1,28 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["." exception (#+ exception:)]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." maybe]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]
- [math
- ["." random]]
- [tool
- [compiler
- ["." version]
- ["." language #_
- ["#/." lux #_
- ["#" version]]]]]
- [world
- ["." console (#+ Console Mock)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception (#+ exception:)]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." maybe]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]
+ [math
+ ["." random]]
+ [tool
+ [compiler
+ ["." version]
+ ["." language #_
+ ["#/." lux #_
+ ["#" version]]]]]
+ [world
+ ["." console (#+ Console Mock)]]]]
[///
["@." profile]]
[\\program
diff --git a/stdlib/source/test/aedifex/dependency.lux b/stdlib/source/test/aedifex/dependency.lux
index 189da054c..d12434d1f 100644
--- a/stdlib/source/test/aedifex/dependency.lux
+++ b/stdlib/source/test/aedifex/dependency.lux
@@ -1,12 +1,13 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [math
- ["." random (#+ Random)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [math
+ ["." random (#+ Random)]]]]
[//
["@." artifact]]
[\\program
diff --git a/stdlib/source/test/aedifex/dependency/deployment.lux b/stdlib/source/test/aedifex/dependency/deployment.lux
index 6e44e03db..a99f37ca1 100644
--- a/stdlib/source/test/aedifex/dependency/deployment.lux
+++ b/stdlib/source/test/aedifex/dependency/deployment.lux
@@ -1,36 +1,37 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- ["." hash (#+ Hash)]]
- [control
- ["." io (#+ IO)]
- ["." try ("#\." functor)]
- [concurrency
- ["." atom (#+ Atom)]
- ["." promise]]]
- [data
- ["." product]
- ["." maybe ("#\." functor)]
- ["." binary (#+ Binary) ("#\." equivalence)]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary (#+ Dictionary)]
- ["." set]
- ["." list ("#\." fold)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]
- [world
- [net (#+ URL)
- ["." uri (#+ URI)]
- ["." http #_
- ["#" client]
- ["#/." status]
- ["@#" /]]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ ["." hash (#+ Hash)]]
+ [control
+ ["." io (#+ IO)]
+ ["." try ("#\." functor)]
+ [concurrency
+ ["." atom (#+ Atom)]
+ ["." promise]]]
+ [data
+ ["." product]
+ ["." maybe ("#\." functor)]
+ ["." binary (#+ Binary) ("#\." equivalence)]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary (#+ Dictionary)]
+ ["." set]
+ ["." list ("#\." fold)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]
+ [world
+ [net (#+ URL)
+ ["." uri (#+ URI)]
+ ["." http #_
+ ["#" client]
+ ["#/." status]
+ ["@#" /]]]]]]
["$." //
["#/" // #_
["#." package]]]
diff --git a/stdlib/source/test/aedifex/dependency/resolution.lux b/stdlib/source/test/aedifex/dependency/resolution.lux
index 24cde0b53..638199af3 100644
--- a/stdlib/source/test/aedifex/dependency/resolution.lux
+++ b/stdlib/source/test/aedifex/dependency/resolution.lux
@@ -1,31 +1,32 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- ["." predicate]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try]
- ["." exception]
- [concurrency
- ["." promise]]]
- [data
- [binary (#+ Binary)]
- ["." product]
- ["." text
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [format
- ["." xml]]
- [collection
- ["." dictionary]
- ["." set]
- ["." list]]]
- [math
- ["." random (#+ Random)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ ["." predicate]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try]
+ ["." exception]
+ [concurrency
+ ["." promise]]]
+ [data
+ [binary (#+ Binary)]
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [format
+ ["." xml]]
+ [collection
+ ["." dictionary]
+ ["." set]
+ ["." list]]]
+ [math
+ ["." random (#+ Random)]]]]
["$." /// #_
["#." package]
["#." repository]
diff --git a/stdlib/source/test/aedifex/dependency/status.lux b/stdlib/source/test/aedifex/dependency/status.lux
index a709e6ca2..a3ac5df4e 100644
--- a/stdlib/source/test/aedifex/dependency/status.lux
+++ b/stdlib/source/test/aedifex/dependency/status.lux
@@ -1,11 +1,12 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [\spec
- ["$." equivalence]]]
- [math
- ["." random (#+ Random) ("#\." monad)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [\\spec
+ ["$." equivalence]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]]]]
["$." /// #_
["#." hash]]
[\\program
diff --git a/stdlib/source/test/aedifex/hash.lux b/stdlib/source/test/aedifex/hash.lux
index f4f6fe441..9064dac8b 100644
--- a/stdlib/source/test/aedifex/hash.lux
+++ b/stdlib/source/test/aedifex/hash.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." codec]]]
- [control
- ["." try]
- ["." exception]]
- [data
- ["." binary (#+ Binary)]
- [text
- ["%" format (#+ format)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." codec]]]
+ [control
+ ["." try]
+ ["." exception]]
+ [data
+ ["." binary (#+ Binary)]
+ [text
+ ["%" format (#+ format)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
[\\program
["." /]]
[test
diff --git a/stdlib/source/test/aedifex/input.lux b/stdlib/source/test/aedifex/input.lux
index cf573bb25..529185320 100644
--- a/stdlib/source/test/aedifex/input.lux
+++ b/stdlib/source/test/aedifex/input.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- [text
- ["%" format]
- [encoding
- ["." utf8]]]
- [collection
- ["." set (#+ Set)]]]
- [math
- ["." random]]
- [world
- ["." file]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ [text
+ ["%" format]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." set (#+ Set)]]]
+ [math
+ ["." random]]
+ [world
+ ["." file]]]]
[//
["$." profile]]
[\\program
diff --git a/stdlib/source/test/aedifex/local.lux b/stdlib/source/test/aedifex/local.lux
index 89e4db9de..bd78c3464 100644
--- a/stdlib/source/test/aedifex/local.lux
+++ b/stdlib/source/test/aedifex/local.lux
@@ -1,12 +1,13 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- ["." text]]
- [math
- ["." random (#+ Random)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." text]]
+ [math
+ ["." random (#+ Random)]]]]
[//
["@." artifact]]
[\\program
diff --git a/stdlib/source/test/aedifex/metadata.lux b/stdlib/source/test/aedifex/metadata.lux
index 2975939bc..d4e6e816c 100644
--- a/stdlib/source/test/aedifex/metadata.lux
+++ b/stdlib/source/test/aedifex/metadata.lux
@@ -1,12 +1,13 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- ["." text ("#\." equivalence)]]
- [math
- ["." random]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." text ("#\." equivalence)]]
+ [math
+ ["." random]]]]
["." / #_
["#." artifact]
["#." snapshot]
diff --git a/stdlib/source/test/aedifex/metadata/artifact.lux b/stdlib/source/test/aedifex/metadata/artifact.lux
index 56e856b88..b84eca173 100644
--- a/stdlib/source/test/aedifex/metadata/artifact.lux
+++ b/stdlib/source/test/aedifex/metadata/artifact.lux
@@ -1,27 +1,28 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try ("#\." functor)]
- [parser
- ["<.>" xml]]]
- [math
- [number
- ["n" nat]]]
- ["." time
- ["." date]
- ["." year]
- ["." month]
- ["." instant]
- ["." duration]]
- [math
- ["." random (#+ Random)]]
- [macro
- ["." code]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try ("#\." functor)]
+ [parser
+ ["<.>" xml]]]
+ [math
+ [number
+ ["n" nat]]]
+ ["." time
+ ["." date]
+ ["." year]
+ ["." month]
+ ["." instant]
+ ["." duration]]
+ [math
+ ["." random (#+ Random)]]
+ [macro
+ ["." code]]]]
[\\program
["." /]])
diff --git a/stdlib/source/test/aedifex/metadata/snapshot.lux b/stdlib/source/test/aedifex/metadata/snapshot.lux
index d94c66761..d34eb60a9 100644
--- a/stdlib/source/test/aedifex/metadata/snapshot.lux
+++ b/stdlib/source/test/aedifex/metadata/snapshot.lux
@@ -1,27 +1,28 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try ("#\." functor)]
- [parser
- ["<.>" xml]]]
- [math
- [number
- ["n" nat]]]
- ["." time
- ["." date]
- ["." year]
- ["." month]
- ["." instant (#+ Instant)]
- ["." duration]]
- [math
- ["." random (#+ Random) ("#\." monad)]]
- [macro
- ["." code]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try ("#\." functor)]
+ [parser
+ ["<.>" xml]]]
+ [math
+ [number
+ ["n" nat]]]
+ ["." time
+ ["." date]
+ ["." year]
+ ["." month]
+ ["." instant (#+ Instant)]
+ ["." duration]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]]
+ [macro
+ ["." code]]]]
["$." /// #_
["#." artifact
["#/." type]
diff --git a/stdlib/source/test/aedifex/package.lux b/stdlib/source/test/aedifex/package.lux
index 61e36aaf7..ef23f35ce 100644
--- a/stdlib/source/test/aedifex/package.lux
+++ b/stdlib/source/test/aedifex/package.lux
@@ -1,29 +1,30 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try]
- [concurrency
- [promise (#+ Promise)]]]
- [data
- ["." product]
- ["." text
- [encoding
- ["." utf8]]]
- [format
- ["." xml (#+ XML)]]
- [collection
- ["." set (#+ Set)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]
- [world
- ["." file]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try]
+ [concurrency
+ [promise (#+ Promise)]]]
+ [data
+ ["." product]
+ ["." text
+ [encoding
+ ["." utf8]]]
+ [format
+ ["." xml (#+ XML)]]
+ [collection
+ ["." set (#+ Set)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]
+ [world
+ ["." file]]]]
[//
["$." profile]
[//
diff --git a/stdlib/source/test/aedifex/parser.lux b/stdlib/source/test/aedifex/parser.lux
index 01c763349..33beaa7f9 100644
--- a/stdlib/source/test/aedifex/parser.lux
+++ b/stdlib/source/test/aedifex/parser.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [hash (#+ Hash)]]
- [control
- [pipe (#+ case>)]
- ["." try]
- [parser
- ["<.>" code]]]
- [data
- ["." text]
- [collection
- ["." set (#+ Set)]
- ["." dictionary (#+ Dictionary)]
- ["." list ("#\." functor)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]
- [macro
- ["." code]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [hash (#+ Hash)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]
+ [parser
+ ["<.>" code]]]
+ [data
+ ["." text]
+ [collection
+ ["." set (#+ Set)]
+ ["." dictionary (#+ Dictionary)]
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]
+ [macro
+ ["." code]]]]
[//
["@." profile]]
[\\program
diff --git a/stdlib/source/test/aedifex/pom.lux b/stdlib/source/test/aedifex/pom.lux
index ad3b1d801..24ca3c3c6 100644
--- a/stdlib/source/test/aedifex/pom.lux
+++ b/stdlib/source/test/aedifex/pom.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["." exception]
- ["<>" parser
- ["<.>" xml]]]
- [data
- [format
- ["." xml]]]
- [math
- ["." random]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception]
+ ["<>" parser
+ ["<.>" xml]]]
+ [data
+ [format
+ ["." xml]]]
+ [math
+ ["." random]]]]
[//
["@." profile]]
[\\program
diff --git a/stdlib/source/test/aedifex/profile.lux b/stdlib/source/test/aedifex/profile.lux
index e7e3f50ac..418756ffd 100644
--- a/stdlib/source/test/aedifex/profile.lux
+++ b/stdlib/source/test/aedifex/profile.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [hash (#+ Hash)]
- [\spec
- ["$." equivalence]
- ["$." monoid]]]
- [control
- [pipe (#+ case>)]
- ["." try]
- [parser
- ["." cli]]]
- [data
- ["." text]
- [collection
- ["." set (#+ Set)]
- ["." dictionary (#+ Dictionary)]]]
- [math
- ["." random (#+ Random) ("#\." monad)]
- [number
- ["n" nat]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [hash (#+ Hash)]
+ [\\spec
+ ["$." equivalence]
+ ["$." monoid]]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]
+ [parser
+ ["." cli]]]
+ [data
+ ["." text]
+ [collection
+ ["." set (#+ Set)]
+ ["." dictionary (#+ Dictionary)]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]
+ [number
+ ["n" nat]]]]]
[//
["@." artifact]
["@." dependency]]
diff --git a/stdlib/source/test/aedifex/project.lux b/stdlib/source/test/aedifex/project.lux
index d2c12109f..e1b4b051a 100644
--- a/stdlib/source/test/aedifex/project.lux
+++ b/stdlib/source/test/aedifex/project.lux
@@ -1,21 +1,22 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." monoid]]]
- [control
- ["." try ("#\." functor)]
- ["." exception]]
- [data
- ["." product]
- ["." text ("#\." equivalence)]]
- [math
- ["." random (#+ Random) ("#\." monad)]
- [number
- ["n" nat]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." monoid]]]
+ [control
+ ["." try ("#\." functor)]
+ ["." exception]]
+ [data
+ ["." product]
+ ["." text ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]
+ [number
+ ["n" nat]]]]]
[//
["@." profile]]
[\\program
diff --git a/stdlib/source/test/aedifex/repository.lux b/stdlib/source/test/aedifex/repository.lux
index 6241e14e9..c86f3d52d 100644
--- a/stdlib/source/test/aedifex/repository.lux
+++ b/stdlib/source/test/aedifex/repository.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]
- ["." monad (#+ do)]]
- [control
- ["." io]
- ["." try]
- ["." exception (#+ exception:)]]
- [data
- ["." product]
- ["." binary (#+ Binary)]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." dictionary (#+ Dictionary)]]]
- [math
- ["." random (#+ Random)]]
- [world
- [net
- ["." uri (#+ URI)]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]
+ ["." monad (#+ do)]]
+ [control
+ ["." io]
+ ["." try]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." product]
+ ["." binary (#+ Binary)]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary (#+ Dictionary)]]]
+ [math
+ ["." random (#+ Random)]]
+ [world
+ [net
+ ["." uri (#+ URI)]]]]]
["." / #_
["#." identity]
["#." origin]
diff --git a/stdlib/source/test/aedifex/repository/identity.lux b/stdlib/source/test/aedifex/repository/identity.lux
index df454b436..061bd9de0 100644
--- a/stdlib/source/test/aedifex/repository/identity.lux
+++ b/stdlib/source/test/aedifex/repository/identity.lux
@@ -1,11 +1,12 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [\spec
- ["$." equivalence]]]
- [math
- ["." random (#+ Random)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [\\spec
+ ["$." equivalence]]]
+ [math
+ ["." random (#+ Random)]]]]
[\\program
["." /]])
diff --git a/stdlib/source/test/aedifex/repository/local.lux b/stdlib/source/test/aedifex/repository/local.lux
index 5bf4c5113..1bbf2f7bb 100644
--- a/stdlib/source/test/aedifex/repository/local.lux
+++ b/stdlib/source/test/aedifex/repository/local.lux
@@ -1,24 +1,25 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try ("#\." functor)]
- [parser
- ["." environment]]
- [concurrency
- ["." promise]]]
- [data
- ["." binary ("#\." equivalence)]
- [text
- [encoding
- ["." utf8]]]]
- [math
- ["." random]]
- [world
- ["." file]
- ["." program]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try ("#\." functor)]
+ [parser
+ ["." environment]]
+ [concurrency
+ ["." promise]]]
+ [data
+ ["." binary ("#\." equivalence)]
+ [text
+ [encoding
+ ["." utf8]]]]
+ [math
+ ["." random]]
+ [world
+ ["." file]
+ ["." program]]]]
[\\program
["." /]])
diff --git a/stdlib/source/test/aedifex/repository/origin.lux b/stdlib/source/test/aedifex/repository/origin.lux
index 7b3675f40..6531726fe 100644
--- a/stdlib/source/test/aedifex/repository/origin.lux
+++ b/stdlib/source/test/aedifex/repository/origin.lux
@@ -1,11 +1,12 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [\spec
- ["$." equivalence]]]
- [math
- ["." random (#+ Random)]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [\\spec
+ ["$." equivalence]]]
+ [math
+ ["." random (#+ Random)]]]]
[\\program
["." /]])
diff --git a/stdlib/source/test/aedifex/repository/remote.lux b/stdlib/source/test/aedifex/repository/remote.lux
index 0fa784a77..5f74cab9d 100644
--- a/stdlib/source/test/aedifex/repository/remote.lux
+++ b/stdlib/source/test/aedifex/repository/remote.lux
@@ -1,30 +1,31 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io (#+ IO)]
- ["." try ("#\." monad)]
- ["." exception]
- ["." function]]
- [data
- ["." binary ("#\." equivalence)]
- ["." maybe ("#\." functor)]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- [collection
- ["." dictionary]]]
- [math
- ["." random (#+ Random)]]
- [world
- [net (#+ URL)
- ["." http #_
- ["#" client]
- ["#/." status]
- ["@#" /]]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io (#+ IO)]
+ ["." try ("#\." monad)]
+ ["." exception]
+ ["." function]]
+ [data
+ ["." binary ("#\." equivalence)]
+ ["." maybe ("#\." functor)]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." dictionary]]]
+ [math
+ ["." random (#+ Random)]]
+ [world
+ [net (#+ URL)
+ ["." http #_
+ ["#" client]
+ ["#/." status]
+ ["@#" /]]]]]]
[\\program
["." /
["/#" // #_
diff --git a/stdlib/source/test/aedifex/runtime.lux b/stdlib/source/test/aedifex/runtime.lux
index e75a9297e..24745da4a 100644
--- a/stdlib/source/test/aedifex/runtime.lux
+++ b/stdlib/source/test/aedifex/runtime.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- ["." maybe ("#\." functor)]
- ["." text ("#\." equivalence)]
- [collection
- ["." list ("#\." functor)]
- ["." set]]]
- [math
- ["." random (#+ Random) ("#\." monad)]
- [number
- ["n" nat]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." maybe ("#\." functor)]
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." list ("#\." functor)]
+ ["." set]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]
+ [number
+ ["n" nat]]]]]
[\\program
["." /]])
diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux
index 415bb3500..f1af7f5a5 100644
--- a/stdlib/source/test/lux.lux
+++ b/stdlib/source/test/lux.lux
@@ -3,29 +3,30 @@
(.as_is))
<target> <target>']
(.module:
- ["/" lux #*
- [program (#+ program:)]
- ["_" test (#+ Test)]
- ["@" target]
- [abstract
- [monad (#+ do)]
- [predicate (#+ Predicate)]]
- [control
- ["." io]
- [concurrency
- ["." atom (#+ Atom)]]]
- [data
- ["." name]
- [text
- ["%" format (#+ format)]]]
- ["." math
- ["." random (#+ Random) ("#\." functor)]
- [number
- ["n" nat]
- ["i" int]
- ["r" rev]
- ["f" frac]
- ["." i64]]]]
+ [library
+ ["/" lux #*
+ [program (#+ program:)]
+ ["_" test (#+ Test)]
+ ["@" target]
+ [abstract
+ [monad (#+ do)]
+ [predicate (#+ Predicate)]]
+ [control
+ ["." io]
+ [concurrency
+ ["." atom (#+ Atom)]]]
+ [data
+ ["." name]
+ [text
+ ["%" format (#+ format)]]]
+ ["." math
+ ["." random (#+ Random) ("#\." functor)]
+ [number
+ ["n" nat]
+ ["i" int]
+ ["r" rev]
+ ["f" frac]
+ ["." i64]]]]]
## TODO: Must have 100% coverage on tests.
["." / #_
["#." abstract]
@@ -224,10 +225,12 @@
/locale.test
/macro.test
/math.test
+
/meta.test
/program.test
/target.test
/test.test
+
/time.test
## /tool.test
/type.test
diff --git a/stdlib/source/test/lux/abstract.lux b/stdlib/source/test/lux/abstract.lux
index b31c10617..e8368434b 100644
--- a/stdlib/source/test/lux/abstract.lux
+++ b/stdlib/source/test/lux/abstract.lux
@@ -1,6 +1,7 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]]]
["." / #_
["#." apply]
["#." codec]
diff --git a/stdlib/source/test/lux/abstract/apply.lux b/stdlib/source/test/lux/abstract/apply.lux
index 97bef5b24..01fe8375f 100644
--- a/stdlib/source/test/lux/abstract/apply.lux
+++ b/stdlib/source/test/lux/abstract/apply.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [data
- ["." maybe]
- [collection
- ["." list]]]
- [math
- ["." random]
- [number
- ["n" nat]]]
- ["_" test (#+ Test)]]
- [\\
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." maybe]
+ [collection
+ ["." list]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]
+ ["_" test (#+ Test)]]]
+ [\\library
["." / (#+ Apply)]])
(def: #export test
diff --git a/stdlib/source/test/lux/abstract/codec.lux b/stdlib/source/test/lux/abstract/codec.lux
index 3365c1d66..00452c205 100644
--- a/stdlib/source/test/lux/abstract/codec.lux
+++ b/stdlib/source/test/lux/abstract/codec.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]]
- [data
- ["." bit ("#\." equivalence)]
- [format
- ["." json (#+ JSON)]]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]]
+ [data
+ ["." bit ("#\." equivalence)]
+ [format
+ ["." json (#+ JSON)]]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." / (#+ Codec)
[//
[equivalence (#+ Equivalence)]]]])
diff --git a/stdlib/source/test/lux/abstract/comonad.lux b/stdlib/source/test/lux/abstract/comonad.lux
index 088b4fe55..9b4d935d8 100644
--- a/stdlib/source/test/lux/abstract/comonad.lux
+++ b/stdlib/source/test/lux/abstract/comonad.lux
@@ -1,15 +1,16 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [data
- ["." identity (#+ Identity)]]
- [math
- ["." random]
- [number
- ["n" nat]]]
- ["_" test (#+ Test)]]
- [\\
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." identity (#+ Identity)]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]
+ ["_" test (#+ Test)]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/abstract/comonad/cofree.lux b/stdlib/source/test/lux/abstract/comonad/cofree.lux
index 9e6c8a1b1..82647f79d 100644
--- a/stdlib/source/test/lux/abstract/comonad/cofree.lux
+++ b/stdlib/source/test/lux/abstract/comonad/cofree.lux
@@ -1,21 +1,22 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [functor (#+ Functor)]
- [comonad (#+ CoMonad)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." comonad]]]
- [control
- ["//" continuation]]
- [data
- [collection
- ["." list]
- ["." sequence (#+ Sequence) ("#\." comonad)]]]
- [math
- ["." random]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [functor (#+ Functor)]
+ [comonad (#+ CoMonad)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." comonad]]]
+ [control
+ ["//" continuation]]
+ [data
+ [collection
+ ["." list]
+ ["." sequence (#+ Sequence) ("#\." comonad)]]]
+ [math
+ ["." random]]]]
+ [\\library
["." /]])
(def: (injection value)
diff --git a/stdlib/source/test/lux/abstract/enum.lux b/stdlib/source/test/lux/abstract/enum.lux
index 5a923019c..09ef32175 100644
--- a/stdlib/source/test/lux/abstract/enum.lux
+++ b/stdlib/source/test/lux/abstract/enum.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- ["." product]
- ["." maybe ("#\." functor)]
- [collection
- ["." list ("#\." fold)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." product]
+ ["." maybe ("#\." functor)]
+ [collection
+ ["." list ("#\." fold)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/abstract/equivalence.lux b/stdlib/source/test/lux/abstract/equivalence.lux
index 520fa141c..5b0bfced8 100644
--- a/stdlib/source/test/lux/abstract/equivalence.lux
+++ b/stdlib/source/test/lux/abstract/equivalence.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- [functor
- ["$." contravariant]]]]
- [data
- ["." bit ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["i" int]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ [functor
+ ["$." contravariant]]]]
+ [data
+ ["." bit ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["i" int]]]]]
+ [\\library
["." / (#+ Equivalence)]])
(def: #export test
diff --git a/stdlib/source/test/lux/abstract/fold.lux b/stdlib/source/test/lux/abstract/fold.lux
index 8165c29c3..787a8a03d 100644
--- a/stdlib/source/test/lux/abstract/fold.lux
+++ b/stdlib/source/test/lux/abstract/fold.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- [collection
- ["." list]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ [collection
+ ["." list]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Fold)]])
(def: #export test
diff --git a/stdlib/source/test/lux/abstract/functor.lux b/stdlib/source/test/lux/abstract/functor.lux
index 05b72f73f..63b0ad2d7 100644
--- a/stdlib/source/test/lux/abstract/functor.lux
+++ b/stdlib/source/test/lux/abstract/functor.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- ["." maybe]
- [collection
- ["." list]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." maybe]
+ [collection
+ ["." list]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Functor)]])
(def: #export test
diff --git a/stdlib/source/test/lux/abstract/functor/contravariant.lux b/stdlib/source/test/lux/abstract/functor/contravariant.lux
index 38bf62cbf..6a07cb0c5 100644
--- a/stdlib/source/test/lux/abstract/functor/contravariant.lux
+++ b/stdlib/source/test/lux/abstract/functor/contravariant.lux
@@ -1,7 +1,8 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/abstract/hash.lux b/stdlib/source/test/lux/abstract/hash.lux
index f06a7dfc2..4c9bc67f6 100644
--- a/stdlib/source/test/lux/abstract/hash.lux
+++ b/stdlib/source/test/lux/abstract/hash.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- [functor
- ["$." contravariant]]]]
- [data
- ["." bit ("#\." equivalence)]]
- [math
- ["." random]
- [number
- ["." nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ [functor
+ ["$." contravariant]]]]
+ [data
+ ["." bit ("#\." equivalence)]]
+ [math
+ ["." random]
+ [number
+ ["." nat]]]]]
+ [\\library
["." / (#+ Hash)
[//
[equivalence (#+ Equivalence)]]]])
diff --git a/stdlib/source/test/lux/abstract/interval.lux b/stdlib/source/test/lux/abstract/interval.lux
index db8eb86be..718663b4b 100644
--- a/stdlib/source/test/lux/abstract/interval.lux
+++ b/stdlib/source/test/lux/abstract/interval.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- ["." order]
- [\spec
- ["$." equivalence]]]
- [control
- [pipe (#+ case>)]]
- [data
- [collection
- ["." set]
- ["." list]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ ["." order]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ [pipe (#+ case>)]]
+ [data
+ [collection
+ ["." set]
+ ["." list]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Interval) ("\." equivalence)]])
(template [<name> <cmp>]
diff --git a/stdlib/source/test/lux/abstract/monad.lux b/stdlib/source/test/lux/abstract/monad.lux
index f66ee182f..cc4642e13 100644
--- a/stdlib/source/test/lux/abstract/monad.lux
+++ b/stdlib/source/test/lux/abstract/monad.lux
@@ -1,15 +1,16 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [data
- ["." identity (#+ Identity)]
- [collection
- ["." list ("#\." functor fold)]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [data
+ ["." identity (#+ Identity)]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Monad do)]])
(def: #export test
diff --git a/stdlib/source/test/lux/abstract/monad/free.lux b/stdlib/source/test/lux/abstract/monad/free.lux
index 6afb3ed62..a56c01fd5 100644
--- a/stdlib/source/test/lux/abstract/monad/free.lux
+++ b/stdlib/source/test/lux/abstract/monad/free.lux
@@ -1,20 +1,21 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- [monad (#+ Monad do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]]]
- [data
- [collection
- ["." list ("#\." functor)]]]
- [math
- ["." random]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ [monad (#+ Monad do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]]
+ [data
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random]]]]
+ [\\library
["." /]])
(def: injection
diff --git a/stdlib/source/test/lux/abstract/monoid.lux b/stdlib/source/test/lux/abstract/monoid.lux
index acd00b91a..876ac1f46 100644
--- a/stdlib/source/test/lux/abstract/monoid.lux
+++ b/stdlib/source/test/lux/abstract/monoid.lux
@@ -1,14 +1,15 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [math
- ["." random (#+ Random)]
- [number
- ["." nat]
- ["." int]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["." nat]
+ ["." int]]]]]
+ [\\library
["." /
[//
[equivalence (#+ Equivalence)]]]])
diff --git a/stdlib/source/test/lux/abstract/order.lux b/stdlib/source/test/lux/abstract/order.lux
index 2dc09461c..2173691de 100644
--- a/stdlib/source/test/lux/abstract/order.lux
+++ b/stdlib/source/test/lux/abstract/order.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- [functor
- ["$." contravariant]]]]
- [data
- ["." bit ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ [functor
+ ["$." contravariant]]]]
+ [data
+ ["." bit ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /
[//
[equivalence (#+ Equivalence)]]]])
diff --git a/stdlib/source/test/lux/abstract/predicate.lux b/stdlib/source/test/lux/abstract/predicate.lux
index 133fbdcba..0535b5802 100644
--- a/stdlib/source/test/lux/abstract/predicate.lux
+++ b/stdlib/source/test/lux/abstract/predicate.lux
@@ -1,24 +1,25 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]
- [\spec
- ["$." monoid]
- [functor
- ["$." contravariant]]]]
- [control
- ["." function]]
- [data
- ["." bit ("#\." equivalence)]
- [collection
- ["." list]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]
+ [\\spec
+ ["$." monoid]
+ [functor
+ ["$." contravariant]]]]
+ [control
+ ["." function]]
+ [data
+ ["." bit ("#\." equivalence)]
+ [collection
+ ["." list]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: (multiple? factor)
diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux
index faf08f9b8..e1ab4f5f1 100644
--- a/stdlib/source/test/lux/control.lux
+++ b/stdlib/source/test/lux/control.lux
@@ -1,6 +1,7 @@
(.module:
- [lux (#- function)
- ["_" test (#+ Test)]]
+ [library
+ [lux (#- function)
+ ["_" test (#+ Test)]]]
["." / #_
["#." concatenative]
["#." concurrency #_
diff --git a/stdlib/source/test/lux/control/concatenative.lux b/stdlib/source/test/lux/control/concatenative.lux
index bfac126b0..39265aafe 100644
--- a/stdlib/source/test/lux/control/concatenative.lux
+++ b/stdlib/source/test/lux/control/concatenative.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- ["." sum]
- ["." name]
- ["." bit ("#\." equivalence)]]
- [macro
- ["." template]]
- [math
- ["." random]
- [number
- ["n" nat]
- ["i" int]
- ["r" rev]
- ["f" frac]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." sum]
+ ["." name]
+ ["." bit ("#\." equivalence)]]
+ [macro
+ ["." template]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]
+ ["i" int]
+ ["r" rev]
+ ["f" frac]]]]]
+ [\\library
["." / (#+ word: => ||>)]])
(def: stack_shuffling
diff --git a/stdlib/source/test/lux/control/concurrency/actor.lux b/stdlib/source/test/lux/control/concurrency/actor.lux
index 854a50814..f229909bd 100644
--- a/stdlib/source/test/lux/control/concurrency/actor.lux
+++ b/stdlib/source/test/lux/control/concurrency/actor.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." io (#+ IO io)]]
- [data
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list]
- ["." row (#+ Row)]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO io)]]
+ [data
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list]
+ ["." row (#+ Row)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ actor: message:)
[//
["." atom (#+ Atom)]
diff --git a/stdlib/source/test/lux/control/concurrency/atom.lux b/stdlib/source/test/lux/control/concurrency/atom.lux
index b160f64e0..674e7dd3f 100644
--- a/stdlib/source/test/lux/control/concurrency/atom.lux
+++ b/stdlib/source/test/lux/control/concurrency/atom.lux
@@ -1,15 +1,16 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/control/concurrency/frp.lux b/stdlib/source/test/lux/control/concurrency/frp.lux
index 659881a20..45d626600 100644
--- a/stdlib/source/test/lux/control/concurrency/frp.lux
+++ b/stdlib/source/test/lux/control/concurrency/frp.lux
@@ -1,25 +1,26 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]]]
- [control
- ["." try]
- ["." exception]
- ["." io (#+ IO io)]]
- [data
- [collection
- ["." list ("#\." fold monoid)]
- ["." row (#+ Row)]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]]
+ [control
+ ["." try]
+ ["." exception]
+ ["." io (#+ IO io)]]
+ [data
+ [collection
+ ["." list ("#\." fold monoid)]
+ ["." row (#+ Row)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /
[//
["." promise (#+ Promise) ("#\." monad)]
diff --git a/stdlib/source/test/lux/control/concurrency/promise.lux b/stdlib/source/test/lux/control/concurrency/promise.lux
index 16c60c508..6b6b0ac14 100644
--- a/stdlib/source/test/lux/control/concurrency/promise.lux
+++ b/stdlib/source/test/lux/control/concurrency/promise.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["@" target]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]]]
- [control
- [pipe (#+ case>)]
- ["." io]]
- [time
- ["." instant]
- ["." duration]]
- [math
- ["." random]
- [number
- ["n" nat]
- ["i" int]
- ["." i64]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["@" target]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]]
+ [control
+ [pipe (#+ case>)]
+ ["." io]]
+ [time
+ ["." instant]
+ ["." duration]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]
+ ["i" int]
+ ["." i64]]]]]
+ [\\library
["." /
[//
["." atom (#+ Atom)]]]])
diff --git a/stdlib/source/test/lux/control/concurrency/semaphore.lux b/stdlib/source/test/lux/control/concurrency/semaphore.lux
index 8924cf66f..38e152456 100644
--- a/stdlib/source/test/lux/control/concurrency/semaphore.lux
+++ b/stdlib/source/test/lux/control/concurrency/semaphore.lux
@@ -1,31 +1,32 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["@" target]
- [abstract
- ["." monad (#+ do)]
- ["." enum]]
- [control
- ["." io]
- ["." try]
- ["." exception (#+ exception:)]
- [concurrency
- ["." promise (#+ Promise)]
- ["." atom (#+ Atom)]]]
- [data
- ["." maybe]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]]]
- [math
- ["." random]
- [number
- ["n" nat]
- ["." i64]]]
- [type
- ["." refinement]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["@" target]
+ [abstract
+ ["." monad (#+ do)]
+ ["." enum]]
+ [control
+ ["." io]
+ ["." try]
+ ["." exception (#+ exception:)]
+ [concurrency
+ ["." promise (#+ Promise)]
+ ["." atom (#+ Atom)]]]
+ [data
+ ["." maybe]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]
+ ["." i64]]]
+ [type
+ ["." refinement]]]]
+ [\\library
["." /]])
(def: delay
diff --git a/stdlib/source/test/lux/control/concurrency/stm.lux b/stdlib/source/test/lux/control/concurrency/stm.lux
index 6bbbc3f54..6667274b5 100644
--- a/stdlib/source/test/lux/control/concurrency/stm.lux
+++ b/stdlib/source/test/lux/control/concurrency/stm.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- ["." monad (#+ Monad do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]]]
- [control
- ["." io (#+ IO)]]
- [data
- ["." product]
- [collection
- ["." list ("#\." functor)]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ ["." monad (#+ Monad do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]]
+ [control
+ ["." io (#+ IO)]]
+ [data
+ ["." product]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /
[//
["." atom (#+ Atom atom)]
diff --git a/stdlib/source/test/lux/control/concurrency/thread.lux b/stdlib/source/test/lux/control/concurrency/thread.lux
index df005c4ac..557b6a80b 100644
--- a/stdlib/source/test/lux/control/concurrency/thread.lux
+++ b/stdlib/source/test/lux/control/concurrency/thread.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io]]
- [time
- ["." instant (#+ Instant)]
- ["." duration]]
- [math
- ["." random]
- [number
- ["n" nat]
- ["i" int]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io]]
+ [time
+ ["." instant (#+ Instant)]
+ ["." duration]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]
+ ["i" int]]]]]
+ [\\library
["." /
[//
["." atom (#+ Atom)]
diff --git a/stdlib/source/test/lux/control/continuation.lux b/stdlib/source/test/lux/control/continuation.lux
index a85418f8a..bec8160c1 100644
--- a/stdlib/source/test/lux/control/continuation.lux
+++ b/stdlib/source/test/lux/control/continuation.lux
@@ -1,20 +1,21 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]]]
- [data
- [collection
- ["." list]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]]
+ [data
+ [collection
+ ["." list]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: injection
diff --git a/stdlib/source/test/lux/control/exception.lux b/stdlib/source/test/lux/control/exception.lux
index e63a2b66e..f62ad9271 100644
--- a/stdlib/source/test/lux/control/exception.lux
+++ b/stdlib/source/test/lux/control/exception.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ exception:)
[//
["." try (#+ Try)]]]])
diff --git a/stdlib/source/test/lux/control/function.lux b/stdlib/source/test/lux/control/function.lux
index 6463e4c1c..8669e4220 100644
--- a/stdlib/source/test/lux/control/function.lux
+++ b/stdlib/source/test/lux/control/function.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]
- [\spec
- ["$." monoid]]]
- [data
- ["." text ("#!." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]
+ [\\spec
+ ["$." monoid]]]
+ [data
+ ["." text ("#!." equivalence)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]]
["." / #_
["#." contract]
diff --git a/stdlib/source/test/lux/control/function/contract.lux b/stdlib/source/test/lux/control/function/contract.lux
index e1b06a325..81840fd08 100644
--- a/stdlib/source/test/lux/control/function/contract.lux
+++ b/stdlib/source/test/lux/control/function/contract.lux
@@ -1,15 +1,16 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/control/function/memo.lux b/stdlib/source/test/lux/control/function/memo.lux
index 87cf14b0b..29c39dbdb 100644
--- a/stdlib/source/test/lux/control/function/memo.lux
+++ b/stdlib/source/test/lux/control/function/memo.lux
@@ -1,25 +1,26 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io (#+ IO)]
- ["." state (#+ State) ("#\." monad)]]
- [data
- ["." product]
- [collection
- ["." dictionary (#+ Dictionary)]
- ["." list ("#\." functor fold)]]]
- [math
- ["." random]
- [number
- ["n" nat]
- ["." i64]]]
- [time
- ["." instant]
- ["." duration (#+ Duration)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io (#+ IO)]
+ ["." state (#+ State) ("#\." monad)]]
+ [data
+ ["." product]
+ [collection
+ ["." dictionary (#+ Dictionary)]
+ ["." list ("#\." functor fold)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]
+ ["." i64]]]
+ [time
+ ["." instant]
+ ["." duration (#+ Duration)]]]]
+ [\\library
["." /
["/#" // #_
["#" mixin]]]])
diff --git a/stdlib/source/test/lux/control/function/mixin.lux b/stdlib/source/test/lux/control/function/mixin.lux
index 35cd36027..a74ca04d4 100644
--- a/stdlib/source/test/lux/control/function/mixin.lux
+++ b/stdlib/source/test/lux/control/function/mixin.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [equivalence (#+ Equivalence)]
- [predicate (#+ Predicate)]
- [monad (#+ do)]
- [\spec
- ["$." monoid]]]
- [control
- ["." state (#+ State)]]
- [data
- ["." product]
- [collection
- ["." list ("#\." functor fold)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [predicate (#+ Predicate)]
+ [monad (#+ do)]
+ [\\spec
+ ["$." monoid]]]
+ [control
+ ["." state (#+ State)]]
+ [data
+ ["." product]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/control/function/mutual.lux b/stdlib/source/test/lux/control/function/mutual.lux
index 120413e5a..c9fbfbace 100644
--- a/stdlib/source/test/lux/control/function/mutual.lux
+++ b/stdlib/source/test/lux/control/function/mutual.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- ["." bit ("#\." equivalence)]
- [text
- ["%" format (#+ format)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." bit ("#\." equivalence)]
+ [text
+ ["%" format (#+ format)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: test_let
diff --git a/stdlib/source/test/lux/control/io.lux b/stdlib/source/test/lux/control/io.lux
index a45fd28a9..1db7423e8 100644
--- a/stdlib/source/test/lux/control/io.lux
+++ b/stdlib/source/test/lux/control/io.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ IO)
[//
["." function]]]])
diff --git a/stdlib/source/test/lux/control/parser.lux b/stdlib/source/test/lux/control/parser.lux
index 81155f605..ff8520b10 100644
--- a/stdlib/source/test/lux/control/parser.lux
+++ b/stdlib/source/test/lux/control/parser.lux
@@ -1,30 +1,31 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [equivalence (#+ Equivalence)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]]]
- [control
- ["." try (#+ Try)]
- [parser
- ["<.>" code]]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]]]
- [math
- ["." random]
- [number
- ["n" nat]]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [equivalence (#+ Equivalence)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]]
+ [control
+ ["." try (#+ Try)]
+ [parser
+ ["<.>" code]]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]]]]
+ [\\library
["." / (#+ Parser)]]
["." / #_
["#." analysis]
diff --git a/stdlib/source/test/lux/control/parser/analysis.lux b/stdlib/source/test/lux/control/parser/analysis.lux
index 49e7b0478..8be89e101 100644
--- a/stdlib/source/test/lux/control/parser/analysis.lux
+++ b/stdlib/source/test/lux/control/parser/analysis.lux
@@ -1,34 +1,35 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- [pipe (#+ case>)]
- ["." try]
- ["." exception]
- ["<>" parser]]
- [data
- ["." name ("#\." equivalence)]
- ["." bit ("#\." equivalence)]
- ["." text ("#\." equivalence)]
- [collection
- ["." list]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["i" int]
- ["f" frac]
- ["r" rev]]]
- [tool
- [compiler
- [reference (#+ Constant)
- [variable (#+)]]
- [language
- [lux
- ["." analysis]]]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]
+ ["." exception]
+ ["<>" parser]]
+ [data
+ ["." name ("#\." equivalence)]
+ ["." bit ("#\." equivalence)]
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." list]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["i" int]
+ ["f" frac]
+ ["r" rev]]]
+ [tool
+ [compiler
+ [reference (#+ Constant)
+ [variable (#+)]]
+ [language
+ [lux
+ ["." analysis]]]]]]]
+ [\\library
["." /]])
(template: (!expect <expectation> <computation>)
diff --git a/stdlib/source/test/lux/control/parser/binary.lux b/stdlib/source/test/lux/control/parser/binary.lux
index 289a80ba9..972078a43 100644
--- a/stdlib/source/test/lux/control/parser/binary.lux
+++ b/stdlib/source/test/lux/control/parser/binary.lux
@@ -1,43 +1,44 @@
(.module:
- [lux (#- primitive)
- ["_" test (#+ Test)]
- ["." type]
- [abstract
- [equivalence (#+ Equivalence)]
- [predicate (#+ Predicate)]
- [monad (#+ do)]]
- [control
- [pipe (#+ case>)]
- ["." try]
- ["." exception]
- ["<>" parser]]
- [data
- ["." binary]
- ["." sum]
- ["." maybe]
- ["." bit]
- ["." name]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]
- ["." format #_
- ["#" binary]]
- [collection
- ["." list]
- ["." row]
- ["." set]]]
- [macro
- ["." code]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["." i64]
- ["." int]
- ["." rev]
- ["." frac]]]]
- [\\
+ [library
+ [lux (#- primitive)
+ ["_" test (#+ Test)]
+ ["." type]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [predicate (#+ Predicate)]
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]
+ ["." exception]
+ ["<>" parser]]
+ [data
+ ["." binary]
+ ["." sum]
+ ["." maybe]
+ ["." bit]
+ ["." name]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ ["." format #_
+ ["#" binary]]
+ [collection
+ ["." list]
+ ["." row]
+ ["." set]]]
+ [macro
+ ["." code]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["." i64]
+ ["." int]
+ ["." rev]
+ ["." frac]]]]]
+ [\\library
["." /]])
(template: (!expect <expectation> <computation>)
diff --git a/stdlib/source/test/lux/control/parser/cli.lux b/stdlib/source/test/lux/control/parser/cli.lux
index 97ffd5e0e..fbf0a810f 100644
--- a/stdlib/source/test/lux/control/parser/cli.lux
+++ b/stdlib/source/test/lux/control/parser/cli.lux
@@ -1,20 +1,21 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["<>" parser]]
- [data
- ["." text ("#\." equivalence)]
- [collection
- ["." list]]]
- [math
- ["." random]
- [number
- ["n" nat ("#\." decimal)]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["<>" parser]]
+ [data
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." list]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat ("#\." decimal)]]]]]
+ [\\library
["." /]])
(template: (!expect <pattern> <value>)
diff --git a/stdlib/source/test/lux/control/parser/code.lux b/stdlib/source/test/lux/control/parser/code.lux
index 987f0ad9d..7bb5d1ddb 100644
--- a/stdlib/source/test/lux/control/parser/code.lux
+++ b/stdlib/source/test/lux/control/parser/code.lux
@@ -1,28 +1,29 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." function]
- ["." try]
- ["<>" parser]]
- [data
- ["." bit]
- ["." name]
- ["." text]
- [collection
- ["." list]]]
- [macro
- ["." code]]
- [math
- ["." random (#+ Random)]
- [number
- ["." nat]
- ["." int]
- ["." rev]
- ["." frac]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try]
+ ["<>" parser]]
+ [data
+ ["." bit]
+ ["." name]
+ ["." text]
+ [collection
+ ["." list]]]
+ [macro
+ ["." code]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["." nat]
+ ["." int]
+ ["." rev]
+ ["." frac]]]]]
+ [\\library
["." /]])
(template: (!expect <pattern> <value>)
diff --git a/stdlib/source/test/lux/control/parser/environment.lux b/stdlib/source/test/lux/control/parser/environment.lux
index 48b7bca54..68f98ea13 100644
--- a/stdlib/source/test/lux/control/parser/environment.lux
+++ b/stdlib/source/test/lux/control/parser/environment.lux
@@ -1,20 +1,21 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["." exception]]
- [data
- ["." text ("#\." equivalence)]
- [collection
- ["." dictionary]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception]]
+ [data
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." dictionary]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /
["/#" // ("#\." monad)]]])
diff --git a/stdlib/source/test/lux/control/parser/json.lux b/stdlib/source/test/lux/control/parser/json.lux
index 0a4adcc83..6b6511e15 100644
--- a/stdlib/source/test/lux/control/parser/json.lux
+++ b/stdlib/source/test/lux/control/parser/json.lux
@@ -1,30 +1,31 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- [pipe (#+ case>)]
- ["." try]
- ["." exception]
- ["<>" parser]]
- [data
- ["." maybe]
- ["." bit]
- ["." text]
- [collection
- ["." list ("#\." functor)]
- ["." set]
- ["." dictionary]
- ["." row (#+ row) ("#\." functor)]]
- [format
- ["." json]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["." frac]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]
+ ["." exception]
+ ["<>" parser]]
+ [data
+ ["." maybe]
+ ["." bit]
+ ["." text]
+ [collection
+ ["." list ("#\." functor)]
+ ["." set]
+ ["." dictionary]
+ ["." row (#+ row) ("#\." functor)]]
+ [format
+ ["." json]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["." frac]]]]]
+ [\\library
["." /]])
(template: (!expect <pattern> <value>)
diff --git a/stdlib/source/test/lux/control/parser/synthesis.lux b/stdlib/source/test/lux/control/parser/synthesis.lux
index 064891f2c..83211a95f 100644
--- a/stdlib/source/test/lux/control/parser/synthesis.lux
+++ b/stdlib/source/test/lux/control/parser/synthesis.lux
@@ -1,34 +1,35 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- ["." monad (#+ do)]]
- [control
- [pipe (#+ case>)]
- ["<>" parser]
- ["." try]
- ["." exception]]
- [data
- ["." bit]
- ["." name]
- ["." text]
- [collection
- ["." list ("#\." functor)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["." i64]
- ["." frac]]]
- [tool
- [compiler
- [reference (#+)
- ["." variable (#+ Variable)]]
- [language
- [lux
- [analysis (#+ Environment)]
- ["." synthesis (#+ Synthesis)]]]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["<>" parser]
+ ["." try]
+ ["." exception]]
+ [data
+ ["." bit]
+ ["." name]
+ ["." text]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["." i64]
+ ["." frac]]]
+ [tool
+ [compiler
+ [reference (#+)
+ ["." variable (#+ Variable)]]
+ [language
+ [lux
+ [analysis (#+ Environment)]
+ ["." synthesis (#+ Synthesis)]]]]]]]
+ [\\library
["." /]])
(template: (!expect <pattern> <value>)
diff --git a/stdlib/source/test/lux/control/parser/text.lux b/stdlib/source/test/lux/control/parser/text.lux
index 0ccad4208..d00a21d90 100644
--- a/stdlib/source/test/lux/control/parser/text.lux
+++ b/stdlib/source/test/lux/control/parser/text.lux
@@ -1,31 +1,32 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ Exception)]
- ["." function]]
- [data
- ["." maybe]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]
- ["." unicode #_
- ["#" set]
- ["#/." block]]]
- [collection
- ["." set]
- ["." list ("#\." functor)]
- [tree
- ["." finger]]]]
- [math
- ["." random]
- [number (#+ hex)
- ["n" nat]]]
- [macro
- ["." code]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ Exception)]
+ ["." function]]
+ [data
+ ["." maybe]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]
+ ["." unicode #_
+ ["#" set]
+ ["#/." block]]]
+ [collection
+ ["." set]
+ ["." list ("#\." functor)]
+ [tree
+ ["." finger]]]]
+ [math
+ ["." random]
+ [number (#+ hex)
+ ["n" nat]]]
+ [macro
+ ["." code]]]]
+ [\\library
["." /
["<>" //
["<c>" code]]]])
diff --git a/stdlib/source/test/lux/control/parser/tree.lux b/stdlib/source/test/lux/control/parser/tree.lux
index f4daaf751..62c4ab04e 100644
--- a/stdlib/source/test/lux/control/parser/tree.lux
+++ b/stdlib/source/test/lux/control/parser/tree.lux
@@ -1,20 +1,21 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["." exception]]
- [data
- [collection
- ["." tree
- ["." zipper]]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception]]
+ [data
+ [collection
+ ["." tree
+ ["." zipper]]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /
["/#" //]]])
diff --git a/stdlib/source/test/lux/control/parser/type.lux b/stdlib/source/test/lux/control/parser/type.lux
index d2a9bce32..7a8feca69 100644
--- a/stdlib/source/test/lux/control/parser/type.lux
+++ b/stdlib/source/test/lux/control/parser/type.lux
@@ -1,21 +1,22 @@
(.module:
- [lux (#- primitive)
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["." exception]]
- [data
- ["." name ("#\." equivalence)]
- [collection
- ["." list]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]
- ["." type ("#\." equivalence)]]
- [\\
+ [library
+ [lux (#- primitive)
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception]]
+ [data
+ ["." name ("#\." equivalence)]
+ [collection
+ ["." list]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]
+ ["." type ("#\." equivalence)]]]
+ [\\library
["." /
["/#" //]]])
diff --git a/stdlib/source/test/lux/control/parser/xml.lux b/stdlib/source/test/lux/control/parser/xml.lux
index 435e3f4d3..aab371fa9 100644
--- a/stdlib/source/test/lux/control/parser/xml.lux
+++ b/stdlib/source/test/lux/control/parser/xml.lux
@@ -1,27 +1,28 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["." type ("#\." equivalence)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["." exception]]
- [data
- ["." text ("#\." equivalence)]
- ["." name ("#\." equivalence)]
- [format
- ["." xml]]
- [collection
- ["." dictionary]
- ["." list]]]
- [macro
- ["." template]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." type ("#\." equivalence)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception]]
+ [data
+ ["." text ("#\." equivalence)]
+ ["." name ("#\." equivalence)]
+ [format
+ ["." xml]]
+ [collection
+ ["." dictionary]
+ ["." list]]]
+ [macro
+ ["." template]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /
["/#" // ("#\." monad)]]])
diff --git a/stdlib/source/test/lux/control/pipe.lux b/stdlib/source/test/lux/control/pipe.lux
index 61d7aab25..e38fafba4 100644
--- a/stdlib/source/test/lux/control/pipe.lux
+++ b/stdlib/source/test/lux/control/pipe.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["." debug]
- [abstract
- [monad (#+ do)]]
- [data
- ["." identity]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." debug]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." identity]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/control/reader.lux b/stdlib/source/test/lux/control/reader.lux
index 9302a014c..b0edaa401 100644
--- a/stdlib/source/test/lux/control/reader.lux
+++ b/stdlib/source/test/lux/control/reader.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Reader)
[//
["." io (#+ IO)]]]])
diff --git a/stdlib/source/test/lux/control/region.lux b/stdlib/source/test/lux/control/region.lux
index 5e21b3a37..2d2c5e1f9 100644
--- a/stdlib/source/test/lux/control/region.lux
+++ b/stdlib/source/test/lux/control/region.lux
@@ -1,27 +1,28 @@
(.module:
- [lux #*
- [type (#+ :share)]
- ["_" test (#+ Test)]
- [abstract
- [equivalence (#+ Equivalence)]
- [functor (#+ Functor)]
- [apply (#+ Apply)]
- ["." monad (#+ Monad do)]
- ["." enum]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]]]
- [control
- ["." try (#+ Try)]]
- [data
- [collection
- ["." list]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ [type (#+ :share)]
+ ["_" test (#+ Test)]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ ["." monad (#+ Monad do)]
+ ["." enum]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ [collection
+ ["." list]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Region)
[//
["." thread (#+ Thread)]
diff --git a/stdlib/source/test/lux/control/remember.lux b/stdlib/source/test/lux/control/remember.lux
index 17c59b8a3..a96f993c9 100644
--- a/stdlib/source/test/lux/control/remember.lux
+++ b/stdlib/source/test/lux/control/remember.lux
@@ -1,30 +1,31 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["." meta]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." io]
- ["." try (#+ Try)]
- ["." exception]
- [parser
- ["<c>" code]]]
- [data
- ["." product]
- ["." text
- ["%" format (#+ format)]]]
- [math
- [number (#+ hex)]
- ["." random (#+ Random) ("#\." monad)]]
- [time
- ["." date (#+ Date)]
- ["." instant]
- ["." duration]]
- ["." macro
- ["." code]
- ["." syntax (#+ syntax:)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." meta]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." io]
+ ["." try (#+ Try)]
+ ["." exception]
+ [parser
+ ["<c>" code]]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]]
+ [math
+ [number (#+ hex)]
+ ["." random (#+ Random) ("#\." monad)]]
+ [time
+ ["." date (#+ Date)]
+ ["." instant]
+ ["." duration]]
+ ["." macro
+ ["." code]
+ ["." syntax (#+ syntax:)]]]]
+ [\\library
["." /]])
(def: deadline (Random Date) random.date)
diff --git a/stdlib/source/test/lux/control/security/capability.lux b/stdlib/source/test/lux/control/security/capability.lux
index ef3d64d05..2798c21b2 100644
--- a/stdlib/source/test/lux/control/security/capability.lux
+++ b/stdlib/source/test/lux/control/security/capability.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io (#+ IO)]
- [concurrency
- ["." promise]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io (#+ IO)]
+ [concurrency
+ ["." promise]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(/.capability: (Can-Shift a)
diff --git a/stdlib/source/test/lux/control/security/policy.lux b/stdlib/source/test/lux/control/security/policy.lux
index 0cf9729dd..87beb9a3a 100644
--- a/stdlib/source/test/lux/control/security/policy.lux
+++ b/stdlib/source/test/lux/control/security/policy.lux
@@ -1,20 +1,21 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [hash (#+ Hash)]
- [monad (#+ do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]]]
- [data
- ["." text ("#\." equivalence)]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [hash (#+ Hash)]
+ [monad (#+ do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]]
+ [data
+ ["." text ("#\." equivalence)]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Context Privacy Can_Conceal Can_Reveal Privilege Private)]])
(def: (injection can_conceal)
diff --git a/stdlib/source/test/lux/control/state.lux b/stdlib/source/test/lux/control/state.lux
index 6d6626522..2c1541dbf 100644
--- a/stdlib/source/test/lux/control/state.lux
+++ b/stdlib/source/test/lux/control/state.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]]]
- [control
- [pipe (#+ let>)]
- ["." io]]
- [data
- ["." product]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]]
+ [control
+ [pipe (#+ let>)]
+ ["." io]]
+ [data
+ ["." product]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ State)]])
(def: (with-conditions [state output] computation)
diff --git a/stdlib/source/test/lux/control/thread.lux b/stdlib/source/test/lux/control/thread.lux
index d2369a0bc..f3ad379dd 100644
--- a/stdlib/source/test/lux/control/thread.lux
+++ b/stdlib/source/test/lux/control/thread.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Thread)
[//
["." io]]]])
diff --git a/stdlib/source/test/lux/control/try.lux b/stdlib/source/test/lux/control/try.lux
index c2b00360f..9f131cffd 100644
--- a/stdlib/source/test/lux/control/try.lux
+++ b/stdlib/source/test/lux/control/try.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]
- ["$." equivalence]]]
- [control
- pipe
- ["." io]]
- [data
- ["." text ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]
+ ["$." equivalence]]]
+ [control
+ pipe
+ ["." io]]
+ [data
+ ["." text ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Try)]])
(def: injection
diff --git a/stdlib/source/test/lux/control/writer.lux b/stdlib/source/test/lux/control/writer.lux
index 1c007d9b1..8d440ddd0 100644
--- a/stdlib/source/test/lux/control/writer.lux
+++ b/stdlib/source/test/lux/control/writer.lux
@@ -1,24 +1,25 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [equivalence (#+ Equivalence)]
- [monoid (#+ Monoid)]
- [monad (#+ do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]]]
- [control
- ["." io]]
- [data
- ["." product]
- ["." text ("#\." equivalence)]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monoid (#+ Monoid)]
+ [monad (#+ do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]]
+ [control
+ ["." io]]
+ [data
+ ["." product]
+ ["." text ("#\." equivalence)]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Writer)]])
(def: (injection monoid value)
diff --git a/stdlib/source/test/lux/data.lux b/stdlib/source/test/lux/data.lux
index 33f0d963b..95576f815 100644
--- a/stdlib/source/test/lux/data.lux
+++ b/stdlib/source/test/lux/data.lux
@@ -1,10 +1,11 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [math
- ["." random]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [math
+ ["." random]]]]
["." / #_
["#." binary]
["#." bit]
@@ -32,6 +33,7 @@
body)))
(def: format
+ Test
($_ _.and
/format/binary.test
/format/json.test
@@ -39,27 +41,36 @@
/format/xml.test
))
+(def: test/0
+ Test
+ ($_ _.and
+ /binary.test
+ /bit.test
+ /color.test
+ /color/named.test))
+
+(def: test/1
+ Test
+ ($_ _.and
+ /identity.test
+ /lazy.test
+ /maybe.test
+ /name.test))
+
+(def: test/2
+ Test
+ ($_ _.and
+ /product.test
+ /sum.test
+ /text.test))
+
(def: #export test
Test
## TODO: Inline ASAP
- (let [test0 ($_ _.and
- /binary.test
- /bit.test
- /color.test
- /color/named.test
- /identity.test)
- test1 ($_ _.and
- /lazy.test
- /maybe.test
- /name.test
- /product.test)
- test2 ($_ _.and
- /sum.test
- /text.test
- ..format
- /collection.test)]
- ($_ _.and
- (!bundle test0)
- (!bundle test1)
- (!bundle test2)
- )))
+ ($_ _.and
+ (!bundle test/0)
+ (!bundle test/1)
+ (!bundle test/2)
+ (!bundle ..format)
+ (!bundle /collection.test)
+ ))
diff --git a/stdlib/source/test/lux/data/binary.lux b/stdlib/source/test/lux/data/binary.lux
index ba5e36662..347d9080b 100644
--- a/stdlib/source/test/lux/data/binary.lux
+++ b/stdlib/source/test/lux/data/binary.lux
@@ -1,24 +1,25 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- ["." monad (#+ do)]
- ["." enum]
- [\spec
- ["$." equivalence]
- ["$." monoid]]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ Exception)]]
- [data
- [collection
- ["." list]]]
- [math
- ["." random (#+ Random)]
- [number
- ["." i64]
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ ["." monad (#+ do)]
+ ["." enum]
+ [\\spec
+ ["$." equivalence]
+ ["$." monoid]]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ Exception)]]
+ [data
+ [collection
+ ["." list]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["." i64]
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Binary)]])
(def: (succeed result)
diff --git a/stdlib/source/test/lux/data/bit.lux b/stdlib/source/test/lux/data/bit.lux
index 341da9beb..499b32779 100644
--- a/stdlib/source/test/lux/data/bit.lux
+++ b/stdlib/source/test/lux/data/bit.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [math
- ["." random]]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." hash]
- ["$." monoid]
- ["$." codec]]]
- [control
- ["." function]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]
+ ["$." monoid]
+ ["$." codec]]]
+ [control
+ ["." function]]
+ [math
+ ["." random]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/data/collection.lux b/stdlib/source/test/lux/data/collection.lux
index bcbda46b9..b30d8181f 100644
--- a/stdlib/source/test/lux/data/collection.lux
+++ b/stdlib/source/test/lux/data/collection.lux
@@ -1,6 +1,7 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]]]
["." / #_
["#." array]
["#." bits]
diff --git a/stdlib/source/test/lux/data/collection/array.lux b/stdlib/source/test/lux/data/collection/array.lux
index e99478ee8..20d554bea 100644
--- a/stdlib/source/test/lux/data/collection/array.lux
+++ b/stdlib/source/test/lux/data/collection/array.lux
@@ -1,24 +1,25 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." monoid]
- ["$." fold]
- ["$." functor (#+ Injection)]]]
- [data
- ["." bit]
- ["." maybe]
- [collection
- ["." list]
- ["." set]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." monoid]
+ ["$." fold]
+ ["$." functor (#+ Injection)]]]
+ [data
+ ["." bit]
+ ["." maybe]
+ [collection
+ ["." list]
+ ["." set]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Array)]])
(def: injection
diff --git a/stdlib/source/test/lux/data/collection/bits.lux b/stdlib/source/test/lux/data/collection/bits.lux
index 258c84107..f505b0fce 100644
--- a/stdlib/source/test/lux/data/collection/bits.lux
+++ b/stdlib/source/test/lux/data/collection/bits.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- ["." predicate]
- [\spec
- ["$." equivalence]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ ["." predicate]
+ [\\spec
+ ["$." equivalence]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Bits)]])
(def: (size min max)
diff --git a/stdlib/source/test/lux/data/collection/dictionary.lux b/stdlib/source/test/lux/data/collection/dictionary.lux
index d68b421d9..c28ff6f51 100644
--- a/stdlib/source/test/lux/data/collection/dictionary.lux
+++ b/stdlib/source/test/lux/data/collection/dictionary.lux
@@ -1,25 +1,26 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [hash (#+ Hash)]
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." functor (#+ Injection)]]]
- [control
- ["." try]
- ["." exception]]
- [data
- ["." product]
- ["." maybe]
- [collection
- ["." list ("#\." functor)]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [hash (#+ Hash)]
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." functor (#+ Injection)]]]
+ [control
+ ["." try]
+ ["." exception]]
+ [data
+ ["." product]
+ ["." maybe]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: injection
diff --git a/stdlib/source/test/lux/data/collection/dictionary/ordered.lux b/stdlib/source/test/lux/data/collection/dictionary/ordered.lux
index a004e5c97..66d8098d3 100644
--- a/stdlib/source/test/lux/data/collection/dictionary/ordered.lux
+++ b/stdlib/source/test/lux/data/collection/dictionary/ordered.lux
@@ -1,24 +1,25 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [equivalence (#+ Equivalence)]
- [order (#+ Order)]
- [\spec
- ["$." equivalence]]]
- [data
- ["." product]
- ["." bit ("#\." equivalence)]
- ["." maybe ("#\." monad)]
- [collection
- ["." set]
- ["." list ("#\." functor)]]]
- [math
- ["." random (#+ Random) ("#\." monad)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]
+ [\\spec
+ ["$." equivalence]]]
+ [data
+ ["." product]
+ ["." bit ("#\." equivalence)]
+ ["." maybe ("#\." monad)]
+ [collection
+ ["." set]
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: #export (dictionary order gen_key gen_value size)
diff --git a/stdlib/source/test/lux/data/collection/dictionary/plist.lux b/stdlib/source/test/lux/data/collection/dictionary/plist.lux
index 4811b1162..3d24c3943 100644
--- a/stdlib/source/test/lux/data/collection/dictionary/plist.lux
+++ b/stdlib/source/test/lux/data/collection/dictionary/plist.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [data
- ["." bit ("#\." equivalence)]
- ["." maybe ("#\." monad)]
- ["." text]
- [collection
- ["." set]
- ["." list]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [data
+ ["." bit ("#\." equivalence)]
+ ["." maybe ("#\." monad)]
+ ["." text]
+ [collection
+ ["." set]
+ ["." list]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: #export (random size gen_key gen_value)
diff --git a/stdlib/source/test/lux/data/collection/list.lux b/stdlib/source/test/lux/data/collection/list.lux
index 625ce2bad..c46ccb681 100644
--- a/stdlib/source/test/lux/data/collection/list.lux
+++ b/stdlib/source/test/lux/data/collection/list.lux
@@ -1,34 +1,35 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- ["." enum]
- [\spec
- ["$." equivalence]
- ["$." hash]
- ["$." monoid]
- ["$." fold]
- ["$." functor]
- ["$." apply]
- ["$." monad]]]
- [control
- pipe
- ["." io]
- ["." function]]
- [data
- ["." bit]
- ["." product]
- ["." maybe]
- ["." text ("#\." equivalence)]
- [collection
- ["." set]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["." int]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ ["." enum]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]
+ ["$." monoid]
+ ["$." fold]
+ ["$." functor]
+ ["$." apply]
+ ["$." monad]]]
+ [control
+ pipe
+ ["." io]
+ ["." function]]
+ [data
+ ["." bit]
+ ["." product]
+ ["." maybe]
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." set]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["." int]]]]]
+ [\\library
["." / ("#\." monad)]])
(def: bounded_size
diff --git a/stdlib/source/test/lux/data/collection/queue.lux b/stdlib/source/test/lux/data/collection/queue.lux
index 8ddd0533a..93dd8828f 100644
--- a/stdlib/source/test/lux/data/collection/queue.lux
+++ b/stdlib/source/test/lux/data/collection/queue.lux
@@ -1,21 +1,22 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." functor (#+ Injection)]]]
- [data
- ["." bit ("#\." equivalence)]
- [collection
- ["." set]
- ["." list ("#\." monoid)]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." functor (#+ Injection)]]]
+ [data
+ ["." bit ("#\." equivalence)]
+ [collection
+ ["." set]
+ ["." list ("#\." monoid)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: injection
diff --git a/stdlib/source/test/lux/data/collection/queue/priority.lux b/stdlib/source/test/lux/data/collection/queue/priority.lux
index 653e0ca52..55d643aa8 100644
--- a/stdlib/source/test/lux/data/collection/queue/priority.lux
+++ b/stdlib/source/test/lux/data/collection/queue/priority.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- ["." monad (#+ do)]]
- [data
- ["." maybe ("#\." functor)]
- ["." bit ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ ["." monad (#+ do)]]
+ [data
+ ["." maybe ("#\." functor)]
+ ["." bit ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Queue)]])
(def: #export (random size)
diff --git a/stdlib/source/test/lux/data/collection/row.lux b/stdlib/source/test/lux/data/collection/row.lux
index e523fd656..6f858efe6 100644
--- a/stdlib/source/test/lux/data/collection/row.lux
+++ b/stdlib/source/test/lux/data/collection/row.lux
@@ -1,28 +1,29 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." monoid]
- ["$." fold]
- ["$." functor (#+ Injection)]
- ["$." apply]
- ["$." monad]]]
- [control
- ["." try (#+ Try)]
- ["." exception]]
- [data
- ["." bit ("#\." equivalence)]
- [collection
- ["." list ("#\." fold)]
- ["." set]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." monoid]
+ ["$." fold]
+ ["$." functor (#+ Injection)]
+ ["$." apply]
+ ["$." monad]]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception]]
+ [data
+ ["." bit ("#\." equivalence)]
+ [collection
+ ["." list ("#\." fold)]
+ ["." set]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / ("#\." monad)]])
(def: signatures
diff --git a/stdlib/source/test/lux/data/collection/sequence.lux b/stdlib/source/test/lux/data/collection/sequence.lux
index 1d5e111af..bbac12c34 100644
--- a/stdlib/source/test/lux/data/collection/sequence.lux
+++ b/stdlib/source/test/lux/data/collection/sequence.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [equivalence (#+ Equivalence)]
- ["." enum]
- [\spec
- ["$." functor]
- ["$." comonad]]]
- [data
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [equivalence (#+ Equivalence)]
+ ["." enum]
+ [\\spec
+ ["$." functor]
+ ["$." comonad]]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(implementation: (equivalence super)
diff --git a/stdlib/source/test/lux/data/collection/set.lux b/stdlib/source/test/lux/data/collection/set.lux
index f577ce59f..e543dce57 100644
--- a/stdlib/source/test/lux/data/collection/set.lux
+++ b/stdlib/source/test/lux/data/collection/set.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [hash (#+ Hash)]
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." hash]
- ["$." monoid]]]
- [data
- ["." bit ("#\." equivalence)]
- [collection
- ["." list]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [hash (#+ Hash)]
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]
+ ["$." monoid]]]
+ [data
+ ["." bit ("#\." equivalence)]
+ [collection
+ ["." list]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / ("\." equivalence)]])
(def: gen_nat
diff --git a/stdlib/source/test/lux/data/collection/set/multi.lux b/stdlib/source/test/lux/data/collection/set/multi.lux
index 4e1cd4f48..a6f95a3f0 100644
--- a/stdlib/source/test/lux/data/collection/set/multi.lux
+++ b/stdlib/source/test/lux/data/collection/set/multi.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [hash (#+ Hash)]
- [monad (#+ do)]
- ["." predicate]
- [\spec
- ["$." equivalence]
- ["$." hash]]]
- [data
- ["." bit ("#\." equivalence)]
- [collection
- ["." set]
- ["." list ("#\." fold)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [hash (#+ Hash)]
+ [monad (#+ do)]
+ ["." predicate]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]]]
+ [data
+ ["." bit ("#\." equivalence)]
+ [collection
+ ["." set]
+ ["." list ("#\." fold)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: count
diff --git a/stdlib/source/test/lux/data/collection/set/ordered.lux b/stdlib/source/test/lux/data/collection/set/ordered.lux
index 385bc3c4a..0a6b441b7 100644
--- a/stdlib/source/test/lux/data/collection/set/ordered.lux
+++ b/stdlib/source/test/lux/data/collection/set/ordered.lux
@@ -1,20 +1,21 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [order (#+ Order)]
- [\spec
- ["$." equivalence]]]
- [data
- ["." bit ("#\." equivalence)]
- [collection
- ["." list]]]
- [math
- ["." random (#+ Random) ("#\." monad)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [order (#+ Order)]
+ [\\spec
+ ["$." equivalence]]]
+ [data
+ ["." bit ("#\." equivalence)]
+ [collection
+ ["." list]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Set)
["." //]]])
diff --git a/stdlib/source/test/lux/data/collection/stack.lux b/stdlib/source/test/lux/data/collection/stack.lux
index 317911b6b..e671b3cee 100644
--- a/stdlib/source/test/lux/data/collection/stack.lux
+++ b/stdlib/source/test/lux/data/collection/stack.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." functor (#+ Injection)]]]
- [data
- ["." maybe]
- ["." bit ("#\." equivalence)]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." functor (#+ Injection)]]]
+ [data
+ ["." maybe]
+ ["." bit ("#\." equivalence)]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: (injection value)
diff --git a/stdlib/source/test/lux/data/collection/tree.lux b/stdlib/source/test/lux/data/collection/tree.lux
index 91817180d..ed27499c3 100644
--- a/stdlib/source/test/lux/data/collection/tree.lux
+++ b/stdlib/source/test/lux/data/collection/tree.lux
@@ -1,21 +1,22 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- ["." monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." fold]
- ["$." functor]]]
- [data
- ["." product]
- [collection
- ["." list ("#\." functor fold)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ ["." monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." fold]
+ ["$." functor]]]
+ [data
+ ["." product]
+ [collection
+ ["." list ("#\." functor fold)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Tree)]])
(def: #export (tree gen-value)
diff --git a/stdlib/source/test/lux/data/collection/tree/finger.lux b/stdlib/source/test/lux/data/collection/tree/finger.lux
index 2c4c83466..c34449027 100644
--- a/stdlib/source/test/lux/data/collection/tree/finger.lux
+++ b/stdlib/source/test/lux/data/collection/tree/finger.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- ["." maybe ("#\." functor)]
- ["." text ("#\." equivalence monoid)]
- [collection
- ["." list ("#\." fold)]]]
- [math
- ["." random]
- [number
- ["n" nat]]]
- [type (#+ :by_example)]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." maybe ("#\." functor)]
+ ["." text ("#\." equivalence monoid)]
+ [collection
+ ["." list ("#\." fold)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]
+ [type (#+ :by_example)]]]
+ [\\library
["." /]])
(def: builder
diff --git a/stdlib/source/test/lux/data/collection/tree/zipper.lux b/stdlib/source/test/lux/data/collection/tree/zipper.lux
index 6a7832736..b45e96213 100644
--- a/stdlib/source/test/lux/data/collection/tree/zipper.lux
+++ b/stdlib/source/test/lux/data/collection/tree/zipper.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." functor]
- ["$." comonad]]]
- [control
- pipe]
- [data
- ["." product]
- ["." maybe ("#\." functor)]
- ["." text]
- [collection
- ["." list]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." functor]
+ ["$." comonad]]]
+ [control
+ pipe]
+ [data
+ ["." product]
+ ["." maybe ("#\." functor)]
+ ["." text]
+ [collection
+ ["." list]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
["." //]
- [\\
+ [\\library
["." / (#+ Zipper)
["tree" //]]])
diff --git a/stdlib/source/test/lux/data/color.lux b/stdlib/source/test/lux/data/color.lux
index 2877af081..b218a15ed 100644
--- a/stdlib/source/test/lux/data/color.lux
+++ b/stdlib/source/test/lux/data/color.lux
@@ -1,25 +1,26 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." hash]
- ["$." monoid]]]
- [data
- [collection
- ["." list]]]
- [macro
- ["." template]]
- ["." math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["." int]
- ["f" frac]
- ["r" rev]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]
+ ["$." monoid]]]
+ [data
+ [collection
+ ["." list]]]
+ [macro
+ ["." template]]
+ ["." math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["." int]
+ ["f" frac]
+ ["r" rev]]]]]
+ [\\library
["." /]])
(def: #export random
diff --git a/stdlib/source/test/lux/data/color/named.lux b/stdlib/source/test/lux/data/color/named.lux
index bddd74593..9e027d74d 100644
--- a/stdlib/source/test/lux/data/color/named.lux
+++ b/stdlib/source/test/lux/data/color/named.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- [collection
- ["." list]
- ["." set]]]
- [macro
- ["." template]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ [collection
+ ["." list]
+ ["." set]]]
+ [macro
+ ["." template]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /
["/#" //]]])
diff --git a/stdlib/source/test/lux/data/format/binary.lux b/stdlib/source/test/lux/data/format/binary.lux
index 8912ae845..3457833ae 100644
--- a/stdlib/source/test/lux/data/format/binary.lux
+++ b/stdlib/source/test/lux/data/format/binary.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]
- [\spec
- ["$." monoid]]]
- [data
- ["." binary ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]
+ [\\spec
+ ["$." monoid]]]
+ [data
+ ["." binary ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /]])
(implementation: equivalence
diff --git a/stdlib/source/test/lux/data/format/json.lux b/stdlib/source/test/lux/data/format/json.lux
index 5e425db79..8fa74ed9e 100644
--- a/stdlib/source/test/lux/data/format/json.lux
+++ b/stdlib/source/test/lux/data/format/json.lux
@@ -1,33 +1,34 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["." meta]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." codec]]]
- [control
- ["." try ("#\." functor)]]
- [data
- ["." product]
- ["." bit]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." row]
- ["." dictionary]
- ["." set]
- ["." list ("#\." functor)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["." frac]]]
- ["." macro
- ["." syntax (#+ syntax:)]
- ["." code]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." meta]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." codec]]]
+ [control
+ ["." try ("#\." functor)]]
+ [data
+ ["." product]
+ ["." bit]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." row]
+ ["." dictionary]
+ ["." set]
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["." frac]]]
+ ["." macro
+ ["." syntax (#+ syntax:)]
+ ["." code]]]]
+ [\\library
["." / (#+ JSON) ("\." equivalence)]])
(def: #export random
diff --git a/stdlib/source/test/lux/data/format/tar.lux b/stdlib/source/test/lux/data/format/tar.lux
index 540eb2af1..8b0655555 100644
--- a/stdlib/source/test/lux/data/format/tar.lux
+++ b/stdlib/source/test/lux/data/format/tar.lux
@@ -1,38 +1,39 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["." exception]
- ["<>" parser
- ["<b>" binary]]]
- [data
- ["." product]
- ["." maybe]
- ["." binary ("#\." equivalence monoid)]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]
- ["." unicode #_
- ["#" set]
- ["#/." block]]]
- [collection
- ["." row]
- ["." list ("#\." fold)]]
- ["." format #_
- ["#" binary]]]
- [time
- ["." instant (#+ Instant)]
- ["." duration]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["i" int]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception]
+ ["<>" parser
+ ["<b>" binary]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." binary ("#\." equivalence monoid)]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]
+ ["." unicode #_
+ ["#" set]
+ ["#/." block]]]
+ [collection
+ ["." row]
+ ["." list ("#\." fold)]]
+ ["." format #_
+ ["#" binary]]]
+ [time
+ ["." instant (#+ Instant)]
+ ["." duration]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["i" int]]]]]
+ [\\library
["." /]])
(def: path
diff --git a/stdlib/source/test/lux/data/format/xml.lux b/stdlib/source/test/lux/data/format/xml.lux
index 95a06127f..5e4585d7f 100644
--- a/stdlib/source/test/lux/data/format/xml.lux
+++ b/stdlib/source/test/lux/data/format/xml.lux
@@ -1,29 +1,30 @@
(.module:
- [lux (#- char)
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ Monad do)]
- [\spec
- ["$." equivalence]
- ["$." codec]]]
- [control
- pipe
- ["." try]
- ["p" parser
- ["</>" xml]]]
- [data
- ["." name]
- ["." maybe]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." dictionary]
- ["." list ("#\." functor)]]]
- [math
- ["." random (#+ Random) ("#\." monad)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux (#- char)
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ Monad do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." codec]]]
+ [control
+ pipe
+ ["." try]
+ ["p" parser
+ ["</>" xml]]]
+ [data
+ ["." name]
+ ["." maybe]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary]
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ XML)]])
(def: char_range
diff --git a/stdlib/source/test/lux/data/identity.lux b/stdlib/source/test/lux/data/identity.lux
index 918eb10f6..c1359fd42 100644
--- a/stdlib/source/test/lux/data/identity.lux
+++ b/stdlib/source/test/lux/data/identity.lux
@@ -1,14 +1,15 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]
- ["$." comonad]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]
+ ["$." comonad]]]]]
+ [\\library
["." / (#+ Identity)]])
(def: injection
diff --git a/stdlib/source/test/lux/data/lazy.lux b/stdlib/source/test/lux/data/lazy.lux
index 87d77ca68..9972de30d 100644
--- a/stdlib/source/test/lux/data/lazy.lux
+++ b/stdlib/source/test/lux/data/lazy.lux
@@ -1,20 +1,21 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]
- ["$." equivalence]]]
- [data
- ["." product]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]
+ ["$." equivalence]]]
+ [data
+ ["." product]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / (#+ Lazy)]])
(def: injection
diff --git a/stdlib/source/test/lux/data/maybe.lux b/stdlib/source/test/lux/data/maybe.lux
index eea0e3f32..51388c7a2 100644
--- a/stdlib/source/test/lux/data/maybe.lux
+++ b/stdlib/source/test/lux/data/maybe.lux
@@ -1,27 +1,28 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." hash]
- ["$." monoid]
- ["$." functor]
- ["$." apply]
- ["$." monad]]]
- [control
- ["." io ("#\." monad)]
- pipe]
- [data
- ["." text]
- [collection
- ["." list]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]
+ ["$." monoid]
+ ["$." functor]
+ ["$." apply]
+ ["$." monad]]]
+ [control
+ ["." io ("#\." monad)]
+ pipe]
+ [data
+ ["." text]
+ [collection
+ ["." list]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / ("#\." monoid monad)]])
(def: #export test
diff --git a/stdlib/source/test/lux/data/name.lux b/stdlib/source/test/lux/data/name.lux
index 8c2722466..958d236bf 100644
--- a/stdlib/source/test/lux/data/name.lux
+++ b/stdlib/source/test/lux/data/name.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." hash]
- ["$." order]
- ["$." codec]]]
- [control
- pipe]
- [data
- ["." text ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]
+ ["$." order]
+ ["$." codec]]]
+ [control
+ pipe]
+ [data
+ ["." text ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: #export (random module_size short_size)
@@ -57,18 +58,17 @@
(_.cover [/.module /.short]
(and (is? module1 (/.module name1))
(is? short1 (/.short name1))))
-
(_.for [.name_of]
(let [(^open "/\.") /.equivalence]
($_ _.and
(_.test "Can obtain Name from identifier."
- (and (/\= ["lux" "yolo"] (.name_of .yolo))
+ (and (/\= [.prelude_module "yolo"] (.name_of .yolo))
(/\= ["test/lux/data/name" "yolo"] (.name_of ..yolo))
(/\= ["" "yolo"] (.name_of yolo))
- (/\= ["lux/test" "yolo"] (.name_of lux/test.yolo))))
+ (/\= ["library/lux/test" "yolo"] (.name_of library/lux/test.yolo))))
(_.test "Can obtain Name from tag."
- (and (/\= ["lux" "yolo"] (.name_of #.yolo))
+ (and (/\= [.prelude_module "yolo"] (.name_of #.yolo))
(/\= ["test/lux/data/name" "yolo"] (.name_of #..yolo))
(/\= ["" "yolo"] (.name_of #yolo))
- (/\= ["lux/test" "yolo"] (.name_of #lux/test.yolo)))))))
+ (/\= ["library/lux/test" "yolo"] (.name_of #library/lux/test.yolo)))))))
)))))
diff --git a/stdlib/source/test/lux/data/product.lux b/stdlib/source/test/lux/data/product.lux
index 3e8124dde..ed086d66a 100644
--- a/stdlib/source/test/lux/data/product.lux
+++ b/stdlib/source/test/lux/data/product.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [math
- ["." random]
- [number
- ["n" nat]
- ["i" int]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]
+ ["i" int]]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/data/sum.lux b/stdlib/source/test/lux/data/sum.lux
index 6725a7a24..b06d4ea79 100644
--- a/stdlib/source/test/lux/data/sum.lux
+++ b/stdlib/source/test/lux/data/sum.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- pipe]
- [data
- ["." text]
- [collection
- ["." list ("#\." functor)]]]
- [math
- ["." random]
- [number
- ["n" nat]
- ["i" int]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ pipe]
+ [data
+ ["." text]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]
+ ["i" int]]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/data/text.lux b/stdlib/source/test/lux/data/text.lux
index 1838206a8..5b13a9076 100644
--- a/stdlib/source/test/lux/data/text.lux
+++ b/stdlib/source/test/lux/data/text.lux
@@ -1,24 +1,25 @@
(.module:
- [lux (#- char)
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." hash]
- ["$." order]
- ["$." monoid]]]
- [control
- pipe]
- [data
- ["." maybe]
- [collection
- ["." list]
- ["." set]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
+ [library
+ [lux (#- char)
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]
+ ["$." order]
+ ["$." monoid]]]
+ [control
+ pipe]
+ [data
+ ["." maybe]
+ [collection
+ ["." list]
+ ["." set]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
["." / #_
["#." buffer]
["#." encoding]
@@ -27,7 +28,7 @@
["#." escape]
["#." unicode #_
["#" set]]]
- [\\
+ [\\library
["." /]])
(def: bounded_size
diff --git a/stdlib/source/test/lux/data/text/buffer.lux b/stdlib/source/test/lux/data/text/buffer.lux
index 551d7943f..0f6e73d35 100644
--- a/stdlib/source/test/lux/data/text/buffer.lux
+++ b/stdlib/source/test/lux/data/text/buffer.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: part
diff --git a/stdlib/source/test/lux/data/text/encoding.lux b/stdlib/source/test/lux/data/text/encoding.lux
index 981fb2d22..53bc78299 100644
--- a/stdlib/source/test/lux/data/text/encoding.lux
+++ b/stdlib/source/test/lux/data/text/encoding.lux
@@ -1,25 +1,26 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." codec]]]
- [control
- ["." try]]
- [data
- ["." maybe]
- ["." text ("#\." equivalence)]
- [collection
- ["." list ("#\." fold)]
- ["." set]]]
- [macro
- ["." template]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." codec]]]
+ [control
+ ["." try]]
+ [data
+ ["." maybe]
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." list ("#\." fold)]
+ ["." set]]]
+ [macro
+ ["." template]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]]
["." / #_
["#." utf8]])
diff --git a/stdlib/source/test/lux/data/text/encoding/utf8.lux b/stdlib/source/test/lux/data/text/encoding/utf8.lux
index 7f83f745d..222e6e19b 100644
--- a/stdlib/source/test/lux/data/text/encoding/utf8.lux
+++ b/stdlib/source/test/lux/data/text/encoding/utf8.lux
@@ -1,14 +1,15 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [\spec
- ["$." codec]]]
- [data
- ["." text]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [\\spec
+ ["$." codec]]]
+ [data
+ ["." text]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/data/text/escape.lux b/stdlib/source/test/lux/data/text/escape.lux
index 7cef235cd..bee4a7560 100644
--- a/stdlib/source/test/lux/data/text/escape.lux
+++ b/stdlib/source/test/lux/data/text/escape.lux
@@ -1,30 +1,31 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["." debug]
- ["." meta]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["." exception]
- [parser
- ["<.>" code]]]
- [data
- ["." bit ("#\." equivalence)]
- ["." text (#+ Char) ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." set (#+ Set)]]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]
- ["." template]]
- [math
- ["." random (#+ Random)]
- [number (#+ hex)
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." debug]
+ ["." meta]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception]
+ [parser
+ ["<.>" code]]]
+ [data
+ ["." bit ("#\." equivalence)]
+ ["." text (#+ Char) ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." set (#+ Set)]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]
+ ["." template]]
+ [math
+ ["." random (#+ Random)]
+ [number (#+ hex)
+ ["n" nat]]]]]
+ [\\library
["." /
[//
["." unicode #_
diff --git a/stdlib/source/test/lux/data/text/format.lux b/stdlib/source/test/lux/data/text/format.lux
index 54176cda3..f35683b33 100644
--- a/stdlib/source/test/lux/data/text/format.lux
+++ b/stdlib/source/test/lux/data/text/format.lux
@@ -1,44 +1,45 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [equivalence (#+ Equivalence)]
- [functor
- [\spec
- ["$." contravariant]]]]
- [control
- ["." try]]
- [data
- ["." text ("#\." equivalence)]
- ["." bit]
- ["." name]
- [format
- ["." xml]
- ["." json]]
- [collection
- ["." list ("#\." functor)]]]
- ["." time
- ["." day]
- ["." month]
- ["." instant]
- ["." duration]
- ["." date]]
- [math
- ["." random (#+ Random) ("#\." monad)]
- ["." modulus]
- ["." modular]
- [number
- ["." nat]
- ["." int]
- ["." rev]
- ["." frac]
- ["." ratio]]]
- [macro
- ["." code]]
- [meta
- ["." location]]
- ["." type]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [equivalence (#+ Equivalence)]
+ [functor
+ [\\spec
+ ["$." contravariant]]]]
+ [control
+ ["." try]]
+ [data
+ ["." text ("#\." equivalence)]
+ ["." bit]
+ ["." name]
+ [format
+ ["." xml]
+ ["." json]]
+ [collection
+ ["." list ("#\." functor)]]]
+ ["." time
+ ["." day]
+ ["." month]
+ ["." instant]
+ ["." duration]
+ ["." date]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]
+ ["." modulus]
+ ["." modular]
+ [number
+ ["." nat]
+ ["." int]
+ ["." rev]
+ ["." frac]
+ ["." ratio]]]
+ [macro
+ ["." code]]
+ [meta
+ ["." location]]
+ ["." type]]]
["$." /// #_
[format
["#." xml]
@@ -48,7 +49,7 @@
["#." type]
[macro
["#." code]]]]
- [\\
+ [\\library
["." /]])
(implementation: (equivalence example)
@@ -68,6 +69,54 @@
(random\wrap [/.frac random.frac])
))
+(def: codec
+ Test
+ (`` ($_ _.and
+ (~~ (template [<format> <codec> <random>]
+ [(do random.monad
+ [sample <random>]
+ (_.cover [<format>]
+ (text\= (\ <codec> encode sample)
+ (<format> sample))))]
+
+ [/.bit bit.codec random.bit]
+ [/.nat nat.decimal random.nat]
+ [/.int int.decimal random.int]
+ [/.rev rev.decimal random.rev]
+ [/.frac frac.decimal random.frac]
+ [/.ratio ratio.codec random.ratio]
+ [/.name name.codec ($///name.random 5 5)]
+ [/.xml xml.codec $///xml.random]
+ [/.json json.codec $///json.random]
+ [/.day day.codec random.day]
+ [/.month month.codec random.month]
+ [/.instant instant.codec random.instant]
+ [/.duration duration.codec random.duration]
+ [/.date date.codec random.date]
+ [/.time time.codec random.time]
+
+ [/.nat/2 nat.binary random.nat]
+ [/.nat/8 nat.octal random.nat]
+ [/.nat/10 nat.decimal random.nat]
+ [/.nat/16 nat.hex random.nat]
+
+ [/.int/2 int.binary random.int]
+ [/.int/8 int.octal random.int]
+ [/.int/10 int.decimal random.int]
+ [/.int/16 int.hex random.int]
+
+ [/.rev/2 rev.binary random.rev]
+ [/.rev/8 rev.octal random.rev]
+ [/.rev/10 rev.decimal random.rev]
+ [/.rev/16 rev.hex random.rev]
+
+ [/.frac/2 frac.binary random.frac]
+ [/.frac/8 frac.octal random.frac]
+ [/.frac/10 frac.decimal random.frac]
+ [/.frac/16 frac.hex random.frac]
+ ))
+ )))
+
(def: #export test
Test
(<| (_.covering /._)
@@ -88,49 +137,7 @@
(_.cover [/.format]
(text\= (/.format left mid right)
($_ "lux text concat" left mid right))))
- (~~ (template [<format> <codec> <random>]
- [(do random.monad
- [sample <random>]
- (_.cover [<format>]
- (text\= (\ <codec> encode sample)
- (<format> sample))))]
-
- [/.bit bit.codec random.bit]
- [/.nat nat.decimal random.nat]
- [/.int int.decimal random.int]
- [/.rev rev.decimal random.rev]
- [/.frac frac.decimal random.frac]
- [/.ratio ratio.codec random.ratio]
- [/.name name.codec ($///name.random 5 5)]
- [/.xml xml.codec $///xml.random]
- [/.json json.codec $///json.random]
- [/.day day.codec random.day]
- [/.month month.codec random.month]
- [/.instant instant.codec random.instant]
- [/.duration duration.codec random.duration]
- [/.date date.codec random.date]
- [/.time time.codec random.time]
-
- [/.nat/2 nat.binary random.nat]
- [/.nat/8 nat.octal random.nat]
- [/.nat/10 nat.decimal random.nat]
- [/.nat/16 nat.hex random.nat]
-
- [/.int/2 int.binary random.int]
- [/.int/8 int.octal random.int]
- [/.int/10 int.decimal random.int]
- [/.int/16 int.hex random.int]
-
- [/.rev/2 rev.binary random.rev]
- [/.rev/8 rev.octal random.rev]
- [/.rev/10 rev.decimal random.rev]
- [/.rev/16 rev.hex random.rev]
-
- [/.frac/2 frac.binary random.frac]
- [/.frac/8 frac.octal random.frac]
- [/.frac/10 frac.decimal random.frac]
- [/.frac/16 frac.hex random.frac]
- ))
+ ..codec
(~~ (template [<format> <alias> <random>]
[(do random.monad
[sample <random>]
diff --git a/stdlib/source/test/lux/data/text/regex.lux b/stdlib/source/test/lux/data/text/regex.lux
index 481dcd17f..cb481b97a 100644
--- a/stdlib/source/test/lux/data/text/regex.lux
+++ b/stdlib/source/test/lux/data/text/regex.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- pipe
- ["." try]
- ["p" parser
- ["<.>" text (#+ Parser)]
- ["s" code]]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]
- [math
- [number (#+ hex)]
- ["." random]]
- ["." macro
- [syntax (#+ syntax:)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ pipe
+ ["." try]
+ ["p" parser
+ ["<.>" text (#+ Parser)]
+ ["s" code]]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]
+ [math
+ [number (#+ hex)]
+ ["." random]]
+ ["." macro
+ [syntax (#+ syntax:)]]]]
+ [\\library
["." /]])
(def: (should_pass regex input)
diff --git a/stdlib/source/test/lux/data/text/unicode/block.lux b/stdlib/source/test/lux/data/text/unicode/block.lux
index 8a41eeca2..e4affc97a 100644
--- a/stdlib/source/test/lux/data/text/unicode/block.lux
+++ b/stdlib/source/test/lux/data/text/unicode/block.lux
@@ -1,24 +1,25 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." hash]
- ["$." monoid]]]
- [data
- ["." text]
- [collection
- ["." set]
- ["." list]]]
- [macro
- ["." template]]
- [math
- ["." random (#+ Random)]
- [number (#+ hex)
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]
+ ["$." monoid]]]
+ [data
+ ["." text]
+ [collection
+ ["." set]
+ ["." list]]]
+ [macro
+ ["." template]]
+ [math
+ ["." random (#+ Random)]
+ [number (#+ hex)
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: #export random
diff --git a/stdlib/source/test/lux/data/text/unicode/set.lux b/stdlib/source/test/lux/data/text/unicode/set.lux
index 631d3b511..3ef15de08 100644
--- a/stdlib/source/test/lux/data/text/unicode/set.lux
+++ b/stdlib/source/test/lux/data/text/unicode/set.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [data
- ["." product]
- ["." bit ("#\." equivalence)]
- [collection
- ["." set ("#\." equivalence)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [data
+ ["." product]
+ ["." bit ("#\." equivalence)]
+ [collection
+ ["." set ("#\." equivalence)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
["." / #_
["/#" // #_
["#." block]]]
- [\\
+ [\\library
["." /
[//
["." block]]]])
diff --git a/stdlib/source/test/lux/debug.lux b/stdlib/source/test/lux/debug.lux
index 5c0a950dc..bbbf299d8 100644
--- a/stdlib/source/test/lux/debug.lux
+++ b/stdlib/source/test/lux/debug.lux
@@ -1,34 +1,35 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["@" target]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try ("#\." functor)]
- ["." exception]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor)]]
- [format
- [json (#+ JSON)]
- [xml (#+ XML)]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- ["." random (#+ Random)]
- [number
- [ratio (#+ Ratio)]]]
- [time (#+ Time)
- [instant (#+ Instant)]
- [date (#+ Date)]
- [duration (#+ Duration)]
- [month (#+ Month)]
- [day (#+ Day)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["@" target]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try ("#\." functor)]
+ ["." exception]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor)]]
+ [format
+ [json (#+ JSON)]
+ [xml (#+ XML)]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ [ratio (#+ Ratio)]]]
+ [time (#+ Time)
+ [instant (#+ Instant)]
+ [date (#+ Date)]
+ [duration (#+ Duration)]
+ [month (#+ Month)]
+ [day (#+ Day)]]]]
+ [\\library
["." /]]
["$." // #_
["#." type]
diff --git a/stdlib/source/test/lux/extension.lux b/stdlib/source/test/lux/extension.lux
index c784788ba..39597a8a3 100644
--- a/stdlib/source/test/lux/extension.lux
+++ b/stdlib/source/test/lux/extension.lux
@@ -1,46 +1,47 @@
(.module:
- [lux #*
- ["." debug]
- ["@" target
- ["." jvm]
- ["." js]
- ["." python]
- ["." lua]
- ["." ruby]
- ["." php]
- ["." scheme]]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try]
- ["<>" parser
- ["<.>" code]
- ["<.>" analysis]
- ["<.>" synthesis]]]
- [data
- ["." product]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." row]
- ["." list ("#\." functor)]]]
- [math
- ["." random]
- [number
- ["n" nat]]]
- [tool
- [compiler
- ["." phase]
- [language
- [lux
- ["." analysis]
- ["." synthesis]
- ["." directive]
- [phase
- [analysis
- ["." type]]]]]]]
- ["_" test (#+ Test)]]
- [\\
+ [library
+ [lux #*
+ ["." debug]
+ ["@" target
+ ["." jvm]
+ ["." js]
+ ["." python]
+ ["." lua]
+ ["." ruby]
+ ["." php]
+ ["." scheme]]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]
+ ["<>" parser
+ ["<.>" code]
+ ["<.>" analysis]
+ ["<.>" synthesis]]]
+ [data
+ ["." product]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." row]
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]
+ [tool
+ [compiler
+ ["." phase]
+ [language
+ [lux
+ ["." analysis]
+ ["." synthesis]
+ ["." directive]
+ [phase
+ [analysis
+ ["." type]]]]]]]
+ ["_" test (#+ Test)]]]
+ [\\library
["." / (#+ analysis: synthesis: generation: directive:)]])
(def: my_analysis "my analysis")
diff --git a/stdlib/source/test/lux/ffi.js.lux b/stdlib/source/test/lux/ffi.js.lux
index e2c699dbd..70ca96929 100644
--- a/stdlib/source/test/lux/ffi.js.lux
+++ b/stdlib/source/test/lux/ffi.js.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]]
- [data
- ["." bit ("#\." equivalence)]
- ["." text ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["." nat]
- ["." frac]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]]
+ [data
+ ["." bit ("#\." equivalence)]
+ ["." text ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["." nat]
+ ["." frac]]]]]
+ [\\library
["." /]])
(/.import: Uint8Array)
diff --git a/stdlib/source/test/lux/ffi.jvm.lux b/stdlib/source/test/lux/ffi.jvm.lux
index 7baa32fa2..ba02b1fc9 100644
--- a/stdlib/source/test/lux/ffi.jvm.lux
+++ b/stdlib/source/test/lux/ffi.jvm.lux
@@ -1,29 +1,30 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["." type ("#\." equivalence)]
- ["." meta]
- [abstract
- [monad (#+ do)]]
- [control
- [pipe (#+ case>)]
- ["." try]
- ["." exception]]
- [data
- ["." bit ("#\." equivalence)]
- ["." text ("#\." equivalence)]
- [collection
- ["." array (#+ Array)]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- ["." random]
- [number
- ["n" nat]
- ["i" int ("#\." equivalence)]
- ["f" frac ("#\." equivalence)]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." type ("#\." equivalence)]
+ ["." meta]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]
+ ["." exception]]
+ [data
+ ["." bit ("#\." equivalence)]
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." array (#+ Array)]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]
+ ["i" int ("#\." equivalence)]
+ ["f" frac ("#\." equivalence)]]]]]
+ [\\library
["." /]])
(/.import: (java/util/concurrent/Callable a))
diff --git a/stdlib/source/test/lux/ffi.lua.lux b/stdlib/source/test/lux/ffi.lua.lux
index b05973bb8..c8d4ea6d5 100644
--- a/stdlib/source/test/lux/ffi.lua.lux
+++ b/stdlib/source/test/lux/ffi.lua.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]]
- [data
- ["." text ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["." nat]
- ["." frac]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]]
+ [data
+ ["." text ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["." nat]
+ ["." frac]]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/ffi.old.lux b/stdlib/source/test/lux/ffi.old.lux
index b7a4ba099..36ec40e21 100644
--- a/stdlib/source/test/lux/ffi.old.lux
+++ b/stdlib/source/test/lux/ffi.old.lux
@@ -1,24 +1,25 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]]
- [control
- [pipe (#+ case>)]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]
- [macro
- ["." template]]
- [math
- ["." random]
- [number
- ["n" nat]
- ["i" int]
- ["f" frac]]]
- ["." type ("#\." equivalence)]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]
+ [macro
+ ["." template]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]
+ ["i" int]
+ ["f" frac]]]
+ ["." type ("#\." equivalence)]]]
+ [\\library
["." /]])
(/.import: java/lang/Object)
diff --git a/stdlib/source/test/lux/ffi.php.lux b/stdlib/source/test/lux/ffi.php.lux
index b05973bb8..c8d4ea6d5 100644
--- a/stdlib/source/test/lux/ffi.php.lux
+++ b/stdlib/source/test/lux/ffi.php.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]]
- [data
- ["." text ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["." nat]
- ["." frac]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]]
+ [data
+ ["." text ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["." nat]
+ ["." frac]]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/ffi.py.lux b/stdlib/source/test/lux/ffi.py.lux
index b05973bb8..18aab4188 100644
--- a/stdlib/source/test/lux/ffi.py.lux
+++ b/stdlib/source/test/lux/ffi.py.lux
@@ -1,24 +1,61 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]]
- [data
- ["." text ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["." nat]
- ["." frac]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [math
+ ["." random]
+ [number
+ ["i" int]]]]]
+ [\\library
["." /]])
+(/.import: os
+ ["#::."
+ (#static R_OK /.Integer)
+ (#static W_OK /.Integer)])
+
(def: #export test
Test
(do {! random.monad}
- []
+ [boolean random.bit
+ integer random.int
+ float random.frac
+ string (random.ascii/lower 1)]
(<| (_.covering /._)
- (_.test "TBD"
- true))))
+ (`` ($_ _.and
+ (~~ (template [<type> <sample>]
+ [(_.cover [<type>]
+ (exec
+ (: <type> <sample>)
+ true))]
+
+ [/.Boolean boolean]
+ [/.Integer integer]
+ [/.Float float]
+ [/.String string]
+ ))
+ (_.for [/.Object]
+ ($_ _.and
+ (~~ (template [<type>]
+ [(_.cover [<type>]
+ (exec
+ (|> []
+ (:as <type>)
+ (: (Ex [a] (/.Object a))))
+ true))]
+
+ [/.None]
+ [/.Dict]
+ ))))
+ (_.cover [/.Function /.lambda]
+ (exec
+ (|> (/.lambda [input/0] input/0)
+ (: /.Function)
+ (: (Ex [a] (/.Object a))))
+ true))
+ (_.cover [/.import:]
+ (and (i.= (os::R_OK) (os::R_OK))
+ (not (i.= (os::W_OK) (os::R_OK)))))
+ )))))
diff --git a/stdlib/source/test/lux/ffi.rb.lux b/stdlib/source/test/lux/ffi.rb.lux
index b05973bb8..c8d4ea6d5 100644
--- a/stdlib/source/test/lux/ffi.rb.lux
+++ b/stdlib/source/test/lux/ffi.rb.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]]
- [data
- ["." text ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["." nat]
- ["." frac]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]]
+ [data
+ ["." text ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["." nat]
+ ["." frac]]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/ffi.scm.lux b/stdlib/source/test/lux/ffi.scm.lux
index b05973bb8..c8d4ea6d5 100644
--- a/stdlib/source/test/lux/ffi.scm.lux
+++ b/stdlib/source/test/lux/ffi.scm.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]]
- [data
- ["." text ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["." nat]
- ["." frac]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]]
+ [data
+ ["." text ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["." nat]
+ ["." frac]]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/locale.lux b/stdlib/source/test/lux/locale.lux
index a7949a62b..54b29cff7 100644
--- a/stdlib/source/test/lux/locale.lux
+++ b/stdlib/source/test/lux/locale.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." hash]]]
- [math
- ["." random (#+ Random) ("#\." monad)]]
- [data
- ["." text ("#\." equivalence)
- ["." encoding (#+ Encoding)]]
- [collection
- ["." list]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]]
+ [data
+ ["." text ("#\." equivalence)
+ ["." encoding (#+ Encoding)]]
+ [collection
+ ["." list]]]]]
["." / #_
["#." language]
["#." territory]]
- [\\
+ [\\library
["." /
["." language (#+ Language)]
["." territory (#+ Territory)]]])
diff --git a/stdlib/source/test/lux/locale/language.lux b/stdlib/source/test/lux/locale/language.lux
index bce125224..39bc71aae 100644
--- a/stdlib/source/test/lux/locale/language.lux
+++ b/stdlib/source/test/lux/locale/language.lux
@@ -1,24 +1,25 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [hash (#+ Hash)]
- [\spec
- ["$." hash]]]
- [data
- ["." maybe]
- ["." text]
- [collection
- ["." set (#+ Set)]
- ["." list ("#\." functor fold)]]]
- [macro
- ["." template]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [hash (#+ Hash)]
+ [\\spec
+ ["$." hash]]]
+ [data
+ ["." maybe]
+ ["." text]
+ [collection
+ ["." set (#+ Set)]
+ ["." list ("#\." functor fold)]]]
+ [macro
+ ["." template]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(type: Bundle
@@ -178,7 +179,8 @@
..languages/x
..languages/y
..languages/z
- ..languages/etc))
+ ..languages/etc
+ ))
(def: (aggregate lens hash territories)
(All [a] (-> (-> Bundle (Set a))
@@ -214,7 +216,7 @@
(list.every? (\ /.equivalence = <reference>)
(`` (list (~~ (template.splice <aliases>)))))))
-(def: aliases_test
+(def: aliases_test/0
Test
($_ _.and
## A
@@ -236,6 +238,11 @@
(!aliases /.kachin [/.jingpho])
(!aliases /.kalaallisut [/.greenlandic])
(!aliases /.khotanese [/.sakan])
+ ))
+
+(def: aliases_test/1
+ Test
+ ($_ _.and
## M
(!aliases /.mi'kmaq [/.micmac])
## N
@@ -260,6 +267,13 @@
(!aliases /.zaza [/.dimili /.dimli /.kirdki /.kirmanjki /.zazaki])
))
+(def: aliases_test
+ Test
+ ($_ _.and
+ ..aliases_test/0
+ ..aliases_test/1
+ ))
+
(def: #export random
(Random /.Language)
(let [options (|> ..languages
diff --git a/stdlib/source/test/lux/locale/territory.lux b/stdlib/source/test/lux/locale/territory.lux
index 61692050b..fadbe2890 100644
--- a/stdlib/source/test/lux/locale/territory.lux
+++ b/stdlib/source/test/lux/locale/territory.lux
@@ -1,24 +1,25 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [hash (#+ Hash)]
- [\spec
- ["$." hash]]]
- [data
- ["." maybe]
- ["." text]
- [collection
- ["." set (#+ Set)]
- ["." list ("#\." functor fold)]]]
- [macro
- ["." template]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [hash (#+ Hash)]
+ [\\spec
+ ["$." hash]]]
+ [data
+ ["." maybe]
+ ["." text]
+ [collection
+ ["." set (#+ Set)]
+ ["." list ("#\." functor fold)]]]
+ [macro
+ ["." template]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(type: Bundle
diff --git a/stdlib/source/test/lux/macro.lux b/stdlib/source/test/lux/macro.lux
index 7864fb686..98d3ead2b 100644
--- a/stdlib/source/test/lux/macro.lux
+++ b/stdlib/source/test/lux/macro.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try ("#\." functor)]
- [parser
- ["<.>" code]]]
- [data
- ["." bit ("#\." equivalence)]
- ["." name]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list]]]
- [math
- ["." random (#+ Random)]
- [number
- ["." nat]]]
- ["." meta
- ["." location]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try ("#\." functor)]
+ [parser
+ ["<.>" code]]]
+ [data
+ ["." bit ("#\." equivalence)]
+ ["." name]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["." nat]]]
+ ["." meta
+ ["." location]]]]
+ [\\library
["." /
[syntax (#+ syntax:)]
["." code ("#\." equivalence)]
diff --git a/stdlib/source/test/lux/macro/code.lux b/stdlib/source/test/lux/macro/code.lux
index 93ed2c19b..576ccb54a 100644
--- a/stdlib/source/test/lux/macro/code.lux
+++ b/stdlib/source/test/lux/macro/code.lux
@@ -1,29 +1,30 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try (#+ Try)]]
- [data
- ["." product]
- ["." text]
- [collection
- ["." list ("#\." functor)]]]
- [math
- ["." random (#+ Random) ("#\." monad)]
- [number
- ["n" nat]]]
- [meta
- ["." location]]
- [tool
- [compiler
- [language
- [lux
- ["." syntax]]]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ ["." product]
+ ["." text]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]
+ [number
+ ["n" nat]]]
+ [meta
+ ["." location]]
+ [tool
+ [compiler
+ [language
+ [lux
+ ["." syntax]]]]]]]
+ [\\library
["." /]])
(def: random_text
diff --git a/stdlib/source/test/lux/macro/local.lux b/stdlib/source/test/lux/macro/local.lux
index d125a2af4..cbe6f0e3a 100644
--- a/stdlib/source/test/lux/macro/local.lux
+++ b/stdlib/source/test/lux/macro/local.lux
@@ -1,29 +1,30 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["." meta]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["." exception]
- ["<>" parser
- ["<.>" code]]]
- [data
- [text
- ["%" format]]
- [collection
- ["." list]
- [dictionary
- ["." plist]]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." meta]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception]
+ ["<>" parser
+ ["<.>" code]]]
+ [data
+ [text
+ ["%" format]]
+ [collection
+ ["." list]
+ [dictionary
+ ["." plist]]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(syntax: (macro_error macro)
diff --git a/stdlib/source/test/lux/macro/poly.lux b/stdlib/source/test/lux/macro/poly.lux
index d15e96d3d..90c57c87c 100644
--- a/stdlib/source/test/lux/macro/poly.lux
+++ b/stdlib/source/test/lux/macro/poly.lux
@@ -1,7 +1,8 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]]]
+ [\\library
["." /]]
["." / #_
["#." equivalence]
diff --git a/stdlib/source/test/lux/macro/poly/equivalence.lux b/stdlib/source/test/lux/macro/poly/equivalence.lux
index a43da2d84..c8cd7c7bf 100644
--- a/stdlib/source/test/lux/macro/poly/equivalence.lux
+++ b/stdlib/source/test/lux/macro/poly/equivalence.lux
@@ -1,27 +1,28 @@
(.module:
- [lux #*
- ["%" data/text/format (#+ format)]
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [equivalence (#+ Equivalence)
- [\poly
- ["." /]]]
- [\spec
- ["$." equivalence]]]
- [data
- ["." bit]
- ["." maybe]
- ["." text]
- [collection
- ["." list]]]
- [macro
- [poly (#+ derived:)]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["i" int]]]])
+ [library
+ [lux #*
+ ["%" data/text/format (#+ format)]
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [equivalence (#+ Equivalence)
+ [\\poly
+ ["." /]]]
+ [\\spec
+ ["$." equivalence]]]
+ [data
+ ["." bit]
+ ["." maybe]
+ ["." text]
+ [collection
+ ["." list]]]
+ [macro
+ [poly (#+ derived:)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["i" int]]]]])
(type: Variant
(#Case0 Bit)
diff --git a/stdlib/source/test/lux/macro/poly/functor.lux b/stdlib/source/test/lux/macro/poly/functor.lux
index 8d94cf852..6eebf2d55 100644
--- a/stdlib/source/test/lux/macro/poly/functor.lux
+++ b/stdlib/source/test/lux/macro/poly/functor.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["%" data/text/format (#+ format)]
- [abstract
- [monad (#+ do)]
- [functor
- [\poly
- ["." /]]]]
- ["r" math/random (#+ Random)]
- ["_" test (#+ Test)]
- [control
- ["." state]]
- [data
- ["." identity]]
- [macro
- [poly (#+ derived:)]]])
+ [library
+ [lux #*
+ ["%" data/text/format (#+ format)]
+ [abstract
+ [monad (#+ do)]
+ [functor
+ [\\poly
+ ["." /]]]]
+ ["r" math/random (#+ Random)]
+ ["_" test (#+ Test)]
+ [control
+ ["." state]]
+ [data
+ ["." identity]]
+ [macro
+ [poly (#+ derived:)]]]])
(derived: maybe_functor (/.functor .Maybe))
(derived: list_functor (/.functor .List))
diff --git a/stdlib/source/test/lux/macro/poly/json.lux b/stdlib/source/test/lux/macro/poly/json.lux
index 91ad9b010..e369dac92 100644
--- a/stdlib/source/test/lux/macro/poly/json.lux
+++ b/stdlib/source/test/lux/macro/poly/json.lux
@@ -1,48 +1,49 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["." debug]
- [abstract
- codec
- [monad (#+ do)]
- ["." equivalence (#+ Equivalence)
- ["poly/#" \poly]]
- [\spec
- ["$." equivalence]
- ["$." codec]]]
- [control
- pipe
- ["." try]
- ["p" parser
- ## TODO: Get rid of this import ASAP
- [json (#+)]]]
- [data
- ["." bit]
- ["." maybe]
- ["." text
- ["%" format (#+ format)]]
- [format
- [json (#+)
- [\poly
- ["." /]]]]
- [collection
- [row (#+ row)]
- ["d" dictionary]
- ["." list]]]
- [macro
- [poly (#+ derived:)]]
- [type
- ["." unit]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["." frac]]]
- [time
- ["ti" instant]
- ["tda" date]
- ## ["tdu" duration]
- ]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." debug]
+ [abstract
+ codec
+ [monad (#+ do)]
+ ["." equivalence (#+ Equivalence)
+ ["poly/#" \\poly]]
+ [\\spec
+ ["$." equivalence]
+ ["$." codec]]]
+ [control
+ pipe
+ ["." try]
+ ["p" parser
+ ## TODO: Get rid of this import ASAP
+ [json (#+)]]]
+ [data
+ ["." bit]
+ ["." maybe]
+ ["." text
+ ["%" format (#+ format)]]
+ [format
+ [json (#+)
+ [\\poly
+ ["." /]]]]
+ [collection
+ [row (#+ row)]
+ ["d" dictionary]
+ ["." list]]]
+ [macro
+ [poly (#+ derived:)]]
+ [type
+ ["." unit]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["." frac]]]
+ [time
+ ["ti" instant]
+ ["tda" date]
+ ## ["tdu" duration]
+ ]]]
[test
[lux
[time
diff --git a/stdlib/source/test/lux/macro/syntax.lux b/stdlib/source/test/lux/macro/syntax.lux
index 057565f3d..35d680974 100644
--- a/stdlib/source/test/lux/macro/syntax.lux
+++ b/stdlib/source/test/lux/macro/syntax.lux
@@ -1,13 +1,14 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]]
["." / #_
["#." annotations]
diff --git a/stdlib/source/test/lux/macro/syntax/annotations.lux b/stdlib/source/test/lux/macro/syntax/annotations.lux
index fdee0ffa5..00d71c949 100644
--- a/stdlib/source/test/lux/macro/syntax/annotations.lux
+++ b/stdlib/source/test/lux/macro/syntax/annotations.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try]
- [parser
- ["<.>" code]]]
- [data
- [collection
- ["." list]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try]
+ [parser
+ ["<.>" code]]]
+ [data
+ [collection
+ ["." list]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]]
["$." /// #_
["#." code]])
diff --git a/stdlib/source/test/lux/macro/syntax/check.lux b/stdlib/source/test/lux/macro/syntax/check.lux
index 59f5c1a0b..626471c73 100644
--- a/stdlib/source/test/lux/macro/syntax/check.lux
+++ b/stdlib/source/test/lux/macro/syntax/check.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try]
- ["<>" parser
- ["<.>" code]]]
- [math
- ["." random (#+ Random)]]
- [macro
- ["." code ("#\." equivalence)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try]
+ ["<>" parser
+ ["<.>" code]]]
+ [math
+ ["." random (#+ Random)]]
+ [macro
+ ["." code ("#\." equivalence)]]]]
+ [\\library
["." /]]
["$." /// #_
["#." code]])
diff --git a/stdlib/source/test/lux/macro/syntax/declaration.lux b/stdlib/source/test/lux/macro/syntax/declaration.lux
index 555c3138e..761ba87cc 100644
--- a/stdlib/source/test/lux/macro/syntax/declaration.lux
+++ b/stdlib/source/test/lux/macro/syntax/declaration.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try]
- [parser
- ["<.>" code]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try]
+ [parser
+ ["<.>" code]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: #export random
diff --git a/stdlib/source/test/lux/macro/syntax/definition.lux b/stdlib/source/test/lux/macro/syntax/definition.lux
index 48719ac17..c98b1e853 100644
--- a/stdlib/source/test/lux/macro/syntax/definition.lux
+++ b/stdlib/source/test/lux/macro/syntax/definition.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try]
- ["." exception]
- ["<>" parser
- ["<.>" code]]]
- [math
- ["." random (#+ Random)]]
- [macro
- ["." code ("#\." equivalence)]]
- [meta
- ["." location]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try]
+ ["." exception]
+ ["<>" parser
+ ["<.>" code]]]
+ [math
+ ["." random (#+ Random)]]
+ [macro
+ ["." code ("#\." equivalence)]]
+ [meta
+ ["." location]]]]
+ [\\library
["." /]]
["$."// #_
["#." check]
diff --git a/stdlib/source/test/lux/macro/syntax/export.lux b/stdlib/source/test/lux/macro/syntax/export.lux
index 10e86fd20..6e93f2e4b 100644
--- a/stdlib/source/test/lux/macro/syntax/export.lux
+++ b/stdlib/source/test/lux/macro/syntax/export.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- [parser
- ["<.>" code]]]
- [data
- ["." bit ("#\." equivalence)]]
- [math
- ["." random]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ [parser
+ ["<.>" code]]]
+ [data
+ ["." bit ("#\." equivalence)]]
+ [math
+ ["." random]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/macro/syntax/input.lux b/stdlib/source/test/lux/macro/syntax/input.lux
index bf22a9c17..34357f79a 100644
--- a/stdlib/source/test/lux/macro/syntax/input.lux
+++ b/stdlib/source/test/lux/macro/syntax/input.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try]
- [parser
- ["<.>" code]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try]
+ [parser
+ ["<.>" code]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]]
["$." /// #_
["#." code]])
diff --git a/stdlib/source/test/lux/macro/syntax/type/variable.lux b/stdlib/source/test/lux/macro/syntax/type/variable.lux
index d2ac5d86e..8ff84f36f 100644
--- a/stdlib/source/test/lux/macro/syntax/type/variable.lux
+++ b/stdlib/source/test/lux/macro/syntax/type/variable.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- ["." try ("#\." functor)]
- [parser
- ["<.>" code]]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ ["." try ("#\." functor)]
+ [parser
+ ["<.>" code]]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /]])
(def: #export random
diff --git a/stdlib/source/test/lux/macro/template.lux b/stdlib/source/test/lux/macro/template.lux
index 12e503e33..fc1d62f11 100644
--- a/stdlib/source/test/lux/macro/template.lux
+++ b/stdlib/source/test/lux/macro/template.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["." exception]]
- [data
- [collection
- ["." list]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- ["." random (#+ Random)]
- [number
- ["." nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception]]
+ [data
+ [collection
+ ["." list]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["." nat]]]]]
+ [\\library
["." /]])
(/.let [(!pow/2 <scalar>)
diff --git a/stdlib/source/test/lux/math.lux b/stdlib/source/test/lux/math.lux
index fc9de2f8f..a43d63a2b 100644
--- a/stdlib/source/test/lux/math.lux
+++ b/stdlib/source/test/lux/math.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [macro
- ["." template]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["i" int]
- ["f" frac]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [macro
+ ["." template]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["i" int]
+ ["f" frac]]]]]
+ [\\library
["." /]]
["." / #_
["#." infix]
diff --git a/stdlib/source/test/lux/math/infix.lux b/stdlib/source/test/lux/math/infix.lux
index 29a3cfcab..2dafd35aa 100644
--- a/stdlib/source/test/lux/math/infix.lux
+++ b/stdlib/source/test/lux/math/infix.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- ["." bit ("#\." equivalence)]]
- [math
- ["." random]
- [number
- ["n" nat]
- ["f" frac]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." bit ("#\." equivalence)]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]
+ ["f" frac]]]]]
+ [\\library
["." /
["." //]]])
diff --git a/stdlib/source/test/lux/math/logic/continuous.lux b/stdlib/source/test/lux/math/logic/continuous.lux
index ceb4ca33b..5ff4c46cc 100644
--- a/stdlib/source/test/lux/math/logic/continuous.lux
+++ b/stdlib/source/test/lux/math/logic/continuous.lux
@@ -1,15 +1,16 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." monoid]]]
- [math
- ["." random]
- [number
- ["r" rev]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." monoid]]]
+ [math
+ ["." random]
+ [number
+ ["r" rev]]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/math/logic/fuzzy.lux b/stdlib/source/test/lux/math/logic/fuzzy.lux
index 3da2e4cc9..ea39da68a 100644
--- a/stdlib/source/test/lux/math/logic/fuzzy.lux
+++ b/stdlib/source/test/lux/math/logic/fuzzy.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]
- [\spec
- [functor
- ["$." contravariant]]]]
- [data
- ["." bit ("#\." equivalence)]
- [collection
- ["." list]
- ["." set]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["r" rev]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]
+ [\\spec
+ [functor
+ ["$." contravariant]]]]
+ [data
+ ["." bit ("#\." equivalence)]
+ [collection
+ ["." list]
+ ["." set]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["r" rev]]]]]
+ [\\library
["." / (#+ Fuzzy)
["/#" // #_
["#" continuous]]]])
diff --git a/stdlib/source/test/lux/math/modular.lux b/stdlib/source/test/lux/math/modular.lux
index 21d451472..5322b162b 100644
--- a/stdlib/source/test/lux/math/modular.lux
+++ b/stdlib/source/test/lux/math/modular.lux
@@ -1,28 +1,29 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["." type ("#\." equivalence)]
- [abstract
- [monad (#+ do)]
- ["." predicate]
- [\spec
- ["$." equivalence]
- ["$." order]
- ["$." monoid]
- ["$." codec]]]
- [control
- ["." try]
- ["." exception]]
- [data
- ["." product]
- ["." bit ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["i" int]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." type ("#\." equivalence)]
+ [abstract
+ [monad (#+ do)]
+ ["." predicate]
+ [\\spec
+ ["$." equivalence]
+ ["$." order]
+ ["$." monoid]
+ ["$." codec]]]
+ [control
+ ["." try]
+ ["." exception]]
+ [data
+ ["." product]
+ ["." bit ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["i" int]]]]]
["$." // #_
["#" modulus]]
- [\\
+ [\\library
["." /
["/#" // #_
["#" modulus]]]])
diff --git a/stdlib/source/test/lux/math/modulus.lux b/stdlib/source/test/lux/math/modulus.lux
index af3a3dc5b..af040b645 100644
--- a/stdlib/source/test/lux/math/modulus.lux
+++ b/stdlib/source/test/lux/math/modulus.lux
@@ -1,20 +1,21 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["." meta]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["." exception]]
- [math
- ["." random (#+ Random)]
- [number
- ["i" int]]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." meta]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["i" int]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]]]]
+ [\\library
["." /]])
(syntax: (|divisor|)
diff --git a/stdlib/source/test/lux/math/number.lux b/stdlib/source/test/lux/math/number.lux
index 99cf72928..b13fa5cf8 100644
--- a/stdlib/source/test/lux/math/number.lux
+++ b/stdlib/source/test/lux/math/number.lux
@@ -1,11 +1,12 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [control
- ["." try]]
- [data
- ["." text]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [control
+ ["." try]]
+ [data
+ ["." text]]]]
+ [\\library
["." /
["n" nat]
["i" int]
diff --git a/stdlib/source/test/lux/math/number/complex.lux b/stdlib/source/test/lux/math/number/complex.lux
index d32abc2c5..2670d53dc 100644
--- a/stdlib/source/test/lux/math/number/complex.lux
+++ b/stdlib/source/test/lux/math/number/complex.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["%" data/text/format (#+ format)]
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." order]
- ["$." codec]]]
- [data
- [collection
- ["." list ("#\." functor)]]]
- ["." math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["%" data/text/format (#+ format)]
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." order]
+ ["$." codec]]]
+ [data
+ [collection
+ ["." list ("#\." functor)]]]
+ ["." math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /
[//
["n" nat]
diff --git a/stdlib/source/test/lux/math/number/frac.lux b/stdlib/source/test/lux/math/number/frac.lux
index eb981a5b0..093511510 100644
--- a/stdlib/source/test/lux/math/number/frac.lux
+++ b/stdlib/source/test/lux/math/number/frac.lux
@@ -1,21 +1,22 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["@" target]
- ["." ffi]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." hash]
- ["$." order]
- ["$." monoid]
- ["$." codec]]]
- [data
- ["." bit ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["@" target]
+ ["." ffi]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]
+ ["$." order]
+ ["$." monoid]
+ ["$." codec]]]
+ [data
+ ["." bit ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /
[// #*
["n" nat]
diff --git a/stdlib/source/test/lux/math/number/i16.lux b/stdlib/source/test/lux/math/number/i16.lux
index 4450cf88e..4720a13b7 100644
--- a/stdlib/source/test/lux/math/number/i16.lux
+++ b/stdlib/source/test/lux/math/number/i16.lux
@@ -1,13 +1,14 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /
["/#" // #_
["i" int]
diff --git a/stdlib/source/test/lux/math/number/i32.lux b/stdlib/source/test/lux/math/number/i32.lux
index 8b2d0e5f2..66d65fa40 100644
--- a/stdlib/source/test/lux/math/number/i32.lux
+++ b/stdlib/source/test/lux/math/number/i32.lux
@@ -1,13 +1,14 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /
["/#" // #_
["i" int]
diff --git a/stdlib/source/test/lux/math/number/i64.lux b/stdlib/source/test/lux/math/number/i64.lux
index 129d2bb84..942930af0 100644
--- a/stdlib/source/test/lux/math/number/i64.lux
+++ b/stdlib/source/test/lux/math/number/i64.lux
@@ -1,17 +1,18 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [data
- ["." bit ("#\." equivalence)]]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." hash]
- ["$." monoid]]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [data
+ ["." bit ("#\." equivalence)]]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]
+ ["$." monoid]]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." / ("\." equivalence)
[// (#+ hex)
["n" nat]
diff --git a/stdlib/source/test/lux/math/number/i8.lux b/stdlib/source/test/lux/math/number/i8.lux
index 1f5c7de42..c5fee1fcf 100644
--- a/stdlib/source/test/lux/math/number/i8.lux
+++ b/stdlib/source/test/lux/math/number/i8.lux
@@ -1,13 +1,14 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /
["/#" // #_
["i" int]
diff --git a/stdlib/source/test/lux/math/number/int.lux b/stdlib/source/test/lux/math/number/int.lux
index f339b3ac4..47e381985 100644
--- a/stdlib/source/test/lux/math/number/int.lux
+++ b/stdlib/source/test/lux/math/number/int.lux
@@ -1,21 +1,22 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." hash]
- ["$." order]
- ["$." enum]
- ["$." interval]
- ["$." monoid]
- ["$." codec]]]
- [data
- ["." bit ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]
+ ["$." order]
+ ["$." enum]
+ ["$." interval]
+ ["$." monoid]
+ ["$." codec]]]
+ [data
+ ["." bit ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /
[//
["n" nat]
diff --git a/stdlib/source/test/lux/math/number/nat.lux b/stdlib/source/test/lux/math/number/nat.lux
index 26a872067..ff3eb64d1 100644
--- a/stdlib/source/test/lux/math/number/nat.lux
+++ b/stdlib/source/test/lux/math/number/nat.lux
@@ -1,21 +1,22 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." hash]
- ["$." order]
- ["$." enum]
- ["$." interval]
- ["$." monoid]
- ["$." codec]]]
- [data
- ["." bit ("#\." equivalence)]]
- [math
- ["." random]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]
+ ["$." order]
+ ["$." enum]
+ ["$." interval]
+ ["$." monoid]
+ ["$." codec]]]
+ [data
+ ["." bit ("#\." equivalence)]]
+ [math
+ ["." random]]]]
+ [\\library
["." /
[//
["f" frac]]]])
diff --git a/stdlib/source/test/lux/math/number/ratio.lux b/stdlib/source/test/lux/math/number/ratio.lux
index 8e8aeb0d0..838e8ca81 100644
--- a/stdlib/source/test/lux/math/number/ratio.lux
+++ b/stdlib/source/test/lux/math/number/ratio.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." order]
- ["$." monoid]
- ["$." codec]]]
- [data
- ["." bit ("#\." equivalence)]
- ["." maybe ("#\." functor)]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." order]
+ ["$." monoid]
+ ["$." codec]]]
+ [data
+ ["." bit ("#\." equivalence)]
+ ["." maybe ("#\." functor)]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /
[//
["n" nat ("#\." equivalence)]]]])
diff --git a/stdlib/source/test/lux/math/number/rev.lux b/stdlib/source/test/lux/math/number/rev.lux
index e4d6b81f7..70ab24c61 100644
--- a/stdlib/source/test/lux/math/number/rev.lux
+++ b/stdlib/source/test/lux/math/number/rev.lux
@@ -1,21 +1,22 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." hash]
- ["$." order]
- ["$." enum]
- ["$." interval]
- ["$." monoid]
- ["$." codec]]]
- [data
- ["." bit ("#\." equivalence)]]
- [math
- ["." random]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]
+ ["$." order]
+ ["$." enum]
+ ["$." interval]
+ ["$." monoid]
+ ["$." codec]]]
+ [data
+ ["." bit ("#\." equivalence)]]
+ [math
+ ["." random]]]]
+ [\\library
["." /
[// (#+ hex)
["n" nat]
diff --git a/stdlib/source/test/lux/meta.lux b/stdlib/source/test/lux/meta.lux
index b8aa1ff8b..3b3bf1ae2 100644
--- a/stdlib/source/test/lux/meta.lux
+++ b/stdlib/source/test/lux/meta.lux
@@ -1,33 +1,34 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["." type ("#\." equivalence)]
- [abstract
- [equivalence (#+ Equivalence)]
- [monad (#+ do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]]]
- [control
- ["." try (#+ Try) ("#\." functor)]]
- [data
- ["." product]
- ["." maybe]
- ["." bit ("#\." equivalence)]
- ["." name ("#\." equivalence)]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor monoid)]
- ["." set]]]
- [meta
- ["." location]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." type ("#\." equivalence)]
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]]
+ [control
+ ["." try (#+ Try) ("#\." functor)]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." bit ("#\." equivalence)]
+ ["." name ("#\." equivalence)]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor monoid)]
+ ["." set]]]
+ [meta
+ ["." location]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]]
["." / #_
["#." annotation]
diff --git a/stdlib/source/test/lux/meta/annotation.lux b/stdlib/source/test/lux/meta/annotation.lux
index 791e5759a..88ffb18d0 100644
--- a/stdlib/source/test/lux/meta/annotation.lux
+++ b/stdlib/source/test/lux/meta/annotation.lux
@@ -1,31 +1,32 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]]
- [data
- ["." product]
- ["." bit]
- ["." name ("#\." equivalence)]
- ["." text]
- [collection
- ["." list ("#\." functor)]]]
- [macro
- ["." code ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["." nat]
- ["." int]
- ["." rev]
- ["." frac]]]]
- [\\
- ["." /]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]]
+ [data
+ ["." product]
+ ["." bit]
+ ["." name ("#\." equivalence)]
+ ["." text]
+ [collection
+ ["." list ("#\." functor)]]]
+ [macro
+ ["." code ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["." nat]
+ ["." int]
+ ["." rev]
+ ["." frac]]]]]
[///
[macro
- ["_." code]]])
+ ["_." code]]]
+ [\\library
+ ["." /]])
(def: random_key
(Random Name)
diff --git a/stdlib/source/test/lux/meta/location.lux b/stdlib/source/test/lux/meta/location.lux
index 6e005bd5f..2aaa797a0 100644
--- a/stdlib/source/test/lux/meta/location.lux
+++ b/stdlib/source/test/lux/meta/location.lux
@@ -1,15 +1,16 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [data
- ["." text]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [data
+ ["." text]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /]]
["$." /// #_
[macro
diff --git a/stdlib/source/test/lux/program.lux b/stdlib/source/test/lux/program.lux
index 2da869ab5..ec605af3b 100644
--- a/stdlib/source/test/lux/program.lux
+++ b/stdlib/source/test/lux/program.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io]
- ["." try]
- ["<>" parser
- ["<.>" code]
- ["<.>" cli]]]
- [data
- ["." text]
- [collection
- ["." list]]]
- [macro
- [syntax (#+ syntax:)]]
- [math
- ["." random]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io]
+ ["." try]
+ ["<>" parser
+ ["<.>" code]
+ ["<.>" cli]]]
+ [data
+ ["." text]
+ [collection
+ ["." list]]]
+ [macro
+ [syntax (#+ syntax:)]]
+ [math
+ ["." random]]]]
+ [\\library
["." /]])
(syntax: (actual_program {actual_program (<| <code>.form
diff --git a/stdlib/source/test/lux/target.lux b/stdlib/source/test/lux/target.lux
index 3158b76ee..e9c2594fc 100644
--- a/stdlib/source/test/lux/target.lux
+++ b/stdlib/source/test/lux/target.lux
@@ -1,15 +1,16 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [data
- ["." text]
- [collection
- ["." list]
- ["." set (#+ Set)]]]
- [math
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [data
+ ["." text]
+ [collection
+ ["." list]
+ ["." set (#+ Set)]]]
+ [math
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(with_expansions [<targets> (as_is /.old
diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux
index 218f3df42..3486821ce 100644
--- a/stdlib/source/test/lux/target/jvm.lux
+++ b/stdlib/source/test/lux/target/jvm.lux
@@ -1,38 +1,39 @@
(.module:
- [lux (#- Type type primitive int)
- ["." ffi (#+ import:)]
- ["@" target]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." function]
- ["." io]
- ["." try]
- [concurrency
- ["." atom]]]
- [data
- ["." maybe]
- ["." bit ("#\." equivalence)]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- ["." format #_
- ["#" binary]]
- [collection
- ["." array]
- ["." dictionary]
- ["." row]
- ["." set]
- ["." list ("#\." functor)]]]
- [math
- ["." random (#+ Random) ("#\." monad)]
- [number
- ["n" nat]
- ["i" int]
- ["f" frac]
- ["." i32 (#+ I32)]
- ["." i64]]]
- ["_" test (#+ Test)]]
- [\\
+ [library
+ [lux (#- Type type primitive int)
+ ["." ffi (#+ import:)]
+ ["@" target]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]
+ ["." io]
+ ["." try]
+ [concurrency
+ ["." atom]]]
+ [data
+ ["." maybe]
+ ["." bit ("#\." equivalence)]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ ["." format #_
+ ["#" binary]]
+ [collection
+ ["." array]
+ ["." dictionary]
+ ["." row]
+ ["." set]
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]
+ [number
+ ["n" nat]
+ ["i" int]
+ ["f" frac]
+ ["." i32 (#+ I32)]
+ ["." i64]]]
+ ["_" test (#+ Test)]]]
+ [\\library
["." / #_
["#." loader (#+ Library)]
["#." version]
diff --git a/stdlib/source/test/lux/test.lux b/stdlib/source/test/lux/test.lux
index ede26191c..9c3e0f506 100644
--- a/stdlib/source/test/lux/test.lux
+++ b/stdlib/source/test/lux/test.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." io]
- ["." exception]
- [concurrency
- ["." promise]
- ["." atom (#+ Atom)]]]
- [data
- ["." text ("#\." equivalence)]
- [collection
- ["." list]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io]
+ ["." exception]
+ [concurrency
+ ["." promise]
+ ["." atom (#+ Atom)]]]
+ [data
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." list]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: (verify expected_message/0 expected_message/1 successes failures [tally message])
diff --git a/stdlib/source/test/lux/time.lux b/stdlib/source/test/lux/time.lux
index 6b321d1ce..17b17c61a 100644
--- a/stdlib/source/test/lux/time.lux
+++ b/stdlib/source/test/lux/time.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." order]
- ["$." enum]
- ["$." codec]]]
- [control
- [pipe (#+ case>)]
- ["." try ("#\." functor)]
- ["." exception]
- [parser
- ["<.>" text]]]
- [data
- ["." text
- ["%" format (#+ format)]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." order]
+ ["$." enum]
+ ["$." codec]]]
+ [control
+ [pipe (#+ case>)]
+ ["." try ("#\." functor)]
+ ["." exception]
+ [parser
+ ["<.>" text]]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
["." / #_
["#." date]
["#." day]
@@ -28,7 +29,7 @@
["#." instant]
["#." month]
["#." year]]
- [\\
+ [\\library
["." /
["." duration]]])
diff --git a/stdlib/source/test/lux/time/date.lux b/stdlib/source/test/lux/time/date.lux
index fdf78d535..cb9d46978 100644
--- a/stdlib/source/test/lux/time/date.lux
+++ b/stdlib/source/test/lux/time/date.lux
@@ -1,27 +1,28 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." order]
- ["$." enum]
- ["$." codec]]]
- [control
- ["." try ("#\." functor)]
- ["." exception]
- [parser
- ["<.>" text]]]
- [data
- [text
- ["%" format (#+ format)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["i" int]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." order]
+ ["$." enum]
+ ["$." codec]]]
+ [control
+ ["." try ("#\." functor)]
+ ["." exception]
+ [parser
+ ["<.>" text]]]
+ [data
+ [text
+ ["%" format (#+ format)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["i" int]]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/time/day.lux b/stdlib/source/test/lux/time/day.lux
index 3245c69b6..d2499309b 100644
--- a/stdlib/source/test/lux/time/day.lux
+++ b/stdlib/source/test/lux/time/day.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." order]
- ["$." enum]
- ["$." codec]]]
- [control
- ["." try]
- ["." exception]]
- [math
- ["." random (#+ Random) ("#\." monad)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." order]
+ ["$." enum]
+ ["$." codec]]]
+ [control
+ ["." try]
+ ["." exception]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]]]]
+ [\\library
["." /]])
(def: #export random
diff --git a/stdlib/source/test/lux/time/duration.lux b/stdlib/source/test/lux/time/duration.lux
index 7ca984beb..a3014cc1a 100644
--- a/stdlib/source/test/lux/time/duration.lux
+++ b/stdlib/source/test/lux/time/duration.lux
@@ -1,22 +1,23 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." order]
- ["$." enum]
- ["$." monoid]
- ["$." codec]]]
- [data
- ["." bit ("#\." equivalence)]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["i" int]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." order]
+ ["$." enum]
+ ["$." monoid]
+ ["$." codec]]]
+ [data
+ ["." bit ("#\." equivalence)]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["i" int]]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/time/instant.lux b/stdlib/source/test/lux/time/instant.lux
index 80a43472b..6fef2f55e 100644
--- a/stdlib/source/test/lux/time/instant.lux
+++ b/stdlib/source/test/lux/time/instant.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." order]
- ["$." enum]
- ["$." codec]]]
- [control
- ["." function]
- ["." try]
- ["." io]]
- [data
- [collection
- ["." list ("#\." fold)]]]
- [math
- ["." random]]
- [time
- ["." duration (#+ Duration)]
- ["." day (#+ Day) ("#\." enum)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." order]
+ ["$." enum]
+ ["$." codec]]]
+ [control
+ ["." function]
+ ["." try]
+ ["." io]]
+ [data
+ [collection
+ ["." list ("#\." fold)]]]
+ [math
+ ["." random]]
+ [time
+ ["." duration (#+ Duration)]
+ ["." day (#+ Day) ("#\." enum)]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/time/month.lux b/stdlib/source/test/lux/time/month.lux
index dac255f2c..202048cac 100644
--- a/stdlib/source/test/lux/time/month.lux
+++ b/stdlib/source/test/lux/time/month.lux
@@ -1,27 +1,28 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- ["." predicate]
- [\spec
- ["$." equivalence]
- ["$." hash]
- ["$." order]
- ["$." enum]
- ["$." codec]]]
- [control
- ["." try ("#\." functor)]
- ["." exception]]
- [data
- [collection
- ["." set]
- ["." list ("#\." functor fold)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ ["." predicate]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]
+ ["$." order]
+ ["$." enum]
+ ["$." codec]]]
+ [control
+ ["." try ("#\." functor)]
+ ["." exception]]
+ [data
+ [collection
+ ["." set]
+ ["." list ("#\." functor fold)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /
[//
["." duration]]]])
diff --git a/stdlib/source/test/lux/time/year.lux b/stdlib/source/test/lux/time/year.lux
index 97c416c11..ba364eaab 100644
--- a/stdlib/source/test/lux/time/year.lux
+++ b/stdlib/source/test/lux/time/year.lux
@@ -1,25 +1,26 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." order]
- ["$." codec]]]
- [control
- ["." try]
- ["." exception]]
- [data
- ["." bit ("#\." equivalence)]
- [text
- ["%" format (#+ format)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]
- ["i" int]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." order]
+ ["$." codec]]]
+ [control
+ ["." try]
+ ["." exception]]
+ [data
+ ["." bit ("#\." equivalence)]
+ [text
+ ["%" format (#+ format)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]
+ ["i" int]]]]]
+ [\\library
["." /
["/#" //
["#." duration]
diff --git a/stdlib/source/test/lux/tool.lux b/stdlib/source/test/lux/tool.lux
index 5452fbb65..ebda4eb93 100644
--- a/stdlib/source/test/lux/tool.lux
+++ b/stdlib/source/test/lux/tool.lux
@@ -1,6 +1,7 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]]]
["." / #_
[compiler
[language
diff --git a/stdlib/source/test/lux/type.lux b/stdlib/source/test/lux/type.lux
index cae8a8773..3a01acaab 100644
--- a/stdlib/source/test/lux/type.lux
+++ b/stdlib/source/test/lux/type.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- ["." monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [control
- [pipe (#+ case>)]]
- [data
- ["." maybe]
- ["." text ("#\." equivalence)]
- [collection
- ["." list]
- ["." array]]]
- [math
- ["." random (#+ Random) ("#\." monad)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ ["." monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [control
+ [pipe (#+ case>)]]
+ [data
+ ["." maybe]
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." list]
+ ["." array]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." / ("#\." equivalence)]]
["." / #_
["#." abstract]
@@ -192,12 +193,31 @@
example
(List a)))))
- (do {! random.monad}
+ (do random.monad
[sample random.nat]
(_.cover [/.:log!]
(exec
(/.:log! sample)
true)))
+ (do random.monad
+ [left random.nat
+ right (random.ascii/lower 1)
+ #let [left,right [left right]]]
+ (_.cover [/.:cast]
+ (|> left,right
+ (/.:cast [l r] (& l r) (| l r))
+ (/.:cast [l r] (| l r) (& l r))
+ (is? left,right))))
+ (do random.monad
+ [expected random.nat]
+ (_.cover [/.:share]
+ (n.= expected
+ (/.:share [a]
+ (I64 a)
+ expected
+
+ (I64 a)
+ (.i64 expected)))))
/abstract.test
/check.test
diff --git a/stdlib/source/test/lux/type/abstract.lux b/stdlib/source/test/lux/type/abstract.lux
index a023e1350..47d478f3f 100644
--- a/stdlib/source/test/lux/type/abstract.lux
+++ b/stdlib/source/test/lux/type/abstract.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["." meta]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["." exception]]
- [data
- ["." text ("#\." equivalence)]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]
- ["." template]]
- ["." math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." meta]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception]]
+ [data
+ ["." text ("#\." equivalence)]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]
+ ["." template]]
+ ["." math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(template.with_locals [g!Foo g!Bar]
diff --git a/stdlib/source/test/lux/type/check.lux b/stdlib/source/test/lux/type/check.lux
index b9f0f570f..949009d5b 100644
--- a/stdlib/source/test/lux/type/check.lux
+++ b/stdlib/source/test/lux/type/check.lux
@@ -1,32 +1,33 @@
(.module:
- [lux (#- type)
- ["_" test (#+ Test)]
- [abstract
- ["." monad (#+ do)]
- [\spec
- ["$." functor (#+ Injection Comparison)]
- ["$." apply]
- ["$." monad]]]
- [control
- [pipe (#+ case>)]
- ["." function]
- ["." try]
- ["." exception (#+ exception:)]]
- [data
- ["." bit ("#\." equivalence)]
- ["." product]
- ["." maybe]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." functor monoid)]
- ["." set]]]
- [math
- ["." random (#+ Random) ("#\." monad)]
- [number
- ["n" nat]]]
- ["." type ("#\." equivalence)]]
- [\\
+ [library
+ [lux (#- type)
+ ["_" test (#+ Test)]
+ [abstract
+ ["." monad (#+ do)]
+ [\\spec
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]]
+ [control
+ [pipe (#+ case>)]
+ ["." function]
+ ["." try]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." bit ("#\." equivalence)]
+ ["." product]
+ ["." maybe]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." functor monoid)]
+ ["." set]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]
+ [number
+ ["n" nat]]]
+ ["." type ("#\." equivalence)]]]
+ [\\library
["." /]])
## TODO: Remove the following 3 definitions ASAP. //.type already exists...
diff --git a/stdlib/source/test/lux/type/dynamic.lux b/stdlib/source/test/lux/type/dynamic.lux
index f9b5472f4..0c743cabf 100644
--- a/stdlib/source/test/lux/type/dynamic.lux
+++ b/stdlib/source/test/lux/type/dynamic.lux
@@ -1,19 +1,20 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try]
- ["." exception]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: #export test
diff --git a/stdlib/source/test/lux/type/implicit.lux b/stdlib/source/test/lux/type/implicit.lux
index 0387c1dd2..bf6db29e6 100644
--- a/stdlib/source/test/lux/type/implicit.lux
+++ b/stdlib/source/test/lux/type/implicit.lux
@@ -1,21 +1,22 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [equivalence (#+)]
- [functor (#+)]
- [monoid (#+)]
- [monad (#+ do)]
- ["." enum]]
- [data
- ["." bit ("#\." equivalence)]
- [collection
- ["." list]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [equivalence (#+)]
+ [functor (#+)]
+ [monoid (#+)]
+ [monad (#+ do)]
+ ["." enum]]
+ [data
+ ["." bit ("#\." equivalence)]
+ [collection
+ ["." list]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(/.implicit: [n.multiplication])
diff --git a/stdlib/source/test/lux/type/quotient.lux b/stdlib/source/test/lux/type/quotient.lux
index 962d2d2aa..11d711ac7 100644
--- a/stdlib/source/test/lux/type/quotient.lux
+++ b/stdlib/source/test/lux/type/quotient.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- ["." monad (#+ do)]
- [\spec
- ["$." equivalence]]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat ("#\." equivalence)]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ ["." monad (#+ do)]
+ [\\spec
+ ["$." equivalence]]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat ("#\." equivalence)]]]]]
+ [\\library
["." /]])
(def: #export (random class super)
diff --git a/stdlib/source/test/lux/type/refinement.lux b/stdlib/source/test/lux/type/refinement.lux
index 1e4e4da3b..6ee53edcd 100644
--- a/stdlib/source/test/lux/type/refinement.lux
+++ b/stdlib/source/test/lux/type/refinement.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [predicate (#+ Predicate)]
- [monad (#+ do)]]
- [data
- ["." maybe ("#\." monad)]
- [collection
- ["." list ("#\." functor)]]]
- [math
- ["." random]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [predicate (#+ Predicate)]
+ [monad (#+ do)]]
+ [data
+ ["." maybe ("#\." monad)]
+ [collection
+ ["." list ("#\." functor)]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(def: _refiner
diff --git a/stdlib/source/test/lux/type/resource.lux b/stdlib/source/test/lux/type/resource.lux
index e5061dc1e..859e8ca3f 100644
--- a/stdlib/source/test/lux/type/resource.lux
+++ b/stdlib/source/test/lux/type/resource.lux
@@ -1,27 +1,28 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["." meta]
- [abstract
- ["." monad
- [indexed (#+ do)]]]
- [control
- ["." io]
- ["." try]
- ["." exception (#+ Exception)]
- [concurrency
- ["." promise]]
- [parser
- ["<.>" code]]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]
- ["." macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- ["." random]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." meta]
+ [abstract
+ ["." monad
+ [indexed (#+ do)]]]
+ [control
+ ["." io]
+ ["." try]
+ ["." exception (#+ Exception)]
+ [concurrency
+ ["." promise]]
+ [parser
+ ["<.>" code]]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]
+ ["." macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ ["." random]]]]
+ [\\library
["." / (#+ Res)]])
(def: pure
diff --git a/stdlib/source/test/lux/type/unit.lux b/stdlib/source/test/lux/type/unit.lux
index aecce2374..6789d7b65 100644
--- a/stdlib/source/test/lux/type/unit.lux
+++ b/stdlib/source/test/lux/type/unit.lux
@@ -1,24 +1,25 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- ["." debug]
- ["." meta]
- [abstract
- [monad (#+ do)]
- [equivalence (#+ Equivalence)]
- [\spec
- ["$." equivalence]
- ["$." order]
- ["$." enum]]]
- [macro
- [syntax (#+ syntax:)]
- ["." code]]
- [math
- ["." random (#+ Random)]
- [number
- ["i" int]
- ["." ratio ("#\." equivalence)]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." debug]
+ ["." meta]
+ [abstract
+ [monad (#+ do)]
+ [equivalence (#+ Equivalence)]
+ [\\spec
+ ["$." equivalence]
+ ["$." order]
+ ["$." enum]]]
+ [macro
+ [syntax (#+ syntax:)]
+ ["." code]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["i" int]
+ ["." ratio ("#\." equivalence)]]]]]
+ [\\library
["." /]])
(template [<name> <type> <unit>]
diff --git a/stdlib/source/test/lux/type/variance.lux b/stdlib/source/test/lux/type/variance.lux
index d8f5aebf2..b0987e833 100644
--- a/stdlib/source/test/lux/type/variance.lux
+++ b/stdlib/source/test/lux/type/variance.lux
@@ -1,11 +1,12 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [math
+ ["." random (#+ Random)]]]]
+ [\\library
["." /
["/#" // #_
["#." check]]]])
diff --git a/stdlib/source/test/lux/world.lux b/stdlib/source/test/lux/world.lux
index c5ea26a6f..795b3e55c 100644
--- a/stdlib/source/test/lux/world.lux
+++ b/stdlib/source/test/lux/world.lux
@@ -1,6 +1,7 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]]]
["." / #_
["#." file]
["#." shell]
diff --git a/stdlib/source/test/lux/world/console.lux b/stdlib/source/test/lux/world/console.lux
index b153e84e9..055ee1466 100644
--- a/stdlib/source/test/lux/world/console.lux
+++ b/stdlib/source/test/lux/world/console.lux
@@ -1,18 +1,19 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io]
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]]
- [data
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]]
- [math
- ["." random]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]]
+ [math
+ ["." random]]]]
+ [\\library
["." /]]
[\\spec
["$." /]])
diff --git a/stdlib/source/test/lux/world/file.lux b/stdlib/source/test/lux/world/file.lux
index 0e5c61c8f..1074749f4 100644
--- a/stdlib/source/test/lux/world/file.lux
+++ b/stdlib/source/test/lux/world/file.lux
@@ -1,15 +1,16 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io]]
- [math
- ["." random]]]
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." io]]
+ [math
+ ["." random]]]]
["." / #_
["#." watch]]
- [\\
+ [\\library
["." /]]
[\\spec
["$." /]])
diff --git a/stdlib/source/test/lux/world/file/watch.lux b/stdlib/source/test/lux/world/file/watch.lux
index 9b9937a25..a4a8748ed 100644
--- a/stdlib/source/test/lux/world/file/watch.lux
+++ b/stdlib/source/test/lux/world/file/watch.lux
@@ -1,23 +1,24 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [predicate (#+ Predicate)]
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." binary (#+ Binary) ("#\." equivalence)]
- ["." text ("#\." equivalence)
- ["%" format (#+ format)]]
- [collection
- ["." list]]]
- [math
- ["." random (#+ Random) ("#\." monad)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [predicate (#+ Predicate)]
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." binary (#+ Binary) ("#\." equivalence)]
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list]]]
+ [math
+ ["." random (#+ Random) ("#\." monad)]]]]
+ [\\library
["." /
["/#" //]]]
[////
diff --git a/stdlib/source/test/lux/world/input/keyboard.lux b/stdlib/source/test/lux/world/input/keyboard.lux
index b58bff96f..f75907fad 100644
--- a/stdlib/source/test/lux/world/input/keyboard.lux
+++ b/stdlib/source/test/lux/world/input/keyboard.lux
@@ -1,21 +1,22 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [data
- ["." bit ("#\." equivalence)]
- ["." maybe]
- [collection
- ["." list]
- ["." set (#+ Set)]]]
- [macro
- ["." template]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [data
+ ["." bit ("#\." equivalence)]
+ ["." maybe]
+ [collection
+ ["." list]
+ ["." set (#+ Set)]]]
+ [macro
+ ["." template]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(with_expansions [<groups> (as_is [keys/commands
diff --git a/stdlib/source/test/lux/world/net/http/client.lux b/stdlib/source/test/lux/world/net/http/client.lux
index 612d599ff..c784d9cbe 100644
--- a/stdlib/source/test/lux/world/net/http/client.lux
+++ b/stdlib/source/test/lux/world/net/http/client.lux
@@ -1,25 +1,28 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- [pipe (#+ do>)]
- ["." io (#+ IO)]
- ["." try]
- ["." function]]
- [data
- ["." binary]
- ["." product]
- [text
- ["%" format (#+ format)]
- [encoding
- ["." utf8]]]]
- [math
- ["." random (#+ Random)]
- [number
- ["." nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ do>)]
+ ["." io (#+ IO)]
+ ["." try]
+ ["." function]]
+ [data
+ ["." binary]
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." dictionary]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["." nat]]]]]
+ [\\library
["." /
["/#" //
["#." status]]]])
@@ -28,7 +31,7 @@
Test
(<| (_.covering /._)
(_.for [/.Client])
- (do random.monad
+ (do {! random.monad}
[on_post random.nat
on_get random.nat
on_put random.nat
@@ -38,6 +41,8 @@
on_connect random.nat
on_options random.nat
on_trace random.nat
+ num_headers (\ ! map (nat.% 10) random.nat)
+ headers (random.dictionary text.hash num_headers (random.ascii/lower 3) (random.ascii/lower 3))
#let [mock (: (/.Client IO)
(implementation
(def: (request method url headers data)
@@ -81,4 +86,10 @@
[/.options on_options]
[/.trace on_trace]
))
+ (_.cover [/.headers]
+ (nat.= (dictionary.size headers)
+ (|> headers
+ dictionary.entries
+ /.headers
+ dictionary.size)))
)))))
diff --git a/stdlib/source/test/lux/world/net/http/status.lux b/stdlib/source/test/lux/world/net/http/status.lux
index 84fbf4b2c..b051d8e8e 100644
--- a/stdlib/source/test/lux/world/net/http/status.lux
+++ b/stdlib/source/test/lux/world/net/http/status.lux
@@ -1,16 +1,17 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [data
- [collection
- ["." list]
- ["." set (#+ Set)]]]
- [macro
- ["." template]]
- [math
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [data
+ [collection
+ ["." list]
+ ["." set (#+ Set)]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /
["/#" //]]])
diff --git a/stdlib/source/test/lux/world/output/video/resolution.lux b/stdlib/source/test/lux/world/output/video/resolution.lux
index ebeec3a65..1cfcd0ae8 100644
--- a/stdlib/source/test/lux/world/output/video/resolution.lux
+++ b/stdlib/source/test/lux/world/output/video/resolution.lux
@@ -1,21 +1,22 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]
- [\spec
- ["$." equivalence]
- ["$." hash]]]
- [data
- ["." maybe]
- [collection
- ["." list]
- ["." set (#+ Set)]]]
- [math
- ["." random (#+ Random)]
- [number
- ["n" nat]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [\\spec
+ ["$." equivalence]
+ ["$." hash]]]
+ [data
+ ["." maybe]
+ [collection
+ ["." list]
+ ["." set (#+ Set)]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /]])
(with_expansions [<resolutions> (as_is /.svga
diff --git a/stdlib/source/test/lux/world/program.lux b/stdlib/source/test/lux/world/program.lux
index d91d7fc62..fafda5f91 100644
--- a/stdlib/source/test/lux/world/program.lux
+++ b/stdlib/source/test/lux/world/program.lux
@@ -1,25 +1,36 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- [parser
- [environment (#+ Environment)]]]
- [data
- ["." text]]
- [math
- ["." random (#+ Random)]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." io]
+ ["." try]
+ ["." exception]
+ [parser
+ [environment (#+ Environment)]]]
+ [data
+ ["." maybe ("#\." functor)]
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." dictionary]
+ ["." list]]]
+ [math
+ ["." random (#+ Random)]
+ [number
+ ["n" nat]]]]]
+ [\\library
["." /
[//
[file (#+ Path)]]]]
[\\spec
["$." /]])
-(def: environment
- (Random Environment)
- (random.dictionary text.hash 5
+(def: (environment env_size)
+ (-> Nat (Random Environment))
+ (random.dictionary text.hash env_size
(random.ascii/alpha 5)
(random.ascii/alpha 5)))
@@ -30,11 +41,38 @@
(def: #export test
Test
(<| (_.covering /._)
- (do random.monad
- [environment ..environment
+ (do {! random.monad}
+ [env_size (\ ! map (|>> (n.% 10) inc) random.nat)
+ environment (..environment env_size)
home ..path
- directory ..path]
+ directory ..path
+
+ unknown (random.ascii/alpha 1)]
($_ _.and
(_.for [/.mock /.async]
($/.spec (/.async (/.mock environment home directory))))
+ (_.cover [/.environment]
+ (let [program (/.mock environment home directory)]
+ (io.run
+ (do io.monad
+ [actual (/.environment io.monad program)]
+ (wrap (and (n.= (dictionary.size environment)
+ (dictionary.size actual))
+ (|> actual
+ dictionary.entries
+ (list.every? (function (_ [key value])
+ (|> environment
+ (dictionary.get key)
+ (maybe\map (text\= value))
+ (maybe.default false)))))))))))
+ (_.cover [/.unknown_environment_variable]
+ (let [program (/.mock environment home directory)]
+ (|> unknown
+ (\ program variable)
+ io.run
+ (case> (#try.Success _)
+ false
+
+ (#try.Failure error)
+ (exception.match? /.unknown_environment_variable error)))))
))))
diff --git a/stdlib/source/test/lux/world/shell.lux b/stdlib/source/test/lux/world/shell.lux
index 4cbdb27ed..8d117eefa 100644
--- a/stdlib/source/test/lux/world/shell.lux
+++ b/stdlib/source/test/lux/world/shell.lux
@@ -1,26 +1,27 @@
(.module:
- [lux #*
- ["_" test (#+ Test)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["." exception (#+ exception:)]
- ["." io (#+ IO)]
- [concurrency
- ["." promise (#+ Promise)]]
- [parser
- ["." environment (#+ Environment)]]]
- [data
- ["." text ("#\." equivalence)]
- [collection
- ["." list]]]
- [math
- ["." random]
- [number
- ["n" nat]
- ["i" int]]]]
- [\\
+ [library
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO)]
+ [concurrency
+ ["." promise (#+ Promise)]]
+ [parser
+ ["." environment (#+ Environment)]]]
+ [data
+ ["." text ("#\." equivalence)]
+ [collection
+ ["." list]]]
+ [math
+ ["." random]
+ [number
+ ["n" nat]
+ ["i" int]]]]]
+ [\\library
["." /
[//
[file (#+ Path)]]]]